algol68g-3.1.2/0000755000175000017500000000000014361065617010152 500000000000000algol68g-3.1.2/configure0000755000175000017500000101415314361065447012007 00000000000000#! /bin/sh # Guess values for system-dependent variables and create Makefiles. # Generated by GNU Autoconf 2.69 for algol68g 3.1.2. # # Report bugs to >. # # # Copyright (C) 1992-1996, 1998-2012 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 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 # Prefer a ksh shell builtin over an external printf program on Solaris, # but without wasting forks for bash or zsh. if test -z "$BASH_VERSION$ZSH_VERSION" \ && (test "X`print -r -- $as_echo`" = "X$as_echo") 2>/dev/null; then as_echo='print -r --' as_echo_n='print -rn --' elif (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 # 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. as_myself= 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 fi # Unset variables that we do not need and which cause bugs (e.g. in # pre-3.0 UWIN ksh). But do not cause bugs in bash 2.01; the "|| exit 1" # suppresses any "Segmentation fault" message there. '((' could # trigger a bug in pdksh 5.2.14. for as_var in BASH_ENV ENV MAIL MAILPATH do eval test x\${$as_var+set} = xset \ && ( (unset $as_var) || exit 1) >/dev/null 2>&1 && unset $as_var || : done PS1='$ ' PS2='> ' PS4='+ ' # NLS nuisances. LC_ALL=C export LC_ALL LANGUAGE=C export LANGUAGE # CDPATH. (unset CDPATH) >/dev/null 2>&1 && unset CDPATH # Use a proper internal environment variable to ensure we don't fall # into an infinite loop, continuously re-executing ourselves. if test x"${_as_can_reexec}" != xno && test "x$CONFIG_SHELL" != x; then _as_can_reexec=no; export _as_can_reexec; # We cannot yet assume a decent shell, so we have to provide a # neutralization value for shells without unset; and this also # works around shells that cannot unset nonexistent variables. # Preserve -v and -x to the replacement shell. BASH_ENV=/dev/null ENV=/dev/null (unset BASH_ENV) >/dev/null 2>&1 && unset BASH_ENV ENV case $- in # (((( *v*x* | *x*v* ) as_opts=-vx ;; *v* ) as_opts=-v ;; *x* ) as_opts=-x ;; * ) as_opts= ;; esac exec $CONFIG_SHELL $as_opts "$as_myself" ${1+"$@"} # Admittedly, this is quite paranoid, since all the known shells bail # out after a failed `exec'. $as_echo "$0: could not re-execute with $CONFIG_SHELL" >&2 as_fn_exit 255 fi # We don't want this to propagate to other subprocesses. { _as_can_reexec=; unset _as_can_reexec;} if test "x$CONFIG_SHELL" = x; then as_bourne_compatible="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_required="as_fn_return () { (exit \$1); } as_fn_success () { as_fn_return 0; } as_fn_failure () { as_fn_return 1; } as_fn_ret_success () { return 0; } as_fn_ret_failure () { return 1; } exitcode=0 as_fn_success || { exitcode=1; echo as_fn_success failed.; } as_fn_failure && { exitcode=1; echo as_fn_failure succeeded.; } as_fn_ret_success || { exitcode=1; echo as_fn_ret_success failed.; } as_fn_ret_failure && { exitcode=1; echo as_fn_ret_failure succeeded.; } if ( set x; as_fn_ret_success y && test x = \"\$1\" ); then : else exitcode=1; echo positional parameters were not saved. fi test x\$exitcode = x0 || exit 1 test -x / || exit 1" as_suggested=" as_lineno_1=";as_suggested=$as_suggested$LINENO;as_suggested=$as_suggested" as_lineno_1a=\$LINENO as_lineno_2=";as_suggested=$as_suggested$LINENO;as_suggested=$as_suggested" as_lineno_2a=\$LINENO eval 'test \"x\$as_lineno_1'\$as_run'\" != \"x\$as_lineno_2'\$as_run'\" && test \"x\`expr \$as_lineno_1'\$as_run' + 1\`\" = \"x\$as_lineno_2'\$as_run'\"' || exit 1 test \$(( 1 + 1 )) = 2 || exit 1" if (eval "$as_required") 2>/dev/null; then : as_have_required=yes else as_have_required=no fi if test x$as_have_required = xyes && (eval "$as_suggested") 2>/dev/null; then : else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR as_found=false for as_dir in /bin$PATH_SEPARATOR/usr/bin$PATH_SEPARATOR$PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. as_found=: case $as_dir in #( /*) for as_base in sh bash ksh sh5; do # Try only shells that exist, to save several forks. as_shell=$as_dir/$as_base if { test -f "$as_shell" || test -f "$as_shell.exe"; } && { $as_echo "$as_bourne_compatible""$as_required" | as_run=a "$as_shell"; } 2>/dev/null; then : CONFIG_SHELL=$as_shell as_have_required=yes if { $as_echo "$as_bourne_compatible""$as_suggested" | as_run=a "$as_shell"; } 2>/dev/null; then : break 2 fi fi done;; esac as_found=false done $as_found || { if { test -f "$SHELL" || test -f "$SHELL.exe"; } && { $as_echo "$as_bourne_compatible""$as_required" | as_run=a "$SHELL"; } 2>/dev/null; then : CONFIG_SHELL=$SHELL as_have_required=yes fi; } IFS=$as_save_IFS if test "x$CONFIG_SHELL" != x; then : export CONFIG_SHELL # We cannot yet assume a decent shell, so we have to provide a # neutralization value for shells without unset; and this also # works around shells that cannot unset nonexistent variables. # Preserve -v and -x to the replacement shell. BASH_ENV=/dev/null ENV=/dev/null (unset BASH_ENV) >/dev/null 2>&1 && unset BASH_ENV ENV case $- in # (((( *v*x* | *x*v* ) as_opts=-vx ;; *v* ) as_opts=-v ;; *x* ) as_opts=-x ;; * ) as_opts= ;; esac exec $CONFIG_SHELL $as_opts "$as_myself" ${1+"$@"} # Admittedly, this is quite paranoid, since all the known shells bail # out after a failed `exec'. $as_echo "$0: could not re-execute with $CONFIG_SHELL" >&2 exit 255 fi if test x$as_have_required = xno; then : $as_echo "$0: This script requires a shell more modern than all" $as_echo "$0: the shells that I found on your system." if test x${ZSH_VERSION+set} = xset ; then $as_echo "$0: In particular, zsh $ZSH_VERSION has bugs and should" $as_echo "$0: be upgraded to zsh 4.3.4 or later." else $as_echo "$0: Please tell bug-autoconf@gnu.org and Marcel van der $0: Veer about your system, including $0: any error possibly output before this message. Then $0: install a modern shell, or manually run the script $0: under such a shell if you do have one." fi exit 1 fi fi fi SHELL=${CONFIG_SHELL-/bin/sh} export SHELL # Unset more variables known to interfere with behavior of common tools. CLICOLOR_FORCE= GREP_OPTIONS= unset CLICOLOR_FORCE GREP_OPTIONS ## --------------------- ## ## M4sh Shell Functions. ## ## --------------------- ## # as_fn_unset VAR # --------------- # Portably unset VAR. as_fn_unset () { { eval $1=; unset $1;} } as_unset=as_fn_unset # as_fn_set_status STATUS # ----------------------- # Set $? to STATUS, without forking. as_fn_set_status () { return $1 } # as_fn_set_status # as_fn_exit STATUS # ----------------- # Exit the shell with STATUS, even in a "trap 0" or "set -e" context. as_fn_exit () { set +e as_fn_set_status $1 exit $1 } # as_fn_exit # as_fn_mkdir_p # ------------- # Create "$as_dir" as a directory, including parents if necessary. as_fn_mkdir_p () { case $as_dir in #( -*) as_dir=./$as_dir;; esac test -d "$as_dir" || eval $as_mkdir_p || { 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_fn_error $? "cannot create directory $as_dir" } # as_fn_mkdir_p # as_fn_executable_p FILE # ----------------------- # Test if FILE is an executable regular file. as_fn_executable_p () { test -f "$1" && test -x "$1" } # as_fn_executable_p # as_fn_append VAR VALUE # ---------------------- # Append the text in VALUE to the end of the definition contained in VAR. Take # advantage of any shell optimizations that allow amortized linear growth over # repeated appends, instead of the typical quadratic growth present in naive # implementations. if (eval "as_var=1; as_var+=2; test x\$as_var = x12") 2>/dev/null; then : eval 'as_fn_append () { eval $1+=\$2 }' else as_fn_append () { eval $1=\$$1\$2 } fi # as_fn_append # as_fn_arith ARG... # ------------------ # Perform arithmetic evaluation on the ARGs, and store the result in the # global $as_val. Take advantage of shells that can avoid forks. The arguments # must be portable across $(()) and expr. if (eval "test \$(( 1 + 1 )) = 2") 2>/dev/null; then : eval 'as_fn_arith () { as_val=$(( $* )) }' else as_fn_arith () { as_val=`expr "$@" || test $? -eq 1` } fi # as_fn_arith # as_fn_error STATUS ERROR [LINENO LOG_FD] # ---------------------------------------- # Output "`basename $0`: error: ERROR" to stderr. If LINENO and LOG_FD are # provided, also output the error to LOG_FD, referencing LINENO. Then exit the # script with STATUS, using 1 if that was 0. as_fn_error () { as_status=$1; test $as_status -eq 0 && as_status=1 if test "$4"; then as_lineno=${as_lineno-"$3"} as_lineno_stack=as_lineno_stack=$as_lineno_stack $as_echo "$as_me:${as_lineno-$LINENO}: error: $2" >&$4 fi $as_echo "$as_me: error: $2" >&2 as_fn_exit $as_status } # as_fn_error 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 if (as_dir=`dirname -- /` && test "X$as_dir" = X/) >/dev/null 2>&1; then as_dirname=dirname else as_dirname=false fi 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'` # 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_lineno_1=$LINENO as_lineno_1a=$LINENO as_lineno_2=$LINENO as_lineno_2a=$LINENO eval 'test "x$as_lineno_1'$as_run'" != "x$as_lineno_2'$as_run'" && test "x`expr $as_lineno_1'$as_run' + 1`" = "x$as_lineno_2'$as_run'"' || { # 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; as_fn_exit 1; } # If we had to re-execute with $CONFIG_SHELL, we're ensured to have # already done that, so ensure we don't try to do so again and fall # in an infinite loop. This has already happened in practice. _as_can_reexec=no; export _as_can_reexec # 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 } ECHO_C= ECHO_N= ECHO_T= case `echo -n x` in #((((( -n*) case `echo 'xy\c'` in *c*) ECHO_T=' ';; # ECHO_T is single tab character. xy) ECHO_C='\c';; *) echo `echo ksh88 bug on AIX 6.1` > /dev/null ECHO_T=' ';; esac;; *) ECHO_N='-n';; esac 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 -pR'. ln -s conf$$.file conf$$.dir 2>/dev/null && test ! -f conf$$.exe || as_ln_s='cp -pR' elif ln conf$$.file conf$$ 2>/dev/null; then as_ln_s=ln else as_ln_s='cp -pR' fi else as_ln_s='cp -pR' 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='mkdir -p "$as_dir"' else test -d ./-p && rmdir ./-p as_mkdir_p=false fi as_test_x='test -x' as_executable_p=as_fn_executable_p # 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'" test -n "$DJDIR" || exec 7<&0 &1 # Name of the host. # hostname on some systems (SVR3.2, old GNU/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= # Identity of this package. PACKAGE_NAME='algol68g' PACKAGE_TARNAME='algol68g' PACKAGE_VERSION='3.1.2' PACKAGE_STRING='algol68g 3.1.2' PACKAGE_BUGREPORT='Marcel van der Veer ' PACKAGE_URL='' ac_default_prefix=/usr/local ac_unique_file="src/include/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='am__EXEEXT_FALSE am__EXEEXT_TRUE LTLIBOBJS LIBOBJS GSL_LIBS GSL_CFLAGS GSL_CONFIG EGREP GREP CPP EXPORT_DYNAMIC_FALSE EXPORT_DYNAMIC_TRUE am__fastdepCC_FALSE am__fastdepCC_TRUE CCDEPMODE am__nodep AMDEPBACKSLASH AMDEP_FALSE AMDEP_TRUE am__include DEPDIR OBJEXT EXEEXT ac_ct_CC CPPFLAGS LDFLAGS CFLAGS CC a68g_exists AM_BACKSLASH AM_DEFAULT_VERBOSITY AM_DEFAULT_V AM_V 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 runstatedir localstatedir sharedstatedir sysconfdir datadir datarootdir libexecdir sbindir bindir program_transform_name prefix exec_prefix PACKAGE_URL PACKAGE_BUGREPORT PACKAGE_STRING PACKAGE_VERSION PACKAGE_TARNAME PACKAGE_NAME PATH_SEPARATOR SHELL am__quote' ac_subst_files='' ac_user_opts=' enable_option_checking enable_generic enable_compiler enable_quadmath enable_mathlib enable_curses enable_gsl enable_mpfr enable_parallel enable_plotutils enable_postgresql enable_readline enable_standard_types enable_long_types enable_pic enable_arch enable_silent_rules enable_dependency_tracking enable_assert with_gsl_prefix with_gsl_exec_prefix enable_gsltest ' 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' runstatedir='${localstatedir}/run' 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= ;; *) 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_fn_error $? "invalid feature name: $ac_useropt" 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_fn_error $? "invalid feature name: $ac_useropt" 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 ;; -runstatedir | --runstatedir | --runstatedi | --runstated \ | --runstate | --runstat | --runsta | --runst | --runs \ | --run | --ru | --r) ac_prev=runstatedir ;; -runstatedir=* | --runstatedir=* | --runstatedi=* | --runstated=* \ | --runstate=* | --runstat=* | --runsta=* | --runst=* | --runs=* \ | --run=* | --ru=* | --r=*) runstatedir=$ac_optarg ;; -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_fn_error $? "invalid package name: $ac_useropt" 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_fn_error $? "invalid package name: $ac_useropt" 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_fn_error $? "unrecognized option: \`$ac_option' Try \`$0 --help' for more information" ;; *=*) ac_envvar=`expr "x$ac_option" : 'x\([^=]*\)='` # Reject names that are not valid shell variable names. case $ac_envvar in #( '' | [0-9]* | *[!_$as_cr_alnum]* ) as_fn_error $? "invalid variable name: \`$ac_envvar'" ;; esac 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_fn_error $? "missing argument to $ac_option" fi if test -n "$ac_unrecognized_opts"; then case $enable_option_checking in no) ;; fatal) as_fn_error $? "unrecognized options: $ac_unrecognized_opts" ;; *) $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 runstatedir 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_fn_error $? "expected an absolute directory name for --$ac_var: $ac_val" 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 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_fn_error $? "working directory cannot be determined" test "X$ac_ls_di" = "X$ac_pwd_ls_di" || as_fn_error $? "pwd does not report name of working directory" # 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_fn_error $? "cannot find sources ($ac_unique_file) in $srcdir" fi ac_msg="sources are in $srcdir, but \`cd $srcdir' does not work" ac_abs_confdir=`( cd "$srcdir" && test -r "./$ac_unique_file" || as_fn_error $? "$ac_msg" 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 3.1.2 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] --runstatedir=DIR modifiable per-process data [LOCALSTATEDIR/run] --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 3.1.2:";; 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-generic build for legacy 32 bit systems (default is "no") --enable-compiler enable unit compiler (default is "yes") --enable-quadmath if available, enable GCC quadmath library (default is "yes") --enable-mathlib if available, enable R mathlib library (default is "yes") --enable-curses if available, enable curses library (default is "yes") --enable-gsl if available, enable GNU scientific library (default is "yes") --enable-mpfr if available, enable GNU MPFR (default is "yes") --enable-parallel enable Algol 68 parallel-clause (default is "yes") --enable-plotutils if available, enable GNU plotting utilities (default is "yes") --enable-postgresql if available, enable PostgreSQL (default is "yes") --enable-readline if available, enable readline library (default is "yes") --enable-standard-types enable int*4 and real*8 modes (default is "yes") --enable-long-types if available, enable int*8 and real*10, real*16 modes (default is "yes") --enable-pic=option if using gcc, enable option to generate PIC (default is "-fPIC") --enable-arch=cpu if using gcc, enable emitting architecture-tuned assembly code (default is "no") --enable-silent-rules less verbose build output (undo: "make V=1") --disable-silent-rules verbose build output (undo: "make V=0") --enable-dependency-tracking do not reject slow dependency extractors --disable-dependency-tracking speeds up one-time build --disable-assert turn off assertions --disable-gsltest Do not try to compile and run a test GSL program Optional Packages: --with-PACKAGE[=ARG] use PACKAGE [ARG=yes] --without-PACKAGE do not use PACKAGE (same as --with-PACKAGE=no) --with-gsl-prefix=PFX Prefix where GSL is installed (optional) --with-gsl-exec-prefix=PFX Exec prefix where GSL is installed (optional) 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 (Objective) C/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 3.1.2 generated by GNU Autoconf 2.69 Copyright (C) 2012 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 ## ------------------------ ## ## Autoconf initialization. ## ## ------------------------ ## # ac_fn_c_try_compile LINENO # -------------------------- # Try to compile conftest.$ac_ext, and return whether this succeeded. ac_fn_c_try_compile () { as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack 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:${as_lineno-$LINENO}: $ac_try_echo\"" $as_echo "$ac_try_echo"; } >&5 (eval "$ac_compile") 2>conftest.err ac_status=$? if test -s conftest.err; then grep -v '^ *+' conftest.err >conftest.er1 cat conftest.er1 >&5 mv -f conftest.er1 conftest.err fi $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 test $ac_status = 0; } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then : ac_retval=0 else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_retval=1 fi eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno as_fn_set_status $ac_retval } # ac_fn_c_try_compile # ac_fn_c_try_run LINENO # ---------------------- # Try to link conftest.$ac_ext, and return whether this succeeded. Assumes # that executables *can* be run. ac_fn_c_try_run () { as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack 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:${as_lineno-$LINENO}: $ac_try_echo\"" $as_echo "$ac_try_echo"; } >&5 (eval "$ac_link") 2>&5 ac_status=$? $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 test $ac_status = 0; } && { 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:${as_lineno-$LINENO}: $ac_try_echo\"" $as_echo "$ac_try_echo"; } >&5 (eval "$ac_try") 2>&5 ac_status=$? $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 test $ac_status = 0; }; }; then : ac_retval=0 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 ac_retval=$ac_status fi rm -rf conftest.dSYM conftest_ipa8_conftest.oo eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno as_fn_set_status $ac_retval } # ac_fn_c_try_run # ac_fn_c_try_cpp LINENO # ---------------------- # Try to preprocess conftest.$ac_ext, and return whether this succeeded. ac_fn_c_try_cpp () { as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack 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:${as_lineno-$LINENO}: $ac_try_echo\"" $as_echo "$ac_try_echo"; } >&5 (eval "$ac_cpp conftest.$ac_ext") 2>conftest.err ac_status=$? if test -s conftest.err; then grep -v '^ *+' conftest.err >conftest.er1 cat conftest.er1 >&5 mv -f conftest.er1 conftest.err fi $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 test $ac_status = 0; } > conftest.i && { test -z "$ac_c_preproc_warn_flag$ac_c_werror_flag" || test ! -s conftest.err }; then : ac_retval=0 else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_retval=1 fi eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno as_fn_set_status $ac_retval } # ac_fn_c_try_cpp # ac_fn_c_check_header_compile LINENO HEADER VAR INCLUDES # ------------------------------------------------------- # Tests whether HEADER exists and can be compiled using the include files in # INCLUDES, setting the cache variable VAR accordingly. ac_fn_c_check_header_compile () { as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $2" >&5 $as_echo_n "checking for $2... " >&6; } if eval \${$3+:} false; then : $as_echo_n "(cached) " >&6 else cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ $4 #include <$2> _ACEOF if ac_fn_c_try_compile "$LINENO"; then : eval "$3=yes" else eval "$3=no" fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi eval ac_res=\$$3 { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5 $as_echo "$ac_res" >&6; } eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno } # ac_fn_c_check_header_compile # ac_fn_c_check_type LINENO TYPE VAR INCLUDES # ------------------------------------------- # Tests whether TYPE exists after having included INCLUDES, setting cache # variable VAR accordingly. ac_fn_c_check_type () { as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $2" >&5 $as_echo_n "checking for $2... " >&6; } if eval \${$3+:} false; then : $as_echo_n "(cached) " >&6 else eval "$3=no" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ $4 int main () { if (sizeof ($2)) return 0; ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO"; then : cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ $4 int main () { if (sizeof (($2))) return 0; ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO"; then : else eval "$3=yes" 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 eval ac_res=\$$3 { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5 $as_echo "$ac_res" >&6; } eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno } # ac_fn_c_check_type # ac_fn_c_find_uintX_t LINENO BITS VAR # ------------------------------------ # Finds an unsigned integer type with width BITS, setting cache variable VAR # accordingly. ac_fn_c_find_uintX_t () { as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack { $as_echo "$as_me:${as_lineno-$LINENO}: checking for uint$2_t" >&5 $as_echo_n "checking for uint$2_t... " >&6; } if eval \${$3+:} false; then : $as_echo_n "(cached) " >&6 else eval "$3=no" # Order is important - never check a type that is potentially smaller # than half of the expected target width. for ac_type in uint$2_t 'unsigned int' 'unsigned long int' \ 'unsigned long long int' 'unsigned short int' 'unsigned char'; do cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ $ac_includes_default int main () { static int test_array [1 - 2 * !((($ac_type) -1 >> ($2 / 2 - 1)) >> ($2 / 2 - 1) == 3)]; test_array [0] = 0; return test_array [0]; ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO"; then : case $ac_type in #( uint$2_t) : eval "$3=yes" ;; #( *) : eval "$3=\$ac_type" ;; esac fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext if eval test \"x\$"$3"\" = x"no"; then : else break fi done fi eval ac_res=\$$3 { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5 $as_echo "$ac_res" >&6; } eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno } # ac_fn_c_find_uintX_t # ac_fn_c_check_header_mongrel LINENO HEADER VAR INCLUDES # ------------------------------------------------------- # Tests whether HEADER exists, giving a warning if it cannot be compiled using # the include files in INCLUDES and setting the cache variable VAR # accordingly. ac_fn_c_check_header_mongrel () { as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack if eval \${$3+:} false; then : { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $2" >&5 $as_echo_n "checking for $2... " >&6; } if eval \${$3+:} false; then : $as_echo_n "(cached) " >&6 fi eval ac_res=\$$3 { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5 $as_echo "$ac_res" >&6; } else # Is the header compilable? { $as_echo "$as_me:${as_lineno-$LINENO}: checking $2 usability" >&5 $as_echo_n "checking $2 usability... " >&6; } cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ $4 #include <$2> _ACEOF if ac_fn_c_try_compile "$LINENO"; then : ac_header_compiler=yes else ac_header_compiler=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_header_compiler" >&5 $as_echo "$ac_header_compiler" >&6; } # Is the header present? { $as_echo "$as_me:${as_lineno-$LINENO}: checking $2 presence" >&5 $as_echo_n "checking $2 presence... " >&6; } cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include <$2> _ACEOF if ac_fn_c_try_cpp "$LINENO"; then : ac_header_preproc=yes else ac_header_preproc=no fi rm -f conftest.err conftest.i conftest.$ac_ext { $as_echo "$as_me:${as_lineno-$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:${as_lineno-$LINENO}: WARNING: $2: accepted by the compiler, rejected by the preprocessor!" >&5 $as_echo "$as_me: WARNING: $2: accepted by the compiler, rejected by the preprocessor!" >&2;} { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $2: proceeding with the compiler's result" >&5 $as_echo "$as_me: WARNING: $2: proceeding with the compiler's result" >&2;} ;; no:yes:* ) { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $2: present but cannot be compiled" >&5 $as_echo "$as_me: WARNING: $2: present but cannot be compiled" >&2;} { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $2: check for missing prerequisite headers?" >&5 $as_echo "$as_me: WARNING: $2: check for missing prerequisite headers?" >&2;} { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $2: see the Autoconf documentation" >&5 $as_echo "$as_me: WARNING: $2: see the Autoconf documentation" >&2;} { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $2: section \"Present But Cannot Be Compiled\"" >&5 $as_echo "$as_me: WARNING: $2: section \"Present But Cannot Be Compiled\"" >&2;} { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $2: proceeding with the compiler's result" >&5 $as_echo "$as_me: WARNING: $2: proceeding with the compiler's result" >&2;} ( $as_echo "## ------------------------------------------------------- ## ## Report this to Marcel van der Veer ## ## ------------------------------------------------------- ##" ) | sed "s/^/$as_me: WARNING: /" >&2 ;; esac { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $2" >&5 $as_echo_n "checking for $2... " >&6; } if eval \${$3+:} false; then : $as_echo_n "(cached) " >&6 else eval "$3=\$ac_header_compiler" fi eval ac_res=\$$3 { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5 $as_echo "$ac_res" >&6; } fi eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno } # ac_fn_c_check_header_mongrel # ac_fn_c_try_link LINENO # ----------------------- # Try to link conftest.$ac_ext, and return whether this succeeded. ac_fn_c_try_link () { as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack 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:${as_lineno-$LINENO}: $ac_try_echo\"" $as_echo "$ac_try_echo"; } >&5 (eval "$ac_link") 2>conftest.err ac_status=$? if test -s conftest.err; then grep -v '^ *+' conftest.err >conftest.er1 cat conftest.er1 >&5 mv -f conftest.er1 conftest.err fi $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 test $ac_status = 0; } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || test -x conftest$ac_exeext }; then : ac_retval=0 else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_retval=1 fi # Delete the IPA/IPO (Inter Procedural Analysis/Optimization) information # created by the PGI compiler (conftest_ipa8_conftest.oo), as it would # interfere with the next link command; also delete a directory that is # left behind by Apple's compiler. We do this before executing the actions. rm -rf conftest.dSYM conftest_ipa8_conftest.oo eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno as_fn_set_status $ac_retval } # ac_fn_c_try_link # ac_fn_c_check_func LINENO FUNC VAR # ---------------------------------- # Tests whether FUNC exists, setting the cache variable VAR accordingly ac_fn_c_check_func () { as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $2" >&5 $as_echo_n "checking for $2... " >&6; } if eval \${$3+:} false; then : $as_echo_n "(cached) " >&6 else cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ /* Define $2 to an innocuous variant, in case declares $2. For example, HP-UX 11i declares gettimeofday. */ #define $2 innocuous_$2 /* System header to define __stub macros and hopefully few prototypes, which can conflict with char $2 (); below. Prefer to if __STDC__ is defined, since exists even on freestanding compilers. */ #ifdef __STDC__ # include #else # include #endif #undef $2 /* 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 $2 (); /* 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_$2 || defined __stub___$2 choke me #endif int main () { return $2 (); ; return 0; } _ACEOF if ac_fn_c_try_link "$LINENO"; then : eval "$3=yes" else eval "$3=no" fi rm -f core conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext fi eval ac_res=\$$3 { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5 $as_echo "$ac_res" >&6; } eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno } # ac_fn_c_check_func 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 3.1.2, which was generated by GNU Autoconf 2.69. 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) as_fn_append ac_configure_args0 " '$ac_arg'" ;; 2) as_fn_append 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 as_fn_append ac_configure_args " '$ac_arg'" ;; esac done done { ac_configure_args0=; unset ac_configure_args0;} { ac_configure_args1=; unset 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 $as_echo "## ---------------- ## ## Cache variables. ## ## ---------------- ##" 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:${as_lineno-$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= ;; #( *) { eval $ac_var=; 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 $as_echo "## ----------------- ## ## Output variables. ## ## ----------------- ##" 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 $as_echo "## ------------------- ## ## File substitutions. ## ## ------------------- ##" 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 $as_echo "## ----------- ## ## confdefs.h. ## ## ----------- ##" 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'; as_fn_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 $as_echo "/* confdefs.h */" > 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 cat >>confdefs.h <<_ACEOF #define PACKAGE_URL "$PACKAGE_URL" _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 # We do not want a PATH search for config.site. case $CONFIG_SITE in #(( -*) ac_site_file1=./$CONFIG_SITE;; */*) ac_site_file1=$CONFIG_SITE;; *) ac_site_file1=./$CONFIG_SITE;; esac 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 /dev/null != "$ac_site_file" && test -r "$ac_site_file"; then { $as_echo "$as_me:${as_lineno-$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" \ || { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error $? "failed to load site script $ac_site_file See \`config.log' for more details" "$LINENO" 5; } 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. DJGPP emulates it as a regular file. if test /dev/null != "$cache_file" && test -f "$cache_file"; then { $as_echo "$as_me:${as_lineno-$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:${as_lineno-$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:${as_lineno-$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:${as_lineno-$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:${as_lineno-$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:${as_lineno-$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:${as_lineno-$LINENO}: former value: \`$ac_old_val'" >&5 $as_echo "$as_me: former value: \`$ac_old_val'" >&2;} { $as_echo "$as_me:${as_lineno-$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. *) as_fn_append ac_configure_args " '$ac_arg'" ;; esac fi done if $ac_cache_corrupted; then { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} { $as_echo "$as_me:${as_lineno-$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_fn_error $? "run \`make distclean' and/or \`rm $cache_file' and start over" "$LINENO" 5 fi ## -------------------- ## ## Main body of script. ## ## -------------------- ## 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 # Check whether compiler supports $1 as a command-line option. # If it does, add the string to CFLAGS. # Configure path for the GNU Scientific Library # Christopher R. Gabriel , April 2000 # This is what autoupdate's m4 run will expand. It fires # the warning (with _au_warn_XXX), outputs it into the # updated configure.ac (with AC_DIAGNOSE), and then outputs # the replacement expansion. # This is an auxiliary macro that is also run when # autoupdate runs m4. It simply calls m4_warning, but # we need a wrapper so that each warning is emitted only # once. We break the quoting in m4_warning's argument in # order to expand this macro's arguments, not AU_DEFUN's. # Finally, this is the expansion that is picked up by # autoconf. It tells the user to run autoupdate, and # then outputs the replacement expansion. We do not care # about autoupdate's warning because that contains # information on what to do *after* running autoupdate. # # Platform ids. # { $as_echo "$as_me:${as_lineno-$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_fn_error $? "cannot find install-sh, install.sh, or shtool in \"$srcdir\" \"$srcdir/..\" \"$srcdir/../..\"" "$LINENO" 5 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_fn_error $? "cannot run $SHELL $ac_aux_dir/config.sub" "$LINENO" 5 { $as_echo "$as_me:${as_lineno-$LINENO}: checking build system type" >&5 $as_echo_n "checking build system type... " >&6; } if ${ac_cv_build+:} false; 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_fn_error $? "cannot guess build type; you must specify one" "$LINENO" 5 ac_cv_build=`$SHELL "$ac_aux_dir/config.sub" $ac_build_alias` || as_fn_error $? "$SHELL $ac_aux_dir/config.sub $ac_build_alias failed" "$LINENO" 5 fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_build" >&5 $as_echo "$ac_cv_build" >&6; } case $ac_cv_build in *-*-*) ;; *) as_fn_error $? "invalid value of canonical build" "$LINENO" 5;; 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:${as_lineno-$LINENO}: checking host system type" >&5 $as_echo_n "checking host system type... " >&6; } if ${ac_cv_host+:} false; 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_fn_error $? "$SHELL $ac_aux_dir/config.sub $host_alias failed" "$LINENO" 5 fi fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_host" >&5 $as_echo "$ac_cv_host" >&6; } case $ac_cv_host in *-*-*) ;; *) as_fn_error $? "invalid value of canonical host" "$LINENO" 5;; 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:${as_lineno-$LINENO}: checking target system type" >&5 $as_echo_n "checking target system type... " >&6; } if ${ac_cv_target+:} false; 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_fn_error $? "$SHELL $ac_aux_dir/config.sub $target_alias failed" "$LINENO" 5 fi fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_target" >&5 $as_echo "$ac_cv_target" >&6; } case $ac_cv_target in *-*-*) ;; *) as_fn_error $? "invalid value of canonical target" "$LINENO" 5;; 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}- bsd_include_dirs=no enable_haiku=no { $as_echo "$as_me:${as_lineno-$LINENO}: checking platform" >&5 $as_echo_n "checking platform... " >&6; } case "$host" in # # Linux. # # aarch64*-*-linux* is for RaspberryPi-4 on ARM-64 - otherwise http/tcp isnt found # Generic *-*-linux-gnu catches for instance s390x-ibm-linux-gnu # *86-*-gnu | *86_64-*-gnu | *86-*-linux* | *86_64-*-linux* | arm*-*-linux* | aarch*-*-linux* | *-*-linux-gnu) $as_echo "#define BUILD_LINUX 1" >>confdefs.h $as_echo "#define HAVE_IEEE_754 1" >>confdefs.h { $as_echo "$as_me:${as_lineno-$LINENO}: result: linux" >&5 $as_echo "linux" >&6; } ;; # # Cygwin. # *86-*-cygwin* | *86_64-*-cygwin*) $as_echo "#define BUILD_CYGWIN 1" >>confdefs.h $as_echo "#define HAVE_IEEE_754 1" >>confdefs.h { $as_echo "$as_me:${as_lineno-$LINENO}: result: cygwin" >&5 $as_echo "cygwin" >&6; } ;; # # Mac OS X. # *86-*-*darwin* | *86_64-*-*darwin*) $as_echo "#define BUILD_BSD 1" >>confdefs.h $as_echo "#define HAVE_IEEE_754 1" >>confdefs.h { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: configuring interpreter-only" >&5 $as_echo "$as_me: WARNING: configuring interpreter-only" >&2;} { $as_echo "$as_me:${as_lineno-$LINENO}: result: mac os x" >&5 $as_echo "mac os x" >&6; } ;; # # FreeBSD. # *86-*-freebsd* | *86_64-*-freebsd*) $as_echo "#define BUILD_BSD 1" >>confdefs.h $as_echo "#define HAVE_IEEE_754 1" >>confdefs.h { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: configuring interpreter-only" >&5 $as_echo "$as_me: WARNING: configuring interpreter-only" >&2;} { $as_echo "$as_me:${as_lineno-$LINENO}: result: freebsd" >&5 $as_echo "freebsd" >&6; } ;; # # NetBSD. # *86-*-netbsd* | *86_64-*-netbsd*) $as_echo "#define BUILD_BSD 1" >>confdefs.h $as_echo "#define HAVE_IEEE_754 1" >>confdefs.h { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: configuring interpreter-only" >&5 $as_echo "$as_me: WARNING: configuring interpreter-only" >&2;} { $as_echo "$as_me:${as_lineno-$LINENO}: result: netbsd" >&5 $as_echo "netbsd" >&6; } ;; # # OpenBSD. # *86-*-openbsd* | *86_64-*-openbsd*) $as_echo "#define BUILD_BSD 1" >>confdefs.h $as_echo "#define HAVE_IEEE_754 1" >>confdefs.h bsd_include_dirs=yes { $as_echo "$as_me:${as_lineno-$LINENO}: result: openbsd" >&5 $as_echo "openbsd" >&6; } ;; # # Haiku. # *86-*-haiku* | *86_64-*-haiku*) $as_echo "#define BUILD_HAIKU 1" >>confdefs.h $as_echo "#define HAVE_IEEE_754 1" >>confdefs.h { $as_echo "$as_me:${as_lineno-$LINENO}: result: haiku" >&5 $as_echo "haiku" >&6; } ;; # # Others, untested. # *) $as_echo "#define HAVE_UNTESTED 1" >>confdefs.h { $as_echo "$as_me:${as_lineno-$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:${as_lineno-$LINENO}: result: interpreter-only" >&5 $as_echo "interpreter-only" >&6; } enable_compiler=no ;; esac # # Extra options. # # Check whether --enable-generic was given. if test "${enable_generic+set}" = set; then : enableval=$enable_generic; else enable_generic=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-quadmath was given. if test "${enable_quadmath+set}" = set; then : enableval=$enable_quadmath; else enable_quadmath=yes fi # Check whether --enable-mathlib was given. if test "${enable_mathlib+set}" = set; then : enableval=$enable_mathlib; else enable_mathlib=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-gsl was given. if test "${enable_gsl+set}" = set; then : enableval=$enable_gsl; else enable_gsl=yes fi # Check whether --enable-mpfr was given. if test "${enable_mpfr+set}" = set; then : enableval=$enable_mpfr; else enable_mpfr=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-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 # Check whether --enable-readline was given. if test "${enable_readline+set}" = set; then : enableval=$enable_readline; else enable_readline=yes fi # Check whether --enable-standard-types was given. if test "${enable_standard_types+set}" = set; then : enableval=$enable_standard_types; else enable_standard_types=yes fi # Check whether --enable-long-types was given. if test "${enable_long_types+set}" = set; then : enableval=$enable_long_types; else enable_long_types=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-arch was given. if test "${enable_arch+set}" = set; then : enableval=$enable_arch; else enable_arch=no fi if test "x$enable_generic" = "xyes"; then enable_standard_types=yes enable_long_types=no fi # # Initialisation. # { $as_echo "$as_me:${as_lineno-$LINENO}: initialising..." >&5 $as_echo "$as_me: initialising..." >&6;} am__api_version='1.16' # 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:${as_lineno-$LINENO}: checking for a BSD-compatible install" >&5 $as_echo_n "checking for a BSD-compatible install... " >&6; } if test -z "$INSTALL"; then if ${ac_cv_path_install+:} false; 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 as_fn_executable_p "$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:${as_lineno-$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:${as_lineno-$LINENO}: checking whether build environment is sane" >&5 $as_echo_n "checking whether build environment is sane... " >&6; } # Reject unsafe characters in $srcdir or the absolute working directory # name. Accept space and tab only in the latter. am_lf=' ' case `pwd` in *[\\\"\#\$\&\'\`$am_lf]*) as_fn_error $? "unsafe absolute working directory name" "$LINENO" 5;; esac case $srcdir in *[\\\"\#\$\&\'\`$am_lf\ \ ]*) as_fn_error $? "unsafe srcdir value: '$srcdir'" "$LINENO" 5;; esac # 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 ( am_has_slept=no for am_try in 1 2; do echo "timestamp, slept: $am_has_slept" > conftest.file 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 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_fn_error $? "ls -t appears to fail. Make sure there is not a broken alias in your environment" "$LINENO" 5 fi if test "$2" = conftest.file || test $am_try -eq 2; then break fi # Just in case. sleep 1 am_has_slept=yes done test "$2" = conftest.file ) then # Ok. : else as_fn_error $? "newly created file is older than distributed files! Check your system clock" "$LINENO" 5 fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 $as_echo "yes" >&6; } # If we didn't sleep, we still need to ensure time stamps of config.status and # generated files are strictly newer. am_sleep_pid= if grep 'slept: no' conftest.file >/dev/null 2>&1; then ( sleep 1 ) & am_sleep_pid=$! fi rm -f conftest.file 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` if test x"${MISSING+set}" != xset; then MISSING="\${SHELL} '$am_aux_dir/missing'" fi # Use eval to expand $SHELL if eval "$MISSING --is-lightweight"; then am_missing_run="$MISSING " else am_missing_run= { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: 'missing' script is too old or missing" >&5 $as_echo "$as_me: WARNING: 'missing' script is too old or missing" >&2;} fi if test x"${install_sh+set}" != xset; then case $am_aux_dir in *\ * | *\ *) install_sh="\${SHELL} '$am_aux_dir/install-sh'" ;; *) install_sh="\${SHELL} $am_aux_dir/install-sh" esac fi # 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:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if ${ac_cv_prog_STRIP+:} false; 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 as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_prog_STRIP="${ac_tool_prefix}strip" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS fi fi STRIP=$ac_cv_prog_STRIP if test -n "$STRIP"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $STRIP" >&5 $as_echo "$STRIP" >&6; } else { $as_echo "$as_me:${as_lineno-$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:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if ${ac_cv_prog_ac_ct_STRIP+:} false; 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 as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_prog_ac_ct_STRIP="strip" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS fi fi ac_ct_STRIP=$ac_cv_prog_ac_ct_STRIP if test -n "$ac_ct_STRIP"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_ct_STRIP" >&5 $as_echo "$ac_ct_STRIP" >&6; } else { $as_echo "$as_me:${as_lineno-$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:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5 $as_echo "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;} ac_tool_warned=yes ;; esac STRIP=$ac_ct_STRIP fi else STRIP="$ac_cv_prog_STRIP" fi fi INSTALL_STRIP_PROGRAM="\$(install_sh) -c -s" { $as_echo "$as_me:${as_lineno-$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 ${ac_cv_path_mkdir+:} false; 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 as_fn_executable_p "$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 test -d ./--version && rmdir ./--version 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. MKDIR_P="$ac_install_sh -d" fi fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $MKDIR_P" >&5 $as_echo "$MKDIR_P" >&6; } 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:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if ${ac_cv_prog_AWK+:} false; 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 as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_prog_AWK="$ac_prog" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS fi fi AWK=$ac_cv_prog_AWK if test -n "$AWK"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $AWK" >&5 $as_echo "$AWK" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi test -n "$AWK" && break done { $as_echo "$as_me:${as_lineno-$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 eval \${ac_cv_prog_make_${ac_make}_set+:} false; 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:${as_lineno-$LINENO}: result: yes" >&5 $as_echo "yes" >&6; } SET_MAKE= else { $as_echo "$as_me:${as_lineno-$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 # Check whether --enable-silent-rules was given. if test "${enable_silent_rules+set}" = set; then : enableval=$enable_silent_rules; fi case $enable_silent_rules in # ((( yes) AM_DEFAULT_VERBOSITY=0;; no) AM_DEFAULT_VERBOSITY=1;; *) AM_DEFAULT_VERBOSITY=1;; esac am_make=${MAKE-make} { $as_echo "$as_me:${as_lineno-$LINENO}: checking whether $am_make supports nested variables" >&5 $as_echo_n "checking whether $am_make supports nested variables... " >&6; } if ${am_cv_make_support_nested_variables+:} false; then : $as_echo_n "(cached) " >&6 else if $as_echo 'TRUE=$(BAR$(V)) BAR0=false BAR1=true V=1 am__doit: @$(TRUE) .PHONY: am__doit' | $am_make -f - >/dev/null 2>&1; then am_cv_make_support_nested_variables=yes else am_cv_make_support_nested_variables=no fi fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $am_cv_make_support_nested_variables" >&5 $as_echo "$am_cv_make_support_nested_variables" >&6; } if test $am_cv_make_support_nested_variables = yes; then AM_V='$(V)' AM_DEFAULT_V='$(AM_DEFAULT_VERBOSITY)' else AM_V=$AM_DEFAULT_VERBOSITY AM_DEFAULT_V=$AM_DEFAULT_VERBOSITY fi AM_BACKSLASH='\' 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_fn_error $? "source directory already configured; run \"make distclean\" there first" "$LINENO" 5 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='3.1.2' 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"} # For better backward compatibility. To be removed once Automake 1.9.x # dies out for good. For more background, see: # # mkdir_p='$(MKDIR_P)' # We need awk for the "check" target (and possibly the TAP driver). The # system "awk" is bad on some platforms. # Always define AMTAR for backward compatibility. Yes, it's still used # in the wild :-( We should find a proper way to deprecate it ... AMTAR='$${TAR-tar}' # We'll loop over all known methods to create a tar archive until one works. _am_tools='gnutar pax cpio none' am__tar='$${TAR-tar} chof - "$$tardir"' am__untar='$${TAR-tar} xf -' # POSIX will say in a future version that running "rm -f" with no argument # is OK; and we want to be able to make that assumption in our Makefile # recipes. So use an aggressive probe to check that the usage we want is # actually supported "in the wild" to an acceptable degree. # See automake bug#10828. # To make any issue more visible, cause the running configure to be aborted # by default if the 'rm' program in use doesn't match our expectations; the # user can still override this though. if rm -f && rm -fr && rm -rf; then : OK; else cat >&2 <<'END' Oops! Your 'rm' program seems unable to run without file operands specified on the command line, even when the '-f' option is present. This is contrary to the behaviour of most rm programs out there, and not conforming with the upcoming POSIX standard: Please tell bug-automake@gnu.org about your system, including the value of your $PATH and any error possibly output before this message. This can help us improve future automake versions. END if test x"$ACCEPT_INFERIOR_RM_PROGRAM" = x"yes"; then echo 'Configuration will proceed anyway, since you have set the' >&2 echo 'ACCEPT_INFERIOR_RM_PROGRAM variable to "yes"' >&2 echo >&2 else cat >&2 <<'END' Aborting the configuration process, to ensure you take notice of the issue. You can download and install GNU coreutils to get an 'rm' implementation that behaves properly: . If you want to complete the configuration process using your problematic 'rm' anyway, export the environment variable ACCEPT_INFERIOR_RM_PROGRAM to "yes", and re-run configure. END as_fn_error $? "Your 'rm' program is bad, sorry." "$LINENO" 5 fi fi ac_config_headers="$ac_config_headers a68g-config.h" # 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:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if ${ac_cv_prog_a68g_exists+:} false; 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 as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_prog_a68g_exists=""yes"" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS fi fi a68g_exists=$ac_cv_prog_a68g_exists if test -n "$a68g_exists"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $a68g_exists" >&5 $as_echo "$a68g_exists" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi # # C compiler. # { $as_echo "$as_me:${as_lineno-$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 gcc clang 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:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if ${ac_cv_prog_CC+:} false; 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 as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_prog_CC="$ac_tool_prefix$ac_prog" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS fi fi CC=$ac_cv_prog_CC if test -n "$CC"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $CC" >&5 $as_echo "$CC" >&6; } else { $as_echo "$as_me:${as_lineno-$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 gcc clang 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:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if ${ac_cv_prog_ac_ct_CC+:} false; 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 as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_prog_ac_ct_CC="$ac_prog" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS fi fi ac_ct_CC=$ac_cv_prog_ac_ct_CC if test -n "$ac_ct_CC"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_ct_CC" >&5 $as_echo "$ac_ct_CC" >&6; } else { $as_echo "$as_me:${as_lineno-$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:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5 $as_echo "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;} ac_tool_warned=yes ;; esac CC=$ac_ct_CC fi fi test -z "$CC" && { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error $? "no acceptable C compiler found in \$PATH See \`config.log' for more details" "$LINENO" 5; } # Provide some information about the compiler. $as_echo "$as_me:${as_lineno-$LINENO}: checking for C compiler version" >&5 set X $ac_compile ac_compiler=$2 for ac_option in --version -v -V -qversion; do { { ac_try="$ac_compiler $ac_option >&5" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" $as_echo "$ac_try_echo"; } >&5 (eval "$ac_compiler $ac_option >&5") 2>conftest.err ac_status=$? if test -s conftest.err; then sed '10a\ ... rest of stderr output deleted ... 10q' conftest.err >conftest.er1 cat conftest.er1 >&5 fi rm -f conftest.er1 conftest.err $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 test $ac_status = 0; } done cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* 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:${as_lineno-$LINENO}: checking whether the C compiler works" >&5 $as_echo_n "checking whether the C compiler works... " >&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:${as_lineno-$LINENO}: $ac_try_echo\"" $as_echo "$ac_try_echo"; } >&5 (eval "$ac_link_default") 2>&5 ac_status=$? $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 test $ac_status = 0; }; 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 if test -z "$ac_file"; then : { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error 77 "C compiler cannot create executables See \`config.log' for more details" "$LINENO" 5; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 $as_echo "yes" >&6; } fi { $as_echo "$as_me:${as_lineno-$LINENO}: checking for C compiler default output file name" >&5 $as_echo_n "checking for C compiler default output file name... " >&6; } { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_file" >&5 $as_echo "$ac_file" >&6; } ac_exeext=$ac_cv_exeext rm -f -r a.out a.out.dSYM a.exe conftest$ac_cv_exeext b.out ac_clean_files=$ac_clean_files_save { $as_echo "$as_me:${as_lineno-$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:${as_lineno-$LINENO}: $ac_try_echo\"" $as_echo "$ac_try_echo"; } >&5 (eval "$ac_link") 2>&5 ac_status=$? $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 test $ac_status = 0; }; 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:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error $? "cannot compute suffix of executables: cannot compile and link See \`config.log' for more details" "$LINENO" 5; } fi rm -f conftest conftest$ac_cv_exeext { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_exeext" >&5 $as_echo "$ac_cv_exeext" >&6; } rm -f conftest.$ac_ext EXEEXT=$ac_cv_exeext ac_exeext=$EXEEXT cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include int main () { FILE *f = fopen ("conftest.out", "w"); return ferror (f) || fclose (f) != 0; ; return 0; } _ACEOF ac_clean_files="$ac_clean_files conftest.out" # Check that the compiler produces executables we can run. If not, either # the compiler is broken, or we cross compile. { $as_echo "$as_me:${as_lineno-$LINENO}: checking whether we are cross compiling" >&5 $as_echo_n "checking whether we are cross compiling... " >&6; } if test "$cross_compiling" != yes; then { { 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:${as_lineno-$LINENO}: $ac_try_echo\"" $as_echo "$ac_try_echo"; } >&5 (eval "$ac_link") 2>&5 ac_status=$? $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 test $ac_status = 0; } if { ac_try='./conftest$ac_cv_exeext' { { case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" $as_echo "$ac_try_echo"; } >&5 (eval "$ac_try") 2>&5 ac_status=$? $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 test $ac_status = 0; }; }; then cross_compiling=no else if test "$cross_compiling" = maybe; then cross_compiling=yes else { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error $? "cannot run C compiled programs. If you meant to cross compile, use \`--host'. See \`config.log' for more details" "$LINENO" 5; } fi fi fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $cross_compiling" >&5 $as_echo "$cross_compiling" >&6; } rm -f conftest.$ac_ext conftest$ac_cv_exeext conftest.out ac_clean_files=$ac_clean_files_save { $as_echo "$as_me:${as_lineno-$LINENO}: checking for suffix of object files" >&5 $as_echo_n "checking for suffix of object files... " >&6; } if ${ac_cv_objext+:} false; then : $as_echo_n "(cached) " >&6 else cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* 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:${as_lineno-$LINENO}: $ac_try_echo\"" $as_echo "$ac_try_echo"; } >&5 (eval "$ac_compile") 2>&5 ac_status=$? $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 test $ac_status = 0; }; 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:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error $? "cannot compute suffix of object files: cannot compile See \`config.log' for more details" "$LINENO" 5; } fi rm -f conftest.$ac_cv_objext conftest.$ac_ext fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_objext" >&5 $as_echo "$ac_cv_objext" >&6; } OBJEXT=$ac_cv_objext ac_objext=$OBJEXT { $as_echo "$as_me:${as_lineno-$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 ${ac_cv_c_compiler_gnu+:} false; then : $as_echo_n "(cached) " >&6 else cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int main () { #ifndef __GNUC__ choke me #endif ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO"; then : ac_compiler_gnu=yes else 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:${as_lineno-$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:${as_lineno-$LINENO}: checking whether $CC accepts -g" >&5 $as_echo_n "checking whether $CC accepts -g... " >&6; } if ${ac_cv_prog_cc_g+:} false; 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 confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int main () { ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO"; then : ac_cv_prog_cc_g=yes else CFLAGS="" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int main () { ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO"; then : else ac_c_werror_flag=$ac_save_c_werror_flag CFLAGS="-g" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int main () { ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO"; then : ac_cv_prog_cc_g=yes 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:${as_lineno-$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:${as_lineno-$LINENO}: checking for $CC option to accept ISO C89" >&5 $as_echo_n "checking for $CC option to accept ISO C89... " >&6; } if ${ac_cv_prog_cc_c89+:} false; then : $as_echo_n "(cached) " >&6 else ac_cv_prog_cc_c89=no ac_save_CC=$CC cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include #include struct stat; /* 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" if ac_fn_c_try_compile "$LINENO"; then : ac_cv_prog_cc_c89=$ac_arg 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:${as_lineno-$LINENO}: result: none needed" >&5 $as_echo "none needed" >&6; } ;; xno) { $as_echo "$as_me:${as_lineno-$LINENO}: result: unsupported" >&5 $as_echo "unsupported" >&6; } ;; *) CC="$CC $ac_cv_prog_cc_c89" { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_prog_cc_c89" >&5 $as_echo "$ac_cv_prog_cc_c89" >&6; } ;; esac if test "x$ac_cv_prog_cc_c89" != xno; then : 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 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:${as_lineno-$LINENO}: checking whether $CC understands -c and -o together" >&5 $as_echo_n "checking whether $CC understands -c and -o together... " >&6; } if ${am_cv_prog_cc_c_o+:} false; then : $as_echo_n "(cached) " >&6 else cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int main () { ; return 0; } _ACEOF # Make sure it works both with $CC and with simple cc. # Following AC_PROG_CC_C_O, we do the test twice because some # compilers refuse to overwrite an existing .o file with -o, # though they will create one. am_cv_prog_cc_c_o=yes for am_i in 1 2; do if { echo "$as_me:$LINENO: $CC -c conftest.$ac_ext -o conftest2.$ac_objext" >&5 ($CC -c conftest.$ac_ext -o conftest2.$ac_objext) >&5 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } \ && test -f conftest2.$ac_objext; then : OK else am_cv_prog_cc_c_o=no break fi done rm -f core conftest* unset am_i fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $am_cv_prog_cc_c_o" >&5 $as_echo "$am_cv_prog_cc_c_o" >&6; } if test "$am_cv_prog_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 DEPDIR="${am__leading_dot}deps" ac_config_commands="$ac_config_commands depfiles" { $as_echo "$as_me:${as_lineno-$LINENO}: checking whether ${MAKE-make} supports the include directive" >&5 $as_echo_n "checking whether ${MAKE-make} supports the include directive... " >&6; } cat > confinc.mk << 'END' am__doit: @echo this is the am__doit target >confinc.out .PHONY: am__doit END am__include="#" am__quote= # BSD make does it like this. echo '.include "confinc.mk" # ignored' > confmf.BSD # Other make implementations (GNU, Solaris 10, AIX) do it like this. echo 'include confinc.mk # ignored' > confmf.GNU _am_result=no for s in GNU BSD; do { echo "$as_me:$LINENO: ${MAKE-make} -f confmf.$s && cat confinc.out" >&5 (${MAKE-make} -f confmf.$s && cat confinc.out) >&5 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } case $?:`cat confinc.out 2>/dev/null` in #( '0:this is the am__doit target') : case $s in #( BSD) : am__include='.include' am__quote='"' ;; #( *) : am__include='include' am__quote='' ;; esac ;; #( *) : ;; esac if test "$am__include" != "#"; then _am_result="yes ($s style)" break fi done rm -f confinc.* confmf.* { $as_echo "$as_me:${as_lineno-$LINENO}: result: ${_am_result}" >&5 $as_echo "${_am_result}" >&6; } # 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='\' am__nodep='_no' 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:${as_lineno-$LINENO}: checking dependency style of $depcc" >&5 $as_echo_n "checking dependency style of $depcc... " >&6; } if ${am_cv_CC_dependencies_compiler_type+:} false; 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". rm -rf conftest.dir 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 am__universal=false case " $depcc " in #( *\ -arch\ *\ -arch\ *) am__universal=true ;; esac 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 10 /bin/sh. echo '/* dummy */' > sub/conftst$i.h done echo "${am__include} ${am__quote}sub/conftest.Po${am__quote}" > confmf # 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. Also, some Intel # versions had trouble with output in subdirs. am__obj=sub/conftest.${OBJEXT-o} am__minus_obj="-o $am__obj" case $depmode in gcc) # This depmode causes a compiler race in universal mode. test "$am__universal" = false || continue ;; 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 ;; msvc7 | msvc7msys | msvisualcpp | msvcmsys) # This compiler won't grok '-c -o', but also, the minuso test has # not run yet. These depmodes are late enough in the game, and # so weak that their functioning should not be impacted. am__obj=conftest.${OBJEXT-o} am__minus_obj= ;; none) break ;; esac if depmode=$depmode \ source=sub/conftest.c object=$am__obj \ depfile=sub/conftest.Po tmpdepfile=sub/conftest.TPo \ $SHELL ./depcomp $depcc -c $am__minus_obj 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 $am__obj 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:${as_lineno-$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 # AC_PROG_CC([clang]) if test "x$GCC" != "xyes"; then a68g_ac_compiler=no { $as_echo "$as_me:${as_lineno-$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 $as_echo "#define HAVE_GCC 1" >>confdefs.h cat >>confdefs.h <<_ACEOF #define C_COMPILER "$CC" _ACEOF # On rhel8 "rpmbuild" sneaks in -pie and -fPIE, so a68g also needs to pass through. # On Suse15 the header files for pgsql and R have their own directories. COPTFLAGS="-g -O2 -Wall -I /usr/include/pgsql -I /usr/lib64/R/include" LDOPTFLAG="-L /usr/lib64/R/lib" # from /usr/lib/rpm/redhat/macros CFLAGS="${CFLAGS:-$COPTFLAGS}" ; export CFLAGS LDFLAGS="${LDFLAGS:-$LDOPTFLAGS}" ; export LDFLAGS { $as_echo "$as_me:${as_lineno-$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 confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int main () { ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO"; then : { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 $as_echo "yes" >&6; } else CFLAGS="$a68g_ac_save_CFLAGS" { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext { $as_echo "$as_me:${as_lineno-$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 confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int main () { ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO"; then : { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 $as_echo "yes" >&6; } else CFLAGS="$a68g_ac_save_CFLAGS" { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext { $as_echo "$as_me:${as_lineno-$LINENO}: checking whether $CC accepts -Wunused-variable" >&5 $as_echo_n "checking whether $CC accepts -Wunused-variable... " >&6; } a68g_ac_save_CFLAGS=$CFLAGS CFLAGS="$a68g_ac_save_CFLAGS -Wunused-variable" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int main () { ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO"; then : { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 $as_echo "yes" >&6; } else CFLAGS="$a68g_ac_save_CFLAGS" { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext { $as_echo "$as_me:${as_lineno-$LINENO}: checking whether $CC accepts -Wunused-parameter" >&5 $as_echo_n "checking whether $CC accepts -Wunused-parameter... " >&6; } a68g_ac_save_CFLAGS=$CFLAGS CFLAGS="$a68g_ac_save_CFLAGS -Wunused-parameter" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int main () { ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO"; then : { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 $as_echo "yes" >&6; } else CFLAGS="$a68g_ac_save_CFLAGS" { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext { $as_echo "$as_me:${as_lineno-$LINENO}: checking whether $CC accepts -Wno-long-long" >&5 $as_echo_n "checking whether $CC accepts -Wno-long-long... " >&6; } a68g_ac_save_CFLAGS=$CFLAGS CFLAGS="$a68g_ac_save_CFLAGS -Wno-long-long" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int main () { ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO"; then : { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 $as_echo "yes" >&6; } else CFLAGS="$a68g_ac_save_CFLAGS" { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext { $as_echo "$as_me:${as_lineno-$LINENO}: checking whether $CC accepts -fno-diagnostics-color" >&5 $as_echo_n "checking whether $CC accepts -fno-diagnostics-color... " >&6; } a68g_ac_save_CFLAGS=$CFLAGS CFLAGS="$a68g_ac_save_CFLAGS -fno-diagnostics-color" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int main () { ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO"; then : { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 $as_echo "yes" >&6; } else CFLAGS="$a68g_ac_save_CFLAGS" { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext # # Test on gcc capabilities. # { $as_echo "$as_me:${as_lineno-$LINENO}: checking __attribute__((aligned())) supported" >&5 $as_echo_n "checking __attribute__((aligned())) supported... " >&6; } if test "$cross_compiling" = yes; then : { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error $? "cannot run test program while cross compiling See \`config.log' for more details" "$LINENO" 5; } else cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int main () { typedef int aint __attribute__((aligned(8))); ; return 0; } _ACEOF if ac_fn_c_try_run "$LINENO"; then : { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 $as_echo "yes" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error $? "stop -- C compiler does not support __attribute__aligned directive See \`config.log' for more details" "$LINENO" 5; } fi rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ conftest.$ac_objext conftest.beam conftest.$ac_ext fi { $as_echo "$as_me:${as_lineno-$LINENO}: checking for inline" >&5 $as_echo_n "checking for inline... " >&6; } if ${ac_cv_c_inline+:} false; then : $as_echo_n "(cached) " >&6 else ac_cv_c_inline=no for ac_kw in inline __inline__ __inline; do cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #ifndef __cplusplus typedef int foo_t; static $ac_kw foo_t static_foo () {return 0; } $ac_kw foo_t foo () {return 0; } #endif _ACEOF if ac_fn_c_try_compile "$LINENO"; then : ac_cv_c_inline=$ac_kw fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext test "$ac_cv_c_inline" != no && break done fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_c_inline" >&5 $as_echo "$ac_cv_c_inline" >&6; } case $ac_cv_c_inline in inline | yes) ;; *) case $ac_cv_c_inline in no) ac_val=;; *) ac_val=$ac_cv_c_inline;; esac cat >>confdefs.h <<_ACEOF #ifndef __cplusplus #define inline $ac_val #endif _ACEOF ;; esac # # Set -I/usr/local/include for *BSD # if test "x$bsd_include_dirs" = "xyes"; then $as_echo "#define INCLUDE_DIR \"-I/usr/local/include\"" >>confdefs.h else $as_echo "#define INCLUDE_DIR \"\"" >>confdefs.h fi # # 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:${as_lineno-$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:${as_lineno-$LINENO}: result: assuming no" >&5 $as_echo "assuming no" >&6; } { $as_echo "$as_me:${as_lineno-$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 confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ extern void exit (); void (*fptr) () = exit; int main () { ; return 0; } _ACEOF if ac_fn_c_try_run "$LINENO"; then : { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 $as_echo "yes" >&6; } $as_echo "#define HAVE_EXPORT_DYNAMIC 1" >>confdefs.h else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } { $as_echo "$as_me:${as_lineno-$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 -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ conftest.$ac_objext conftest.beam 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:${as_lineno-$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 confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int main () { ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO"; then : { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 $as_echo "yes" >&6; } cat >>confdefs.h <<_ACEOF #define HAVE_TUNING "$a68g_ac_march" _ACEOF else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } { $as_echo "$as_me:${as_lineno-$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:${as_lineno-$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 confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int main () { ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO"; then : { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 $as_echo "yes" >&6; } cat >>confdefs.h <<_ACEOF #define HAVE_PIC "$enable_pic" _ACEOF else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } { $as_echo "$as_me:${as_lineno-$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 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $CC option to accept ISO C99" >&5 $as_echo_n "checking for $CC option to accept ISO C99... " >&6; } if ${ac_cv_prog_cc_c99+:} false; then : $as_echo_n "(cached) " >&6 else ac_cv_prog_cc_c99=no ac_save_CC=$CC cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include #include #include #include #include // Check varargs macros. These examples are taken from C99 6.10.3.5. #define debug(...) fprintf (stderr, __VA_ARGS__) #define showlist(...) puts (#__VA_ARGS__) #define report(test,...) ((test) ? puts (#test) : printf (__VA_ARGS__)) static void test_varargs_macros (void) { int x = 1234; int y = 5678; debug ("Flag"); debug ("X = %d\n", x); showlist (The first, second, and third items.); report (x>y, "x is %d but y is %d", x, y); } // Check long long types. #define BIG64 18446744073709551615ull #define BIG32 4294967295ul #define BIG_OK (BIG64 / BIG32 == 4294967297ull && BIG64 % BIG32 == 0) #if !BIG_OK your preprocessor is broken; #endif #if BIG_OK #else your preprocessor is broken; #endif static long long int bignum = -9223372036854775807LL; static unsigned long long int ubignum = BIG64; struct incomplete_array { int datasize; double data[]; }; struct named_init { int number; const wchar_t *name; double average; }; typedef const char *ccp; static inline int test_restrict (ccp restrict text) { // See if C++-style comments work. // Iterate through items via the restricted pointer. // Also check for declarations in for loops. for (unsigned int i = 0; *(text+i) != '\0'; ++i) continue; return 0; } // Check varargs and va_copy. static void test_varargs (const char *format, ...) { va_list args; va_start (args, format); va_list args_copy; va_copy (args_copy, args); const char *str; int number; float fnumber; while (*format) { switch (*format++) { case 's': // string str = va_arg (args_copy, const char *); break; case 'd': // int number = va_arg (args_copy, int); break; case 'f': // float fnumber = va_arg (args_copy, double); break; default: break; } } va_end (args_copy); va_end (args); } int main () { // Check bool. _Bool success = false; // Check restrict. if (test_restrict ("String literal") == 0) success = true; char *restrict newvar = "Another string"; // Check varargs. test_varargs ("s, d' f .", "string", 65, 34.234); test_varargs_macros (); // Check flexible array members. struct incomplete_array *ia = malloc (sizeof (struct incomplete_array) + (sizeof (double) * 10)); ia->datasize = 10; for (int i = 0; i < ia->datasize; ++i) ia->data[i] = i * 1.234; // Check named initializers. struct named_init ni = { .number = 34, .name = L"Test wide string", .average = 543.34343, }; ni.number = 58; int dynamic_array[ni.number]; dynamic_array[ni.number - 1] = 543; // work around unused variable warnings return (!success || bignum == 0LL || ubignum == 0uLL || newvar[0] == 'x' || dynamic_array[ni.number - 1] != 543); ; return 0; } _ACEOF for ac_arg in '' -std=gnu99 -std=c99 -c99 -AC99 -D_STDC_C99= -qlanglvl=extc99 do CC="$ac_save_CC $ac_arg" if ac_fn_c_try_compile "$LINENO"; then : ac_cv_prog_cc_c99=$ac_arg fi rm -f core conftest.err conftest.$ac_objext test "x$ac_cv_prog_cc_c99" != "xno" && break done rm -f conftest.$ac_ext CC=$ac_save_CC fi # AC_CACHE_VAL case "x$ac_cv_prog_cc_c99" in x) { $as_echo "$as_me:${as_lineno-$LINENO}: result: none needed" >&5 $as_echo "none needed" >&6; } ;; xno) { $as_echo "$as_me:${as_lineno-$LINENO}: result: unsupported" >&5 $as_echo "unsupported" >&6; } ;; *) CC="$CC $ac_cv_prog_cc_c99" { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_prog_cc_c99" >&5 $as_echo "$ac_cv_prog_cc_c99" >&6; } ;; esac if test "x$ac_cv_prog_cc_c99" != xno; then : 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:${as_lineno-$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 ${ac_cv_prog_CPP+:} false; 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 confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #ifdef __STDC__ # include #else # include #endif Syntax error _ACEOF if ac_fn_c_try_cpp "$LINENO"; then : else # Broken: fails on valid input. continue fi rm -f conftest.err conftest.i conftest.$ac_ext # OK, works on sane cases. Now check whether nonexistent headers # can be detected and how. cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include _ACEOF if ac_fn_c_try_cpp "$LINENO"; then : # Broken: success on invalid input. continue else # Passes both tests. ac_preproc_ok=: break fi rm -f conftest.err conftest.i conftest.$ac_ext done # Because of `break', _AC_PREPROC_IFELSE's cleaning code was skipped. rm -f conftest.i 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:${as_lineno-$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 confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #ifdef __STDC__ # include #else # include #endif Syntax error _ACEOF if ac_fn_c_try_cpp "$LINENO"; then : else # Broken: fails on valid input. continue fi rm -f conftest.err conftest.i conftest.$ac_ext # OK, works on sane cases. Now check whether nonexistent headers # can be detected and how. cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include _ACEOF if ac_fn_c_try_cpp "$LINENO"; then : # Broken: success on invalid input. continue else # Passes both tests. ac_preproc_ok=: break fi rm -f conftest.err conftest.i conftest.$ac_ext done # Because of `break', _AC_PREPROC_IFELSE's cleaning code was skipped. rm -f conftest.i conftest.err conftest.$ac_ext if $ac_preproc_ok; then : else { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error $? "C preprocessor \"$CPP\" fails sanity check See \`config.log' for more details" "$LINENO" 5; } 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:${as_lineno-$LINENO}: types..." >&5 $as_echo "$as_me: types..." >&6;} { $as_echo "$as_me:${as_lineno-$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 ${ac_cv_path_GREP+:} false; 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" as_fn_executable_p "$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 as_fn_arith $ac_count + 1 && ac_count=$as_val 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_fn_error $? "no acceptable grep could be found in $PATH$PATH_SEPARATOR/usr/xpg4/bin" "$LINENO" 5 fi else ac_cv_path_GREP=$GREP fi fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_path_GREP" >&5 $as_echo "$ac_cv_path_GREP" >&6; } GREP="$ac_cv_path_GREP" { $as_echo "$as_me:${as_lineno-$LINENO}: checking for egrep" >&5 $as_echo_n "checking for egrep... " >&6; } if ${ac_cv_path_EGREP+:} false; 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" as_fn_executable_p "$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 as_fn_arith $ac_count + 1 && ac_count=$as_val 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_fn_error $? "no acceptable egrep could be found in $PATH$PATH_SEPARATOR/usr/xpg4/bin" "$LINENO" 5 fi else ac_cv_path_EGREP=$EGREP fi fi fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_path_EGREP" >&5 $as_echo "$ac_cv_path_EGREP" >&6; } EGREP="$ac_cv_path_EGREP" { $as_echo "$as_me:${as_lineno-$LINENO}: checking for ANSI C header files" >&5 $as_echo_n "checking for ANSI C header files... " >&6; } if ${ac_cv_header_stdc+:} false; then : $as_echo_n "(cached) " >&6 else cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include #include #include #include int main () { ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO"; then : ac_cv_header_stdc=yes else 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 confdefs.h - <<_ACEOF >conftest.$ac_ext /* 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 confdefs.h - <<_ACEOF >conftest.$ac_ext /* 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 confdefs.h - <<_ACEOF >conftest.$ac_ext /* 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 if ac_fn_c_try_run "$LINENO"; then : else ac_cv_header_stdc=no fi rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ conftest.$ac_objext conftest.beam conftest.$ac_ext fi fi fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_header_stdc" >&5 $as_echo "$ac_cv_header_stdc" >&6; } if test $ac_cv_header_stdc = yes; then $as_echo "#define STDC_HEADERS 1" >>confdefs.h 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` ac_fn_c_check_header_compile "$LINENO" "$ac_header" "$as_ac_Header" "$ac_includes_default " if eval test \"x\$"$as_ac_Header"\" = x"yes"; then : cat >>confdefs.h <<_ACEOF #define `$as_echo "HAVE_$ac_header" | $as_tr_cpp` 1 _ACEOF fi done { $as_echo "$as_me:${as_lineno-$LINENO}: checking whether char is unsigned" >&5 $as_echo_n "checking whether char is unsigned... " >&6; } if ${ac_cv_c_char_unsigned+:} false; then : $as_echo_n "(cached) " >&6 else cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ $ac_includes_default int main () { static int test_array [1 - 2 * !(((char) -1) < 0)]; test_array [0] = 0; return test_array [0]; ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO"; then : ac_cv_c_char_unsigned=no else ac_cv_c_char_unsigned=yes fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:${as_lineno-$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 $as_echo "#define __CHAR_UNSIGNED__ 1" >>confdefs.h fi ac_fn_c_check_type "$LINENO" "mode_t" "ac_cv_type_mode_t" "$ac_includes_default" if test "x$ac_cv_type_mode_t" = xyes; then : else cat >>confdefs.h <<_ACEOF #define mode_t int _ACEOF fi ac_fn_c_check_type "$LINENO" "size_t" "ac_cv_type_size_t" "$ac_includes_default" if test "x$ac_cv_type_size_t" = xyes; then : else cat >>confdefs.h <<_ACEOF #define size_t unsigned int _ACEOF fi ac_fn_c_check_type "$LINENO" "ssize_t" "ac_cv_type_ssize_t" "$ac_includes_default" if test "x$ac_cv_type_ssize_t" = xyes; then : else cat >>confdefs.h <<_ACEOF #define ssize_t int _ACEOF fi ac_fn_c_find_uintX_t "$LINENO" "16" "ac_cv_c_uint16_t" 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:${as_lineno-$LINENO}: checking __off_t or off_t" >&5 $as_echo_n "checking __off_t or off_t... " >&6; } cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include #include __off_t dummy; _ACEOF if ac_fn_c_try_compile "$LINENO"; then : { $as_echo "$as_me:${as_lineno-$LINENO}: result: __off_t" >&5 $as_echo "__off_t" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: off_t" >&5 $as_echo "off_t" >&6; } $as_echo "#define __off_t off_t" >>confdefs.h fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext { $as_echo "$as_me:${as_lineno-$LINENO}: checking __pid_t or pid_t" >&5 $as_echo_n "checking __pid_t or pid_t... " >&6; } cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include #include __pid_t dummy; ) _ACEOF if ac_fn_c_try_compile "$LINENO"; then : { $as_echo "$as_me:${as_lineno-$LINENO}: result: __pid_t" >&5 $as_echo "__pid_t" >&6; } $as_echo "#define a68_pid_t __pid_t" >>confdefs.h else { $as_echo "$as_me:${as_lineno-$LINENO}: result: pid_t" >&5 $as_echo "pid_t" >&6; } $as_echo "#define a68_pid_t pid_t" >>confdefs.h fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext { $as_echo "$as_me:${as_lineno-$LINENO}: checking __mode_t or mode_t" >&5 $as_echo_n "checking __mode_t or mode_t... " >&6; } cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include #include __mode_t dummy; _ACEOF if ac_fn_c_try_compile "$LINENO"; then : { $as_echo "$as_me:${as_lineno-$LINENO}: result: __mode_t" >&5 $as_echo "__mode_t" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: mode_t" >&5 $as_echo "mode_t" >&6; } $as_echo "#define __mode_t mode_t" >>confdefs.h fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext # # Extra include directories. # { $as_echo "$as_me:${as_lineno-$LINENO}: extra include directories..." >&5 $as_echo "$as_me: extra include directories..." >&6;} # GSL on OpenBSD if test -d /usr/local/include/gsl; then CFLAGS="$CFLAGS -I/usr/local/include" CPPFLAGS="$CPPFLAGS -I/usr/local/include" CXXFLAGS="$CXXFLAGS -I/usr/local/include" LDFLAGS="$LDFLAGS -L/usr/local/lib" fi # R on Debian # # if test -d /usr/share/R/include; then # AC_DEFINE(HAVE_USR_SHARE_R_INCLUDE, 1, [Define this if /usr/share/R/include was detected]) # CFLAGS="$CFLAGS -I/usr/share/R/include" # CPPFLAGS="$CPPFLAGS -I/usr/share/R/include" # CXXFLAGS="$CXXFLAGS -I/usr/share/R/include" # LDFLAGS="$LDFLAGS -L/usr/share/R/lib" # fi # Postgresql if test -d /usr/local/pgsql/include; then $as_echo "#define HAVE_USR_LOCAL_PGSQL_INCLUDE 1" >>confdefs.h 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 $as_echo "#define HAVE_USR_PKG_PGSQL_INCLUDE 1" >>confdefs.h 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 $as_echo "#define HAVE_OPT_LOCAL_PGSQL_INCLUDE 1" >>confdefs.h 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 if test -d /usr/include/postgresql; then $as_echo "#define HAVE_USR_INCLUDE_POSTGRESQL 1" >>confdefs.h CFLAGS="$CFLAGS -I/usr/include/postgresql" CPPFLAGS="$CPPFLAGS -I/usr/include/postgresql" CXXFLAGS="$CXXFLAGS -I/usr/include/postgresql" LDFLAGS="$LDFLAGS -L/usr/lib" fi # # Checks for header files. # { $as_echo "$as_me:${as_lineno-$LINENO}: standard header files..." >&5 $as_echo "$as_me: standard header files..." >&6;} # # test is GSL proof. # for ac_header in math.h do : ac_fn_c_check_header_mongrel "$LINENO" "math.h" "ac_cv_header_math_h" "$ac_includes_default" if test "x$ac_cv_header_math_h" = xyes; then : cat >>confdefs.h <<_ACEOF #define HAVE_MATH_H 1 _ACEOF fi done { $as_echo "$as_me:${as_lineno-$LINENO}: checking for cos in -lm" >&5 $as_echo_n "checking for cos in -lm... " >&6; } if ${ac_cv_lib_m_cos+:} false; then : $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lm $LIBS" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* 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 if ac_fn_c_try_link "$LINENO"; then : ac_cv_lib_m_cos=yes else ac_cv_lib_m_cos=no fi rm -f core conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_m_cos" >&5 $as_echo "$ac_cv_lib_m_cos" >&6; } if test "x$ac_cv_lib_m_cos" = xyes; then : cat >>confdefs.h <<_ACEOF #define HAVE_LIBM 1 _ACEOF LIBS="-lm $LIBS" fi { $as_echo "$as_me:${as_lineno-$LINENO}: checking for ANSI C header files" >&5 $as_echo_n "checking for ANSI C header files... " >&6; } if ${ac_cv_header_stdc+:} false; then : $as_echo_n "(cached) " >&6 else cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include #include #include #include int main () { ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO"; then : ac_cv_header_stdc=yes else 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 confdefs.h - <<_ACEOF >conftest.$ac_ext /* 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 confdefs.h - <<_ACEOF >conftest.$ac_ext /* 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 confdefs.h - <<_ACEOF >conftest.$ac_ext /* 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 if ac_fn_c_try_run "$LINENO"; then : else ac_cv_header_stdc=no fi rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ conftest.$ac_objext conftest.beam conftest.$ac_ext fi fi fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_header_stdc" >&5 $as_echo "$ac_cv_header_stdc" >&6; } if test $ac_cv_header_stdc = yes; then $as_echo "#define STDC_HEADERS 1" >>confdefs.h fi { $as_echo "$as_me:${as_lineno-$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; ac_enable_assert=$enableval if test "x$enableval" = xno; then : $as_echo "#define NDEBUG 1" >>confdefs.h elif test "x$enableval" != xyes; then : { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: invalid argument supplied to --enable-assert" >&5 $as_echo "$as_me: WARNING: invalid argument supplied to --enable-assert" >&2;} ac_enable_assert=yes fi else ac_enable_assert=yes fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_enable_assert" >&5 $as_echo "$ac_enable_assert" >&6; } 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:${as_lineno-$LINENO}: checking for $ac_hdr that defines DIR" >&5 $as_echo_n "checking for $ac_hdr that defines DIR... " >&6; } if eval \${$as_ac_Header+:} false; then : $as_echo_n "(cached) " >&6 else cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include #include <$ac_hdr> int main () { if ((DIR *) 0) return 0; ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO"; then : eval "$as_ac_Header=yes" else eval "$as_ac_Header=no" fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi eval ac_res=\$$as_ac_Header { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5 $as_echo "$ac_res" >&6; } if eval test \"x\$"$as_ac_Header"\" = 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:${as_lineno-$LINENO}: checking for library containing opendir" >&5 $as_echo_n "checking for library containing opendir... " >&6; } if ${ac_cv_search_opendir+:} false; then : $as_echo_n "(cached) " >&6 else ac_func_search_save_LIBS=$LIBS cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* 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 if ac_fn_c_try_link "$LINENO"; then : ac_cv_search_opendir=$ac_res fi rm -f core conftest.err conftest.$ac_objext \ conftest$ac_exeext if ${ac_cv_search_opendir+:} false; then : break fi done if ${ac_cv_search_opendir+:} false; then : else ac_cv_search_opendir=no fi rm conftest.$ac_ext LIBS=$ac_func_search_save_LIBS fi { $as_echo "$as_me:${as_lineno-$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:${as_lineno-$LINENO}: checking for library containing opendir" >&5 $as_echo_n "checking for library containing opendir... " >&6; } if ${ac_cv_search_opendir+:} false; then : $as_echo_n "(cached) " >&6 else ac_func_search_save_LIBS=$LIBS cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* 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 if ac_fn_c_try_link "$LINENO"; then : ac_cv_search_opendir=$ac_res fi rm -f core conftest.err conftest.$ac_objext \ conftest$ac_exeext if ${ac_cv_search_opendir+:} false; then : break fi done if ${ac_cv_search_opendir+:} false; then : else ac_cv_search_opendir=no fi rm conftest.$ac_ext LIBS=$ac_func_search_save_LIBS fi { $as_echo "$as_me:${as_lineno-$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:${as_lineno-$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 ${ac_cv_header_sys_wait_h+:} false; then : $as_echo_n "(cached) " >&6 else cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* 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 if ac_fn_c_try_compile "$LINENO"; then : ac_cv_header_sys_wait_h=yes else ac_cv_header_sys_wait_h=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:${as_lineno-$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 $as_echo "#define HAVE_SYS_WAIT_H 1" >>confdefs.h fi { $as_echo "$as_me:${as_lineno-$LINENO}: checking whether termios.h defines TIOCGWINSZ" >&5 $as_echo_n "checking whether termios.h defines TIOCGWINSZ... " >&6; } if ${ac_cv_sys_tiocgwinsz_in_termios_h+:} false; then : $as_echo_n "(cached) " >&6 else cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* 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:${as_lineno-$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:${as_lineno-$LINENO}: checking whether sys/ioctl.h defines TIOCGWINSZ" >&5 $as_echo_n "checking whether sys/ioctl.h defines TIOCGWINSZ... " >&6; } if ${ac_cv_sys_tiocgwinsz_in_sys_ioctl_h+:} false; then : $as_echo_n "(cached) " >&6 else cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* 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:${as_lineno-$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 $as_echo "#define GWINSZ_IN_SYS_IOCTL 1" >>confdefs.h fi fi for ac_header in assert.h complex.h ctype.h errno.h fcntl.h fenv.h float.h limits.h netdb.h netinet/in.h regex.h setjmp.h signal.h stdarg.h stddef.h stdio.h stdlib.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` ac_fn_c_check_header_mongrel "$LINENO" "$ac_header" "$as_ac_Header" "$ac_includes_default" if eval test \"x\$"$as_ac_Header"\" = 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:${as_lineno-$LINENO}: standard functions..." >&5 $as_echo "$as_me: standard functions..." >&6;} for ac_func in posix_memalign do : ac_fn_c_check_func "$LINENO" "posix_memalign" "ac_cv_func_posix_memalign" if test "x$ac_cv_func_posix_memalign" = xyes; then : cat >>confdefs.h <<_ACEOF #define HAVE_POSIX_MEMALIGN 1 _ACEOF fi done for ac_func in aligned_alloc do : ac_fn_c_check_func "$LINENO" "aligned_alloc" "ac_cv_func_aligned_alloc" if test "x$ac_cv_func_aligned_alloc" = xyes; then : cat >>confdefs.h <<_ACEOF #define HAVE_ALIGNED_ALLOC 1 _ACEOF fi done for ac_func in malloc do : ac_fn_c_check_func "$LINENO" "malloc" "ac_cv_func_malloc" if test "x$ac_cv_func_malloc" = xyes; then : cat >>confdefs.h <<_ACEOF #define HAVE_MALLOC 1 _ACEOF fi done for ac_func in free do : ac_fn_c_check_func "$LINENO" "free" "ac_cv_func_free" if test "x$ac_cv_func_free" = xyes; then : cat >>confdefs.h <<_ACEOF #define HAVE_FREE 1 _ACEOF fi done for ac_func in setjmp do : ac_fn_c_check_func "$LINENO" "setjmp" "ac_cv_func_setjmp" if test "x$ac_cv_func_setjmp" = xyes; then : cat >>confdefs.h <<_ACEOF #define HAVE_SETJMP 1 _ACEOF fi done for ac_func in longjmp do : ac_fn_c_check_func "$LINENO" "longjmp" "ac_cv_func_longjmp" if test "x$ac_cv_func_longjmp" = xyes; then : cat >>confdefs.h <<_ACEOF #define HAVE_LONGJMP 1 _ACEOF fi done for ac_func in memcpy do : ac_fn_c_check_func "$LINENO" "memcpy" "ac_cv_func_memcpy" if test "x$ac_cv_func_memcpy" = xyes; then : cat >>confdefs.h <<_ACEOF #define HAVE_MEMCPY 1 _ACEOF fi done for ac_func in memmove do : ac_fn_c_check_func "$LINENO" "memmove" "ac_cv_func_memmove" if test "x$ac_cv_func_memmove" = xyes; then : cat >>confdefs.h <<_ACEOF #define HAVE_MEMMOVE 1 _ACEOF fi done for ac_func in memset do : ac_fn_c_check_func "$LINENO" "memset" "ac_cv_func_memset" if test "x$ac_cv_func_memset" = xyes; then : cat >>confdefs.h <<_ACEOF #define HAVE_MEMSET 1 _ACEOF fi done for ac_func in strcmp do : ac_fn_c_check_func "$LINENO" "strcmp" "ac_cv_func_strcmp" if test "x$ac_cv_func_strcmp" = xyes; then : cat >>confdefs.h <<_ACEOF #define HAVE_STRCMP 1 _ACEOF fi done for ac_func in strncmp do : ac_fn_c_check_func "$LINENO" "strncmp" "ac_cv_func_strncmp" if test "x$ac_cv_func_strncmp" = xyes; then : cat >>confdefs.h <<_ACEOF #define HAVE_STRNCMP 1 _ACEOF fi done for ac_func in strncpy do : ac_fn_c_check_func "$LINENO" "strncpy" "ac_cv_func_strncpy" if test "x$ac_cv_func_strncpy" = xyes; then : cat >>confdefs.h <<_ACEOF #define HAVE_STRNCPY 1 _ACEOF fi done for ac_func in printf do : ac_fn_c_check_func "$LINENO" "printf" "ac_cv_func_printf" if test "x$ac_cv_func_printf" = xyes; then : cat >>confdefs.h <<_ACEOF #define HAVE_PRINTF 1 _ACEOF fi done for ac_func in fprintf do : ac_fn_c_check_func "$LINENO" "fprintf" "ac_cv_func_fprintf" if test "x$ac_cv_func_fprintf" = xyes; then : cat >>confdefs.h <<_ACEOF #define HAVE_FPRINTF 1 _ACEOF fi done for ac_func in snprintf do : ac_fn_c_check_func "$LINENO" "snprintf" "ac_cv_func_snprintf" if test "x$ac_cv_func_snprintf" = xyes; then : cat >>confdefs.h <<_ACEOF #define HAVE_SNPRINTF 1 _ACEOF fi done for ac_func in signal do : ac_fn_c_check_func "$LINENO" "signal" "ac_cv_func_signal" if test "x$ac_cv_func_signal" = xyes; then : cat >>confdefs.h <<_ACEOF #define HAVE_SIGNAL 1 _ACEOF fi done for ac_func in exit do : ac_fn_c_check_func "$LINENO" "exit" "ac_cv_func_exit" if test "x$ac_cv_func_exit" = xyes; then : cat >>confdefs.h <<_ACEOF #define HAVE_EXIT 1 _ACEOF fi done for ac_func in sqrt do : ac_fn_c_check_func "$LINENO" "sqrt" "ac_cv_func_sqrt" if test "x$ac_cv_func_sqrt" = xyes; then : cat >>confdefs.h <<_ACEOF #define HAVE_SQRT 1 _ACEOF fi done for ac_func in csqrt do : ac_fn_c_check_func "$LINENO" "csqrt" "ac_cv_func_csqrt" if test "x$ac_cv_func_csqrt" = xyes; then : cat >>confdefs.h <<_ACEOF #define HAVE_CSQRT 1 _ACEOF fi done # # Checks for functions / macros. # { $as_echo "$as_me:${as_lineno-$LINENO}: checking for isfinite" >&5 $as_echo_n "checking for isfinite... " >&6; } cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include int main () { int a = isfinite(0.0) ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO"; then : { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 $as_echo "yes" >&6; } $as_echo "#define HAVE_ISFINITE 1" >>confdefs.h else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext { $as_echo "$as_me:${as_lineno-$LINENO}: checking for finite" >&5 $as_echo_n "checking for finite... " >&6; } cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include int main () { int a = finite(0.0) ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO"; then : { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 $as_echo "yes" >&6; } $as_echo "#define HAVE_FINITE 1" >>confdefs.h else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext { $as_echo "$as_me:${as_lineno-$LINENO}: checking for isinf" >&5 $as_echo_n "checking for isinf... " >&6; } cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include int main () { int a = isinf(0.0) ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO"; then : { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 $as_echo "yes" >&6; } $as_echo "#define HAVE_ISINF 1" >>confdefs.h else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext { $as_echo "$as_me:${as_lineno-$LINENO}: checking for isnan" >&5 $as_echo_n "checking for isnan... " >&6; } cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include int main () { int a = isnan(0.0) ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO"; then : { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 $as_echo "yes" >&6; } $as_echo "#define HAVE_ISNAN 1" >>confdefs.h else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext { $as_echo "$as_me:${as_lineno-$LINENO}: optional headers and libraries..." >&5 $as_echo "$as_me: optional headers and libraries..." >&6;} if test "x$enable_standard_types" = "xyes"; then { $as_echo "$as_me:${as_lineno-$LINENO}: checking int is 32 bit" >&5 $as_echo_n "checking int is 32 bit... " >&6; } if test "$cross_compiling" = yes; then : { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error $? "cannot run test program while cross compiling See \`config.log' for more details" "$LINENO" 5; } else cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int main () { return sizeof (int) != 4; ; return 0; } _ACEOF if ac_fn_c_try_run "$LINENO"; then : { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 $as_echo "yes" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } enable_long_types=no fi rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ conftest.$ac_objext conftest.beam conftest.$ac_ext fi { $as_echo "$as_me:${as_lineno-$LINENO}: checking unsigned is 32 bit" >&5 $as_echo_n "checking unsigned is 32 bit... " >&6; } if test "$cross_compiling" = yes; then : { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error $? "cannot run test program while cross compiling See \`config.log' for more details" "$LINENO" 5; } else cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int main () { return sizeof (unsigned) != 4; ; return 0; } _ACEOF if ac_fn_c_try_run "$LINENO"; then : { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 $as_echo "yes" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } enable_long_types=no fi rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ conftest.$ac_objext conftest.beam conftest.$ac_ext fi { $as_echo "$as_me:${as_lineno-$LINENO}: checking double is 64 bit" >&5 $as_echo_n "checking double is 64 bit... " >&6; } if test "$cross_compiling" = yes; then : { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error $? "cannot run test program while cross compiling See \`config.log' for more details" "$LINENO" 5; } else cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int main () { return sizeof (double) != 8; ; return 0; } _ACEOF if ac_fn_c_try_run "$LINENO"; then : { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 $as_echo "yes" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } enable_long_types=no fi rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ conftest.$ac_objext conftest.beam conftest.$ac_ext fi { $as_echo "$as_me:${as_lineno-$LINENO}: checking uint64_t is 64 bit" >&5 $as_echo_n "checking uint64_t is 64 bit... " >&6; } if test "$cross_compiling" = yes; then : { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error $? "cannot run test program while cross compiling See \`config.log' for more details" "$LINENO" 5; } else cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include int main () { return sizeof (uint64_t) != 8; ; return 0; } _ACEOF if ac_fn_c_try_run "$LINENO"; then : { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 $as_echo "yes" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } enable_standard_types=no enable_long_types=no fi rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ conftest.$ac_objext conftest.beam conftest.$ac_ext fi fi if test "x$enable_standard_types" = "xno"; then { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error $? "stop -- unexpected lengths for int and/or double and/or uint64_t See \`config.log' for more details" "$LINENO" 5; } fi if test "x$enable_long_types" = "xyes"; then { $as_echo "$as_me:${as_lineno-$LINENO}: checking 64-bit long long int is available" >&5 $as_echo_n "checking 64-bit long long int is available... " >&6; } if test "$cross_compiling" = yes; then : { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error $? "cannot run test program while cross compiling See \`config.log' for more details" "$LINENO" 5; } else cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int main () { return sizeof (long long) != 8; ; return 0; } _ACEOF if ac_fn_c_try_run "$LINENO"; then : { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 $as_echo "yes" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } enable_long_types=no fi rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ conftest.$ac_objext conftest.beam conftest.$ac_ext fi { $as_echo "$as_me:${as_lineno-$LINENO}: checking 64-bit long long unsigned is available" >&5 $as_echo_n "checking 64-bit long long unsigned is available... " >&6; } if test "$cross_compiling" = yes; then : { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error $? "cannot run test program while cross compiling See \`config.log' for more details" "$LINENO" 5; } else cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int main () { return sizeof (long long unsigned) != 8; ; return 0; } _ACEOF if ac_fn_c_try_run "$LINENO"; then : { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 $as_echo "yes" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } enable_long_types=no fi rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ conftest.$ac_objext conftest.beam conftest.$ac_ext fi { $as_echo "$as_me:${as_lineno-$LINENO}: checking 80-bit __float80 is available" >&5 $as_echo_n "checking 80-bit __float80 is available... " >&6; } if test "$cross_compiling" = yes; then : { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error $? "cannot run test program while cross compiling See \`config.log' for more details" "$LINENO" 5; } else cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int main () { return sizeof (__float80) != 16; ; return 0; } _ACEOF if ac_fn_c_try_run "$LINENO"; then : { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 $as_echo "yes" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } enable_long_types=no fi rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ conftest.$ac_objext conftest.beam conftest.$ac_ext fi { $as_echo "$as_me:${as_lineno-$LINENO}: checking 80-bit __float80 has 64-bit mantissa" >&5 $as_echo_n "checking 80-bit __float80 has 64-bit mantissa... " >&6; } if test "$cross_compiling" = yes; then : { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error $? "cannot run test program while cross compiling See \`config.log' for more details" "$LINENO" 5; } else cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include int main () { return LDBL_MANT_DIG != 64; ; return 0; } _ACEOF if ac_fn_c_try_run "$LINENO"; then : { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 $as_echo "yes" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } enable_long_types=no fi rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ conftest.$ac_objext conftest.beam conftest.$ac_ext fi { $as_echo "$as_me:${as_lineno-$LINENO}: checking 128-bit __float128 is available" >&5 $as_echo_n "checking 128-bit __float128 is available... " >&6; } if test "$cross_compiling" = yes; then : { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error $? "cannot run test program while cross compiling See \`config.log' for more details" "$LINENO" 5; } else cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int main () { return sizeof (__float128) != 16; ; return 0; } _ACEOF if ac_fn_c_try_run "$LINENO"; then : { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 $as_echo "yes" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } enable_long_types=no fi rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ conftest.$ac_objext conftest.beam conftest.$ac_ext fi if test "x$enable_long_types" = "xyes"; then $as_echo "#define HAVE_LONG_TYPES 1" >>confdefs.h fi fi if test "x$enable_long_types" = "xyes"; then if test "x$enable_quadmath" = "xyes"; then { $as_echo "$as_me:${as_lineno-$LINENO}: quadmath..." >&5 $as_echo "$as_me: quadmath..." >&6;} for ac_header in quadmath.h do : ac_fn_c_check_header_mongrel "$LINENO" "quadmath.h" "ac_cv_header_quadmath_h" "$ac_includes_default" if test "x$ac_cv_header_quadmath_h" = xyes; then : cat >>confdefs.h <<_ACEOF #define HAVE_QUADMATH_H 1 _ACEOF else enable_quadmath=no fi done { $as_echo "$as_me:${as_lineno-$LINENO}: checking for lgammaq in -lquadmath" >&5 $as_echo_n "checking for lgammaq in -lquadmath... " >&6; } if ${ac_cv_lib_quadmath_lgammaq+:} false; then : $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lquadmath $LIBS" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* 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 lgammaq (); int main () { return lgammaq (); ; return 0; } _ACEOF if ac_fn_c_try_link "$LINENO"; then : ac_cv_lib_quadmath_lgammaq=yes else ac_cv_lib_quadmath_lgammaq=no fi rm -f core conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_quadmath_lgammaq" >&5 $as_echo "$ac_cv_lib_quadmath_lgammaq" >&6; } if test "x$ac_cv_lib_quadmath_lgammaq" = xyes; then : cat >>confdefs.h <<_ACEOF #define HAVE_LIBQUADMATH 1 _ACEOF LIBS="-lquadmath $LIBS" else enable_quadmath=no fi if test "x$enable_quadmath" = "xyes"; then $as_echo "#define HAVE_QUADMATH 1" >>confdefs.h fi fi else { $as_echo "$as_me:${as_lineno-$LINENO}: quadmath ignored for this system" >&5 $as_echo "$as_me: quadmath ignored for this system" >&6;} enable_quadmath=no fi if test "x$enable_long_types" = "xyes"; then if test "x$enable_mpfr" = "xyes"; then { $as_echo "$as_me:${as_lineno-$LINENO}: GNU MPFR..." >&5 $as_echo "$as_me: GNU MPFR..." >&6;} { $as_echo "$as_me:${as_lineno-$LINENO}: checking for __gmpz_init in -lgmp" >&5 $as_echo_n "checking for __gmpz_init in -lgmp... " >&6; } if ${ac_cv_lib_gmp___gmpz_init+:} false; then : $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgmp $LIBS" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* 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 __gmpz_init (); int main () { return __gmpz_init (); ; return 0; } _ACEOF if ac_fn_c_try_link "$LINENO"; then : ac_cv_lib_gmp___gmpz_init=yes else ac_cv_lib_gmp___gmpz_init=no fi rm -f core conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_gmp___gmpz_init" >&5 $as_echo "$ac_cv_lib_gmp___gmpz_init" >&6; } if test "x$ac_cv_lib_gmp___gmpz_init" = xyes; then : cat >>confdefs.h <<_ACEOF #define HAVE_LIBGMP 1 _ACEOF LIBS="-lgmp $LIBS" else enable_mpfr=no fi if test "x$enable_mpfr" = "xyes"; then for ac_header in mpfr.h do : ac_fn_c_check_header_mongrel "$LINENO" "mpfr.h" "ac_cv_header_mpfr_h" "$ac_includes_default" if test "x$ac_cv_header_mpfr_h" = xyes; then : cat >>confdefs.h <<_ACEOF #define HAVE_MPFR_H 1 _ACEOF fi done if test "x$enable_mpfr" = "xyes"; then { $as_echo "$as_me:${as_lineno-$LINENO}: checking for mpfr_gamma in -lmpfr" >&5 $as_echo_n "checking for mpfr_gamma in -lmpfr... " >&6; } if ${ac_cv_lib_mpfr_mpfr_gamma+:} false; then : $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lmpfr $LIBS" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* 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 mpfr_gamma (); int main () { return mpfr_gamma (); ; return 0; } _ACEOF if ac_fn_c_try_link "$LINENO"; then : ac_cv_lib_mpfr_mpfr_gamma=yes else ac_cv_lib_mpfr_mpfr_gamma=no fi rm -f core conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_mpfr_mpfr_gamma" >&5 $as_echo "$ac_cv_lib_mpfr_mpfr_gamma" >&6; } if test "x$ac_cv_lib_mpfr_mpfr_gamma" = xyes; then : cat >>confdefs.h <<_ACEOF #define HAVE_LIBMPFR 1 _ACEOF LIBS="-lmpfr $LIBS" else enable_mpfr=no fi { $as_echo "$as_me:${as_lineno-$LINENO}: checking for mpfr_gamma_inc in -lmpfr" >&5 $as_echo_n "checking for mpfr_gamma_inc in -lmpfr... " >&6; } if ${ac_cv_lib_mpfr_mpfr_gamma_inc+:} false; then : $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lmpfr $LIBS" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* 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 mpfr_gamma_inc (); int main () { return mpfr_gamma_inc (); ; return 0; } _ACEOF if ac_fn_c_try_link "$LINENO"; then : ac_cv_lib_mpfr_mpfr_gamma_inc=yes else ac_cv_lib_mpfr_mpfr_gamma_inc=no fi rm -f core conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_mpfr_mpfr_gamma_inc" >&5 $as_echo "$ac_cv_lib_mpfr_mpfr_gamma_inc" >&6; } if test "x$ac_cv_lib_mpfr_mpfr_gamma_inc" = xyes; then : cat >>confdefs.h <<_ACEOF #define HAVE_LIBMPFR 1 _ACEOF LIBS="-lmpfr $LIBS" else enable_mpfr=no fi { $as_echo "$as_me:${as_lineno-$LINENO}: checking for mpfr_get_float128 in -lmpfr" >&5 $as_echo_n "checking for mpfr_get_float128 in -lmpfr... " >&6; } if ${ac_cv_lib_mpfr_mpfr_get_float128+:} false; then : $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lmpfr $LIBS" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* 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 mpfr_get_float128 (); int main () { return mpfr_get_float128 (); ; return 0; } _ACEOF if ac_fn_c_try_link "$LINENO"; then : ac_cv_lib_mpfr_mpfr_get_float128=yes else ac_cv_lib_mpfr_mpfr_get_float128=no fi rm -f core conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_mpfr_mpfr_get_float128" >&5 $as_echo "$ac_cv_lib_mpfr_mpfr_get_float128" >&6; } if test "x$ac_cv_lib_mpfr_mpfr_get_float128" = xyes; then : cat >>confdefs.h <<_ACEOF #define HAVE_LIBMPFR 1 _ACEOF LIBS="-lmpfr $LIBS" else enable_mpfr=no fi { $as_echo "$as_me:${as_lineno-$LINENO}: checking for mpfr_set_float128 in -lmpfr" >&5 $as_echo_n "checking for mpfr_set_float128 in -lmpfr... " >&6; } if ${ac_cv_lib_mpfr_mpfr_set_float128+:} false; then : $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lmpfr $LIBS" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* 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 mpfr_set_float128 (); int main () { return mpfr_set_float128 (); ; return 0; } _ACEOF if ac_fn_c_try_link "$LINENO"; then : ac_cv_lib_mpfr_mpfr_set_float128=yes else ac_cv_lib_mpfr_mpfr_set_float128=no fi rm -f core conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_mpfr_mpfr_set_float128" >&5 $as_echo "$ac_cv_lib_mpfr_mpfr_set_float128" >&6; } if test "x$ac_cv_lib_mpfr_mpfr_set_float128" = xyes; then : cat >>confdefs.h <<_ACEOF #define HAVE_LIBMPFR 1 _ACEOF LIBS="-lmpfr $LIBS" else enable_mpfr=no fi if test "x$enable_mpfr" = "xyes"; then $as_echo "#define HAVE_GNU_MPFR 1" >>confdefs.h fi fi fi fi else { $as_echo "$as_me:${as_lineno-$LINENO}: GNU MPFR ignored for this system" >&5 $as_echo "$as_me: GNU MPFR ignored for this system" >&6;} enable_mpfr=no fi if test "x$enable_parallel" = "xyes"; then { $as_echo "$as_me:${as_lineno-$LINENO}: POSIX pthreads..." >&5 $as_echo "$as_me: POSIX pthreads..." >&6;} for ac_header in pthread.h do : ac_fn_c_check_header_mongrel "$LINENO" "pthread.h" "ac_cv_header_pthread_h" "$ac_includes_default" if test "x$ac_cv_header_pthread_h" = xyes; then : cat >>confdefs.h <<_ACEOF #define HAVE_PTHREAD_H 1 _ACEOF else enable_parallel=no fi done { $as_echo "$as_me:${as_lineno-$LINENO}: checking for pthread_attr_getstacksize in -lpthread" >&5 $as_echo_n "checking for pthread_attr_getstacksize in -lpthread... " >&6; } if ${ac_cv_lib_pthread_pthread_attr_getstacksize+:} false; then : $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lpthread $LIBS" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* 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 if ac_fn_c_try_link "$LINENO"; then : ac_cv_lib_pthread_pthread_attr_getstacksize=yes else ac_cv_lib_pthread_pthread_attr_getstacksize=no fi rm -f core conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:${as_lineno-$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" = xyes; then : cat >>confdefs.h <<_ACEOF #define HAVE_LIBPTHREAD 1 _ACEOF LIBS="-lpthread $LIBS" else enable_parallel=no fi if test "x$enable_parallel" = "xyes"; then $as_echo "#define BUILD_PARALLEL_CLAUSE 1" >>confdefs.h fi fi if test "x$enable_mathlib" = "xyes"; then { $as_echo "$as_me:${as_lineno-$LINENO}: mathlib..." >&5 $as_echo "$as_me: mathlib..." >&6;} for ac_header in Rmath.h do : ac_fn_c_check_header_compile "$LINENO" "Rmath.h" "ac_cv_header_Rmath_h" "#define MATHLIB_STANDALONE #include " if test "x$ac_cv_header_Rmath_h" = xyes; then : cat >>confdefs.h <<_ACEOF #define HAVE_RMATH_H 1 _ACEOF else enable_mathlib=no fi done { $as_echo "$as_me:${as_lineno-$LINENO}: checking for ptukey in -lRmath" >&5 $as_echo_n "checking for ptukey in -lRmath... " >&6; } if ${ac_cv_lib_Rmath_ptukey+:} false; then : $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lRmath $LIBS" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* 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 ptukey (); int main () { return ptukey (); ; return 0; } _ACEOF if ac_fn_c_try_link "$LINENO"; then : ac_cv_lib_Rmath_ptukey=yes else ac_cv_lib_Rmath_ptukey=no fi rm -f core conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_Rmath_ptukey" >&5 $as_echo "$ac_cv_lib_Rmath_ptukey" >&6; } if test "x$ac_cv_lib_Rmath_ptukey" = xyes; then : cat >>confdefs.h <<_ACEOF #define HAVE_LIBRMATH 1 _ACEOF LIBS="-lRmath $LIBS" else enable_mathlib=no fi if test "x$enable_mathlib" = "xyes"; then $as_echo "#define HAVE_MATHLIB 1" >>confdefs.h fi fi if test "x$enable_gsl" = "xyes"; then { $as_echo "$as_me:${as_lineno-$LINENO}: GNU Scientific Library..." >&5 $as_echo "$as_me: GNU Scientific Library..." >&6;} # Check whether --with-gsl-prefix was given. if test "${with_gsl_prefix+set}" = set; then : withval=$with_gsl_prefix; gsl_prefix="$withval" else gsl_prefix="" fi # Check whether --with-gsl-exec-prefix was given. if test "${with_gsl_exec_prefix+set}" = set; then : withval=$with_gsl_exec_prefix; gsl_exec_prefix="$withval" else gsl_exec_prefix="" fi # Check whether --enable-gsltest was given. if test "${enable_gsltest+set}" = set; then : enableval=$enable_gsltest; else enable_gsltest=yes fi if test "x${GSL_CONFIG+set}" != xset ; then if test "x$gsl_prefix" != x ; then GSL_CONFIG="$gsl_prefix/bin/gsl-config" fi if test "x$gsl_exec_prefix" != x ; then GSL_CONFIG="$gsl_exec_prefix/bin/gsl-config" fi fi # Extract the first word of "gsl-config", so it can be a program name with args. set dummy gsl-config; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if ${ac_cv_path_GSL_CONFIG+:} false; then : $as_echo_n "(cached) " >&6 else case $GSL_CONFIG in [\\/]* | ?:[\\/]*) ac_cv_path_GSL_CONFIG="$GSL_CONFIG" # Let the user override the test with a path. ;; *) as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_path_GSL_CONFIG="$as_dir/$ac_word$ac_exec_ext" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS test -z "$ac_cv_path_GSL_CONFIG" && ac_cv_path_GSL_CONFIG="no" ;; esac fi GSL_CONFIG=$ac_cv_path_GSL_CONFIG if test -n "$GSL_CONFIG"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $GSL_CONFIG" >&5 $as_echo "$GSL_CONFIG" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi min_gsl_version=2.5 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for GSL version >= $min_gsl_version" >&5 $as_echo_n "checking for GSL version >= $min_gsl_version... " >&6; } no_gsl="" if test "$GSL_CONFIG" = "no" ; then no_gsl=yes else GSL_CFLAGS=`$GSL_CONFIG --cflags` GSL_LIBS=`$GSL_CONFIG --libs` gsl_major_version=`$GSL_CONFIG --version | \ sed 's/^\([0-9]*\).*/\1/'` if test "x${gsl_major_version}" = "x" ; then gsl_major_version=0 fi gsl_minor_version=`$GSL_CONFIG --version | \ sed 's/^\([0-9]*\)\.\{0,1\}\([0-9]*\).*/\2/'` if test "x${gsl_minor_version}" = "x" ; then gsl_minor_version=0 fi gsl_micro_version=`$GSL_CONFIG --version | \ sed 's/^\([0-9]*\)\.\{0,1\}\([0-9]*\)\.\{0,1\}\([0-9]*\).*/\3/'` if test "x${gsl_micro_version}" = "x" ; then gsl_micro_version=0 fi if test "x$enable_gsltest" = "xyes" ; then ac_save_CFLAGS="$CFLAGS" ac_save_LIBS="$LIBS" CFLAGS="$CFLAGS $GSL_CFLAGS" LIBS="$LIBS $GSL_LIBS" rm -f conf.gsltest if test "$cross_compiling" = yes; then : echo $ac_n "cross compiling; assumed OK... $ac_c" else cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include #include #include char* my_strdup (const char *str); char* my_strdup (const char *str) { char *new_str; if (str) { new_str = (char *)malloc ((strlen (str) + 1) * sizeof(char)); strcpy (new_str, str); } else new_str = NULL; return new_str; } int main (void) { int major = 0, minor = 0, micro = 0; int n; char *tmp_version; system ("touch conf.gsltest"); /* HP/UX 9 (%@#!) writes to sscanf strings */ tmp_version = my_strdup("$min_gsl_version"); n = sscanf(tmp_version, "%d.%d.%d", &major, &minor, µ) ; if (n != 2 && n != 3) { printf("%s, bad version string\n", "$min_gsl_version"); exit(1); } if (($gsl_major_version > major) || (($gsl_major_version == major) && ($gsl_minor_version > minor)) || (($gsl_major_version == major) && ($gsl_minor_version == minor) && ($gsl_micro_version >= micro))) { exit(0); } else { exit(1); } } _ACEOF if ac_fn_c_try_run "$LINENO"; then : else no_gsl=yes fi rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ conftest.$ac_objext conftest.beam conftest.$ac_ext fi CFLAGS="$ac_save_CFLAGS" LIBS="$ac_save_LIBS" fi fi if test "x$no_gsl" = x ; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 $as_echo "yes" >&6; } enable_gsl=yes else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } if test "$GSL_CONFIG" = "no" ; then echo "*** The gsl-config script installed by GSL could not be found" echo "*** If GSL was installed in PREFIX, make sure PREFIX/bin is in" echo "*** your path, or set the GSL_CONFIG environment variable to the" echo "*** full path to gsl-config." else if test -f conf.gsltest ; then : else echo "*** Could not run GSL test program, checking why..." CFLAGS="$CFLAGS $GSL_CFLAGS" LIBS="$LIBS $GSL_LIBS" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include int main () { return 0; ; return 0; } _ACEOF if ac_fn_c_try_link "$LINENO"; then : echo "*** The test program compiled, but did not run. This usually means" echo "*** that the run-time linker is not finding GSL or finding the wrong" echo "*** version of GSL. If it is not finding GSL, you'll need to set your" echo "*** LD_LIBRARY_PATH environment variable, or edit /etc/ld.so.conf to point" echo "*** to the installed location Also, make sure you have run ldconfig if that" echo "*** is required on your system" echo "***" echo "*** If you have an old version installed, it is best to remove it, although" echo "*** you may also be able to get things to work by modifying LD_LIBRARY_PATH" else echo "*** The test program failed to compile or link. See the file config.log for the" echo "*** exact error that occured. This usually means GSL was incorrectly installed" echo "*** or that you have moved GSL since it was installed. In the latter case, you" echo "*** may want to edit the gsl-config script: $GSL_CONFIG" fi rm -f core conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext CFLAGS="$ac_save_CFLAGS" LIBS="$ac_save_LIBS" fi fi # GSL_CFLAGS="" # GSL_LIBS="" enable_gsl=no fi rm -f conf.gsltest if test "x$enable_gsl" = "xyes"; then { $as_echo "$as_me:${as_lineno-$LINENO}: checking for cblas_dgemm in -lgslcblas" >&5 $as_echo_n "checking for cblas_dgemm in -lgslcblas... " >&6; } if ${ac_cv_lib_gslcblas_cblas_dgemm+:} false; then : $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgslcblas $LIBS" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* 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 if ac_fn_c_try_link "$LINENO"; then : ac_cv_lib_gslcblas_cblas_dgemm=yes else ac_cv_lib_gslcblas_cblas_dgemm=no fi rm -f core conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:${as_lineno-$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" = xyes; then : cat >>confdefs.h <<_ACEOF #define HAVE_LIBGSLCBLAS 1 _ACEOF LIBS="-lgslcblas $LIBS" else enable_gsl=no fi { $as_echo "$as_me:${as_lineno-$LINENO}: checking for gsl_blas_ddot in -lgsl" >&5 $as_echo_n "checking for gsl_blas_ddot in -lgsl... " >&6; } if ${ac_cv_lib_gsl_gsl_blas_ddot+:} false; then : $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* 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 if ac_fn_c_try_link "$LINENO"; then : ac_cv_lib_gsl_gsl_blas_ddot=yes else ac_cv_lib_gsl_gsl_blas_ddot=no fi rm -f core conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:${as_lineno-$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" = xyes; then : cat >>confdefs.h <<_ACEOF #define HAVE_LIBGSL 1 _ACEOF LIBS="-lgsl $LIBS" else enable_gsl=no fi 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 gsl/gsl_version.h do : as_ac_Header=`$as_echo "ac_cv_header_$ac_header" | $as_tr_sh` ac_fn_c_check_header_mongrel "$LINENO" "$ac_header" "$as_ac_Header" "$ac_includes_default" if eval test \"x\$"$as_ac_Header"\" = x"yes"; then : cat >>confdefs.h <<_ACEOF #define `$as_echo "HAVE_$ac_header" | $as_tr_cpp` 1 _ACEOF else enable_gsl=no fi done fi if test "x$enable_gsl" = "xyes"; then $as_echo "#define HAVE_GSL 1" >>confdefs.h fi fi if test "x$enable_plotutils" = "xyes"; then { $as_echo "$as_me:${as_lineno-$LINENO}: GNU plotutils..." >&5 $as_echo "$as_me: GNU plotutils..." >&6;} for ac_header in plot.h do : ac_fn_c_check_header_mongrel "$LINENO" "plot.h" "ac_cv_header_plot_h" "$ac_includes_default" if test "x$ac_cv_header_plot_h" = xyes; then : cat >>confdefs.h <<_ACEOF #define HAVE_PLOT_H 1 _ACEOF else enable_plotutils=no fi done { $as_echo "$as_me:${as_lineno-$LINENO}: checking for pl_alabel_r in -lplot" >&5 $as_echo_n "checking for pl_alabel_r in -lplot... " >&6; } if ${ac_cv_lib_plot_pl_alabel_r+:} false; then : $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lplot $LIBS" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* 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 if ac_fn_c_try_link "$LINENO"; then : ac_cv_lib_plot_pl_alabel_r=yes else ac_cv_lib_plot_pl_alabel_r=no fi rm -f core conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:${as_lineno-$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" = xyes; then : cat >>confdefs.h <<_ACEOF #define HAVE_LIBPLOT 1 _ACEOF LIBS="-lplot $LIBS" else enable_plotutils=no fi if test "x$enable_plotutils" = "xyes"; then $as_echo "#define HAVE_GNU_PLOTUTILS 1" >>confdefs.h fi fi if test "x$enable_curses" = "xyes"; then { $as_echo "$as_me:${as_lineno-$LINENO}: curses..." >&5 $as_echo "$as_me: curses..." >&6;} for ac_header in curses.h do : ac_fn_c_check_header_mongrel "$LINENO" "curses.h" "ac_cv_header_curses_h" "$ac_includes_default" if test "x$ac_cv_header_curses_h" = xyes; then : cat >>confdefs.h <<_ACEOF #define HAVE_CURSES_H 1 _ACEOF else enable_curses=no fi done if test "x$enable_curses" = "xno"; then for ac_header in ncurses/curses.h do : ac_fn_c_check_header_mongrel "$LINENO" "ncurses/curses.h" "ac_cv_header_ncurses_curses_h" "$ac_includes_default" if test "x$ac_cv_header_ncurses_curses_h" = xyes; then : cat >>confdefs.h <<_ACEOF #define HAVE_NCURSES_CURSES_H 1 _ACEOF enable_curses=yes fi done fi if test "x$enable_curses" = "xyes"; then { $as_echo "$as_me:${as_lineno-$LINENO}: checking for stdscr in -ltinfo" >&5 $as_echo_n "checking for stdscr in -ltinfo... " >&6; } if ${ac_cv_lib_tinfo_stdscr+:} false; then : $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-ltinfo $LIBS" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* 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 stdscr (); int main () { return stdscr (); ; return 0; } _ACEOF if ac_fn_c_try_link "$LINENO"; then : ac_cv_lib_tinfo_stdscr=yes else ac_cv_lib_tinfo_stdscr=no fi rm -f core conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_tinfo_stdscr" >&5 $as_echo "$ac_cv_lib_tinfo_stdscr" >&6; } if test "x$ac_cv_lib_tinfo_stdscr" = xyes; then : cat >>confdefs.h <<_ACEOF #define HAVE_LIBTINFO 1 _ACEOF LIBS="-ltinfo $LIBS" else enable_curses=no fi { $as_echo "$as_me:${as_lineno-$LINENO}: checking for stdscr in -ltic" >&5 $as_echo_n "checking for stdscr in -ltic... " >&6; } if ${ac_cv_lib_tic_stdscr+:} false; then : $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-ltic $LIBS" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* 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 stdscr (); int main () { return stdscr (); ; return 0; } _ACEOF if ac_fn_c_try_link "$LINENO"; then : ac_cv_lib_tic_stdscr=yes else ac_cv_lib_tic_stdscr=no fi rm -f core conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_tic_stdscr" >&5 $as_echo "$ac_cv_lib_tic_stdscr" >&6; } if test "x$ac_cv_lib_tic_stdscr" = xyes; then : cat >>confdefs.h <<_ACEOF #define HAVE_LIBTIC 1 _ACEOF LIBS="-ltic $LIBS" else enable_curses=no fi { $as_echo "$as_me:${as_lineno-$LINENO}: checking for initscr in -lncurses" >&5 $as_echo_n "checking for initscr in -lncurses... " >&6; } if ${ac_cv_lib_ncurses_initscr+:} false; then : $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lncurses $LIBS" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* 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 if ac_fn_c_try_link "$LINENO"; then : ac_cv_lib_ncurses_initscr=yes else ac_cv_lib_ncurses_initscr=no fi rm -f core conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_ncurses_initscr" >&5 $as_echo "$ac_cv_lib_ncurses_initscr" >&6; } if test "x$ac_cv_lib_ncurses_initscr" = xyes; 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 : ac_fn_c_check_header_mongrel "$LINENO" "readline/readline.h" "ac_cv_header_readline_readline_h" "$ac_includes_default" if test "x$ac_cv_header_readline_readline_h" = xyes; then : cat >>confdefs.h <<_ACEOF #define HAVE_READLINE_READLINE_H 1 _ACEOF else enable_readline=no fi done for ac_header in readline/history.h do : ac_fn_c_check_header_mongrel "$LINENO" "readline/history.h" "ac_cv_header_readline_history_h" "$ac_includes_default" if test "x$ac_cv_header_readline_history_h" = xyes; then : cat >>confdefs.h <<_ACEOF #define HAVE_READLINE_HISTORY_H 1 _ACEOF else enable_readline=no fi done if test "x$enable_readline" = "xyes"; then { $as_echo "$as_me:${as_lineno-$LINENO}: checking for readline in -lreadline" >&5 $as_echo_n "checking for readline in -lreadline... " >&6; } if ${ac_cv_lib_readline_readline+:} false; then : $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lreadline -lcurses $LIBS" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* 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 if ac_fn_c_try_link "$LINENO"; then : ac_cv_lib_readline_readline=yes else ac_cv_lib_readline_readline=no fi rm -f core conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_readline_readline" >&5 $as_echo "$ac_cv_lib_readline_readline" >&6; } if test "x$ac_cv_lib_readline_readline" = xyes; 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 $as_echo "#define HAVE_READLINE 1" >>confdefs.h fi fi fi fi if test "x$enable_curses" = "xno"; then { $as_echo "$as_me:${as_lineno-$LINENO}: checking for initscr in -lcurses" >&5 $as_echo_n "checking for initscr in -lcurses... " >&6; } if ${ac_cv_lib_curses_initscr+:} false; then : $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lcurses $LIBS" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* 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 if ac_fn_c_try_link "$LINENO"; then : ac_cv_lib_curses_initscr=yes else ac_cv_lib_curses_initscr=no fi rm -f core conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_curses_initscr" >&5 $as_echo "$ac_cv_lib_curses_initscr" >&6; } if test "x$ac_cv_lib_curses_initscr" = xyes; then : enable_curses=yes fi fi if test "x$enable_curses" = "xyes"; then $as_echo "#define HAVE_CURSES 1" >>confdefs.h fi fi fi if test "x$enable_postgresql" = "xyes"; then { $as_echo "$as_me:${as_lineno-$LINENO}: PostgreSQL..." >&5 $as_echo "$as_me: PostgreSQL..." >&6;} for ac_header in libpq-fe.h do : ac_fn_c_check_header_mongrel "$LINENO" "libpq-fe.h" "ac_cv_header_libpq_fe_h" "$ac_includes_default" if test "x$ac_cv_header_libpq_fe_h" = xyes; then : cat >>confdefs.h <<_ACEOF #define HAVE_LIBPQ_FE_H 1 _ACEOF else enable_postgresql=no fi done { $as_echo "$as_me:${as_lineno-$LINENO}: checking for PQbackendPID in -lpq" >&5 $as_echo_n "checking for PQbackendPID in -lpq... " >&6; } if ${ac_cv_lib_pq_PQbackendPID+:} false; then : $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lpq $LIBS" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* 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 if ac_fn_c_try_link "$LINENO"; then : ac_cv_lib_pq_PQbackendPID=yes else ac_cv_lib_pq_PQbackendPID=no fi rm -f core conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_pq_PQbackendPID" >&5 $as_echo "$ac_cv_lib_pq_PQbackendPID" >&6; } if test "x$ac_cv_lib_pq_PQbackendPID" = xyes; then : cat >>confdefs.h <<_ACEOF #define HAVE_LIBPQ 1 _ACEOF LIBS="-lpq $LIBS" else enable_postgresql=no fi if test "x$enable_postgresql" = "xyes"; then $as_echo "#define HAVE_POSTGRESQL 1" >>confdefs.h fi fi if test "x$enable_compiler" = "xyes"; then libdl_found=no { $as_echo "$as_me:${as_lineno-$LINENO}: Dynamic loader via libdl..." >&5 $as_echo "$as_me: Dynamic loader via libdl..." >&6;} for ac_header in dlfcn.h do : ac_fn_c_check_header_mongrel "$LINENO" "dlfcn.h" "ac_cv_header_dlfcn_h" "$ac_includes_default" if test "x$ac_cv_header_dlfcn_h" = xyes; then : cat >>confdefs.h <<_ACEOF #define HAVE_DLFCN_H 1 _ACEOF fi done { $as_echo "$as_me:${as_lineno-$LINENO}: checking for library containing dlopen" >&5 $as_echo_n "checking for library containing dlopen... " >&6; } if ${ac_cv_search_dlopen+:} false; then : $as_echo_n "(cached) " >&6 else ac_func_search_save_LIBS=$LIBS cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* 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 for ac_lib in '' dl; 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 if ac_fn_c_try_link "$LINENO"; then : ac_cv_search_dlopen=$ac_res fi rm -f core conftest.err conftest.$ac_objext \ conftest$ac_exeext if ${ac_cv_search_dlopen+:} false; then : break fi done if ${ac_cv_search_dlopen+:} false; then : else ac_cv_search_dlopen=no fi rm conftest.$ac_ext LIBS=$ac_func_search_save_LIBS fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_search_dlopen" >&5 $as_echo "$ac_cv_search_dlopen" >&6; } ac_res=$ac_cv_search_dlopen if test "$ac_res" != no; then : test "$ac_res" = "none required" || LIBS="$ac_res $LIBS" else enable_compiler=no fi if test "x$enable_compiler" = "xyes"; then $as_echo "#define HAVE_DL 1" >>confdefs.h libdl_found=yes fi fi # Are we on Haiku? if test "x$enable_compiler" = "xyes"; then if test "x$libdl_found" = "xno"; then { $as_echo "$as_me:${as_lineno-$LINENO}: Dynamic loader via libroot..." >&5 $as_echo "$as_me: Dynamic loader via libroot..." >&6;} for ac_header in dlfcn.h do : ac_fn_c_check_header_mongrel "$LINENO" "dlfcn.h" "ac_cv_header_dlfcn_h" "$ac_includes_default" if test "x$ac_cv_header_dlfcn_h" = xyes; then : cat >>confdefs.h <<_ACEOF #define HAVE_DLFCN_H 1 _ACEOF fi done { $as_echo "$as_me:${as_lineno-$LINENO}: checking for dlopen in -lroot" >&5 $as_echo_n "checking for dlopen in -lroot... " >&6; } if ${ac_cv_lib_root_dlopen+:} false; then : $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lroot $LIBS" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* 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 if ac_fn_c_try_link "$LINENO"; then : ac_cv_lib_root_dlopen=yes else ac_cv_lib_root_dlopen=no fi rm -f core conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_root_dlopen" >&5 $as_echo "$ac_cv_lib_root_dlopen" >&6; } if test "x$ac_cv_lib_root_dlopen" = xyes; then : cat >>confdefs.h <<_ACEOF #define HAVE_LIBROOT 1 _ACEOF LIBS="-lroot $LIBS" else enable_compiler=no fi if test "x$enable_compiler" = "xyes"; then $as_echo "#define HAVE_DL 1" >>confdefs.h fi 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:${as_lineno-$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= ;; #( *) { eval $ac_var=; 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 if test "x$cache_file" != "x/dev/null"; then { $as_echo "$as_me:${as_lineno-$LINENO}: updating cache $cache_file" >&5 $as_echo "$as_me: updating cache $cache_file" >&6;} if test ! -f "$cache_file" || test -h "$cache_file"; then cat confcache >"$cache_file" else case $cache_file in #( */* | ?:*) mv -f confcache "$cache_file"$$ && mv -f "$cache_file"$$ "$cache_file" ;; #( *) mv -f confcache "$cache_file" ;; esac fi fi else { $as_echo "$as_me:${as_lineno-$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= U= 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. as_fn_append ac_libobjs " \${LIBOBJDIR}$ac_i\$U.$ac_objext" as_fn_append ac_ltlibobjs " \${LIBOBJDIR}$ac_i"'$U.lo' done LIBOBJS=$ac_libobjs LTLIBOBJS=$ac_ltlibobjs { $as_echo "$as_me:${as_lineno-$LINENO}: checking that generated files are newer than configure" >&5 $as_echo_n "checking that generated files are newer than configure... " >&6; } if test -n "$am_sleep_pid"; then # Hide warnings about reused PIDs. wait $am_sleep_pid 2>/dev/null fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: done" >&5 $as_echo "done" >&6; } if test -n "$EXEEXT"; then am__EXEEXT_TRUE= am__EXEEXT_FALSE='#' else am__EXEEXT_TRUE='#' am__EXEEXT_FALSE= fi if test -z "${AMDEP_TRUE}" && test -z "${AMDEP_FALSE}"; then as_fn_error $? "conditional \"AMDEP\" was never defined. Usually this means the macro was only invoked conditionally." "$LINENO" 5 fi if test -z "${am__fastdepCC_TRUE}" && test -z "${am__fastdepCC_FALSE}"; then as_fn_error $? "conditional \"am__fastdepCC\" was never defined. Usually this means the macro was only invoked conditionally." "$LINENO" 5 fi if test -z "${EXPORT_DYNAMIC_TRUE}" && test -z "${EXPORT_DYNAMIC_FALSE}"; then as_fn_error $? "conditional \"EXPORT_DYNAMIC\" was never defined. Usually this means the macro was only invoked conditionally." "$LINENO" 5 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:${as_lineno-$LINENO}: creating $CONFIG_STATUS" >&5 $as_echo "$as_me: creating $CONFIG_STATUS" >&6;} as_write_fail=0 cat >$CONFIG_STATUS <<_ASEOF || as_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} export SHELL _ASEOF cat >>$CONFIG_STATUS <<\_ASEOF || as_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 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 # Prefer a ksh shell builtin over an external printf program on Solaris, # but without wasting forks for bash or zsh. if test -z "$BASH_VERSION$ZSH_VERSION" \ && (test "X`print -r -- $as_echo`" = "X$as_echo") 2>/dev/null; then as_echo='print -r --' as_echo_n='print -rn --' elif (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 # 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. as_myself= 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 fi # Unset variables that we do not need and which cause bugs (e.g. in # pre-3.0 UWIN ksh). But do not cause bugs in bash 2.01; the "|| exit 1" # suppresses any "Segmentation fault" message there. '((' could # trigger a bug in pdksh 5.2.14. for as_var in BASH_ENV ENV MAIL MAILPATH do eval test x\${$as_var+set} = xset \ && ( (unset $as_var) || exit 1) >/dev/null 2>&1 && unset $as_var || : done PS1='$ ' PS2='> ' PS4='+ ' # NLS nuisances. LC_ALL=C export LC_ALL LANGUAGE=C export LANGUAGE # CDPATH. (unset CDPATH) >/dev/null 2>&1 && unset CDPATH # as_fn_error STATUS ERROR [LINENO LOG_FD] # ---------------------------------------- # Output "`basename $0`: error: ERROR" to stderr. If LINENO and LOG_FD are # provided, also output the error to LOG_FD, referencing LINENO. Then exit the # script with STATUS, using 1 if that was 0. as_fn_error () { as_status=$1; test $as_status -eq 0 && as_status=1 if test "$4"; then as_lineno=${as_lineno-"$3"} as_lineno_stack=as_lineno_stack=$as_lineno_stack $as_echo "$as_me:${as_lineno-$LINENO}: error: $2" >&$4 fi $as_echo "$as_me: error: $2" >&2 as_fn_exit $as_status } # as_fn_error # as_fn_set_status STATUS # ----------------------- # Set $? to STATUS, without forking. as_fn_set_status () { return $1 } # as_fn_set_status # as_fn_exit STATUS # ----------------- # Exit the shell with STATUS, even in a "trap 0" or "set -e" context. as_fn_exit () { set +e as_fn_set_status $1 exit $1 } # as_fn_exit # as_fn_unset VAR # --------------- # Portably unset VAR. as_fn_unset () { { eval $1=; unset $1;} } as_unset=as_fn_unset # as_fn_append VAR VALUE # ---------------------- # Append the text in VALUE to the end of the definition contained in VAR. Take # advantage of any shell optimizations that allow amortized linear growth over # repeated appends, instead of the typical quadratic growth present in naive # implementations. if (eval "as_var=1; as_var+=2; test x\$as_var = x12") 2>/dev/null; then : eval 'as_fn_append () { eval $1+=\$2 }' else as_fn_append () { eval $1=\$$1\$2 } fi # as_fn_append # as_fn_arith ARG... # ------------------ # Perform arithmetic evaluation on the ARGs, and store the result in the # global $as_val. Take advantage of shells that can avoid forks. The arguments # must be portable across $(()) and expr. if (eval "test \$(( 1 + 1 )) = 2") 2>/dev/null; then : eval 'as_fn_arith () { as_val=$(( $* )) }' else as_fn_arith () { as_val=`expr "$@" || test $? -eq 1` } fi # as_fn_arith 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 if (as_dir=`dirname -- /` && test "X$as_dir" = X/) >/dev/null 2>&1; then as_dirname=dirname else as_dirname=false fi 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'` # 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 ECHO_C= ECHO_N= ECHO_T= case `echo -n x` in #((((( -n*) case `echo 'xy\c'` in *c*) ECHO_T=' ';; # ECHO_T is single tab character. xy) ECHO_C='\c';; *) echo `echo ksh88 bug on AIX 6.1` > /dev/null ECHO_T=' ';; esac;; *) ECHO_N='-n';; esac 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 -pR'. ln -s conf$$.file conf$$.dir 2>/dev/null && test ! -f conf$$.exe || as_ln_s='cp -pR' elif ln conf$$.file conf$$ 2>/dev/null; then as_ln_s=ln else as_ln_s='cp -pR' fi else as_ln_s='cp -pR' fi rm -f conf$$ conf$$.exe conf$$.dir/conf$$.file conf$$.file rmdir conf$$.dir 2>/dev/null # as_fn_mkdir_p # ------------- # Create "$as_dir" as a directory, including parents if necessary. as_fn_mkdir_p () { case $as_dir in #( -*) as_dir=./$as_dir;; esac test -d "$as_dir" || eval $as_mkdir_p || { 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_fn_error $? "cannot create directory $as_dir" } # as_fn_mkdir_p if mkdir -p . 2>/dev/null; then as_mkdir_p='mkdir -p "$as_dir"' else test -d ./-p && rmdir ./-p as_mkdir_p=false fi # as_fn_executable_p FILE # ----------------------- # Test if FILE is an executable regular file. as_fn_executable_p () { test -f "$1" && test -x "$1" } # as_fn_executable_p as_test_x='test -x' as_executable_p=as_fn_executable_p # 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 ## ----------------------------------- ## ## Main body of $CONFIG_STATUS script. ## ## ----------------------------------- ## _ASEOF test $as_write_fail = 0 && chmod +x $CONFIG_STATUS || ac_write_fail=1 cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=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 3.1.2, which was generated by GNU Autoconf 2.69. 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 and other configuration actions from templates according to the current configuration. Unless the files and actions are specified as TAGs, all are instantiated by default. Usage: $0 [OPTION]... [TAG]... -h, --help print this help, then exit -V, --version print version number and configuration settings, then exit --config print configuration, 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_config="`$as_echo "$ac_configure_args" | sed 's/^ //; s/[\\""\`\$]/\\\\&/g'`" ac_cs_version="\\ algol68g config.status 3.1.2 configured by $0, generated by GNU Autoconf 2.69, with options \\"\$ac_cs_config\\" Copyright (C) 2012 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=`expr "X$1" : 'X\([^=]*\)='` ac_optarg= 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 ;; --config | --confi | --conf | --con | --co | --c ) $as_echo "$ac_cs_config"; 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"` ;; '') as_fn_error $? "missing file argument" ;; esac as_fn_append 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 as_fn_append CONFIG_HEADERS " '$ac_optarg'" ac_need_defaults=false;; --he | --h) # Conflict between --help and --header as_fn_error $? "ambiguous option: \`$1' Try \`$0 --help' for more information.";; --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_fn_error $? "unrecognized option: \`$1' Try \`$0 --help' for more information." ;; *) as_fn_append 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" MAKE="${MAKE-make}" _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 "a68g-config.h") CONFIG_HEADERS="$CONFIG_HEADERS a68g-config.h" ;; "depfiles") CONFIG_COMMANDS="$CONFIG_COMMANDS depfiles" ;; "Makefile") CONFIG_FILES="$CONFIG_FILES Makefile" ;; *) as_fn_error $? "invalid argument: \`$ac_config_target'" "$LINENO" 5;; 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= ac_tmp= trap 'exit_status=$? : "${ac_tmp:=$tmp}" { test ! -d "$ac_tmp" || rm -fr "$ac_tmp"; } && exit $exit_status ' 0 trap 'as_fn_exit 1' 1 2 13 15 } # Create a (secure) tmp directory for tmp files. { tmp=`(umask 077 && mktemp -d "./confXXXXXX") 2>/dev/null` && test -d "$tmp" } || { tmp=./conf$$-$RANDOM (umask 077 && mkdir "$tmp") } || as_fn_error $? "cannot create a temporary directory in ." "$LINENO" 5 ac_tmp=$tmp # 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=`echo X | tr X '\015'` # On cygwin, bash can eat \r inside `` if the user requested igncr. # But we know of no other shell where ac_cr would be empty at this # point, so we can use a bashism as a fallback. if test "x$ac_cr" = x; then eval ac_cr=\$\'\\r\' fi 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 {' >"$ac_tmp/subs1.awk" && _ACEOF { echo "cat >conf$$subs.awk <<_ACEOF" && echo "$ac_subst_vars" | sed 's/.*/&!$&$ac_delim/' && echo "_ACEOF" } >conf$$subs.sh || as_fn_error $? "could not make $CONFIG_STATUS" "$LINENO" 5 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_fn_error $? "could not make $CONFIG_STATUS" "$LINENO" 5 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_fn_error $? "could not make $CONFIG_STATUS" "$LINENO" 5 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 >>"\$ac_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 >>"\$ac_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 < "$ac_tmp/subs1.awk" > "$ac_tmp/subs.awk" \ || as_fn_error $? "could not setup config files machinery" "$LINENO" 5 _ACEOF # VPATH may cause trouble with some makes, so we remove sole $(srcdir), # ${srcdir} and @srcdir@ entries 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[ ]*=[ ]*/{ h s/// s/^/:/ s/[ ]*$/:/ s/:\$(srcdir):/:/g s/:\${srcdir}:/:/g s/:@srcdir@:/:/g s/^:*// s/:*$// x s/\(=[ ]*\).*/\1/ G s/\n// 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 >"$ac_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_tt=`sed -n "/$ac_delim/p" confdefs.h` if test -z "$ac_tt"; then break elif $ac_last_try; then as_fn_error $? "could not make $CONFIG_HEADERS" "$LINENO" 5 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_fn_error $? "could not setup config headers machinery" "$LINENO" 5 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_fn_error $? "invalid tag \`$ac_tag'" "$LINENO" 5;; :[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="$ac_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_fn_error 1 "cannot find input file: \`$ac_f'" "$LINENO" 5;; esac case $ac_f in *\'*) ac_f=`$as_echo "$ac_f" | sed "s/'/'\\\\\\\\''/g"`;; esac as_fn_append 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:${as_lineno-$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 >"$ac_tmp/stdin" \ || as_fn_error $? "could not create $ac_file" "$LINENO" 5 ;; 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"; as_fn_mkdir_p 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:${as_lineno-$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 "$ac_tmp/subs.awk" \ >$ac_tmp/out || as_fn_error $? "could not create $ac_file" "$LINENO" 5 test -z "$ac_datarootdir_hack$ac_datarootdir_seen" && { ac_out=`sed -n '/\${datarootdir}/p' "$ac_tmp/out"`; test -n "$ac_out"; } && { ac_out=`sed -n '/^[ ]*datarootdir[ ]*:*=/p' \ "$ac_tmp/out"`; test -z "$ac_out"; } && { $as_echo "$as_me:${as_lineno-$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 "$ac_tmp/stdin" case $ac_file in -) cat "$ac_tmp/out" && rm -f "$ac_tmp/out";; *) rm -f "$ac_file" && mv "$ac_tmp/out" "$ac_file";; esac \ || as_fn_error $? "could not create $ac_file" "$LINENO" 5 ;; :H) # # CONFIG_HEADER # if test x"$ac_file" != x-; then { $as_echo "/* $configure_input */" \ && eval '$AWK -f "$ac_tmp/defines.awk"' "$ac_file_inputs" } >"$ac_tmp/config.h" \ || as_fn_error $? "could not create $ac_file" "$LINENO" 5 if diff "$ac_file" "$ac_tmp/config.h" >/dev/null 2>&1; then { $as_echo "$as_me:${as_lineno-$LINENO}: $ac_file is unchanged" >&5 $as_echo "$as_me: $ac_file is unchanged" >&6;} else rm -f "$ac_file" mv "$ac_tmp/config.h" "$ac_file" \ || as_fn_error $? "could not create $ac_file" "$LINENO" 5 fi else $as_echo "/* $configure_input */" \ && eval '$AWK -f "$ac_tmp/defines.awk"' "$ac_file_inputs" \ || as_fn_error $? "could not create -" "$LINENO" 5 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:${as_lineno-$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"" || { # Older Autoconf quotes --file arguments for eval, but not when files # are listed without --file. Let's play safe and only enable the eval # if we detect the quoting. # TODO: see whether this extra hack can be removed once we start # requiring Autoconf 2.70 or later. case $CONFIG_FILES in #( *\'*) : eval set x "$CONFIG_FILES" ;; #( *) : set x $CONFIG_FILES ;; #( *) : ;; esac shift # Used to flag and report bootstrapping failures. am_rc=0 for am_mf do # Strip MF so we end up with the name of the file. am_mf=`$as_echo "$am_mf" | sed -e 's/:.*$//'` # Check whether this is an Automake generated Makefile which includes # dependency-tracking related rules and includes. # Grep'ing the whole file directly is not great: AIX grep has a line # limit of 2048, but all sed's we know have understand at least 4000. sed -n 's,^am--depfiles:.*,X,p' "$am_mf" | grep X >/dev/null 2>&1 \ || continue am_dirpart=`$as_dirname -- "$am_mf" || $as_expr X"$am_mf" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ X"$am_mf" : 'X\(//\)[^/]' \| \ X"$am_mf" : 'X\(//\)$' \| \ X"$am_mf" : 'X\(/\)' \| . 2>/dev/null || $as_echo X"$am_mf" | sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ s//\1/ q } /^X\(\/\/\)[^/].*/{ s//\1/ q } /^X\(\/\/\)$/{ s//\1/ q } /^X\(\/\).*/{ s//\1/ q } s/.*/./; q'` am_filepart=`$as_basename -- "$am_mf" || $as_expr X/"$am_mf" : '.*/\([^/][^/]*\)/*$' \| \ X"$am_mf" : 'X\(//\)$' \| \ X"$am_mf" : 'X\(/\)' \| . 2>/dev/null || $as_echo X/"$am_mf" | sed '/^.*\/\([^/][^/]*\)\/*$/{ s//\1/ q } /^X\/\(\/\/\)$/{ s//\1/ q } /^X\/\(\/\).*/{ s//\1/ q } s/.*/./; q'` { echo "$as_me:$LINENO: cd "$am_dirpart" \ && sed -e '/# am--include-marker/d' "$am_filepart" \ | $MAKE -f - am--depfiles" >&5 (cd "$am_dirpart" \ && sed -e '/# am--include-marker/d' "$am_filepart" \ | $MAKE -f - am--depfiles) >&5 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } || am_rc=$? done if test $am_rc -ne 0; then { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error $? "Something went wrong bootstrapping makefile fragments for automatic dependency tracking. If GNU make was not used, consider re-running the configure script with MAKE=\"gmake\" (or whatever is necessary). You can also try re-running configure with the '--disable-dependency-tracking' option to at least be able to build the package (albeit without support for automatic dependency tracking). See \`config.log' for more details" "$LINENO" 5; } fi { am_dirpart=; unset am_dirpart;} { am_filepart=; unset am_filepart;} { am_mf=; unset am_mf;} { am_rc=; unset am_rc;} rm -f conftest-deps.mk } ;; esac done # for ac_tag as_fn_exit 0 _ACEOF ac_clean_files=$ac_clean_files_save test $ac_write_fail = 0 || as_fn_error $? "write failure creating $CONFIG_STATUS" "$LINENO" 5 # 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 || as_fn_exit 1 fi if test -n "$ac_unrecognized_opts" && test "$enable_option_checking" != no; then { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: unrecognized options: $ac_unrecognized_opts" >&5 $as_echo "$as_me: WARNING: unrecognized options: $ac_unrecognized_opts" >&2;} fi { $as_echo "$as_me:${as_lineno-$LINENO}: " >&5 $as_echo "$as_me: " >&6;} { $as_echo "$as_me:${as_lineno-$LINENO}: algol68g-3.1.2 by Marcel van der Veer " >&5 $as_echo "$as_me: algol68g-3.1.2 by Marcel van der Veer " >&6;} if test "x$a68g_exists" = "xyes"; then { $as_echo "$as_me:${as_lineno-$LINENO}: algol68g already exists on this system" >&5 $as_echo "$as_me: algol68g already exists on this system" >&6;} fi { $as_echo "$as_me:${as_lineno-$LINENO}: " >&5 $as_echo "$as_me: " >&6;} if test "x$enable_quadmath" = "xyes"; then if test "x$enable_long_types" = "xyes"; then { $as_echo "$as_me:${as_lineno-$LINENO}: building with hardware support for long modes" >&5 $as_echo "$as_me: building with hardware support for long modes" >&6;} { $as_echo "$as_me:${as_lineno-$LINENO}: building with quadmath" >&5 $as_echo "$as_me: building with quadmath" >&6;} fi fi if test "x$enable_parallel" = "xyes"; then { $as_echo "$as_me:${as_lineno-$LINENO}: building with parallel clause" >&5 $as_echo "$as_me: building with parallel clause" >&6;} fi if test "x$enable_mpfr" = "xyes"; then { $as_echo "$as_me:${as_lineno-$LINENO}: building with GNU MPFR" >&5 $as_echo "$as_me: building with GNU MPFR" >&6;} fi if test "x$enable_mpfr" = "xno"; then if test "x$GCC" = "xyes"; then { $as_echo "$as_me:${as_lineno-$LINENO}: GNU MPFR found but not used" >&5 $as_echo "$as_me: GNU MPFR found but not used" >&6;} fi fi if test "x$enable_mathlib" = "xyes"; then { $as_echo "$as_me:${as_lineno-$LINENO}: building with R mathlib" >&5 $as_echo "$as_me: building with R mathlib" >&6;} fi if test "x$enable_gsl" = "xyes"; then { $as_echo "$as_me:${as_lineno-$LINENO}: building with GNU Scientific Library" >&5 $as_echo "$as_me: building with GNU Scientific Library" >&6;} fi if test "x$enable_curses" = "xyes"; then { $as_echo "$as_me:${as_lineno-$LINENO}: building with curses" >&5 $as_echo "$as_me: building with curses" >&6;} fi if test "x$enable_plotutils" = "xyes"; then { $as_echo "$as_me:${as_lineno-$LINENO}: building with GNU plotutils" >&5 $as_echo "$as_me: building with GNU plotutils" >&6;} fi if test "x$enable_postgresql" = "xyes"; then { $as_echo "$as_me:${as_lineno-$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:${as_lineno-$LINENO}: building compiler-interpreter" >&5 $as_echo "$as_me: building compiler-interpreter" >&6;} else { $as_echo "$as_me:${as_lineno-$LINENO}: building interpreter-only" >&5 $as_echo "$as_me: building interpreter-only" >&6;} fi { $as_echo "$as_me:${as_lineno-$LINENO}: " >&5 $as_echo "$as_me: " >&6;} if test "x$GCC" = "xyes"; then if test "x$enable_quadmath" = "xno"; then { $as_echo "$as_me:${as_lineno-$LINENO}: consider installing libquadmath-devel and reconfiguring" >&5 $as_echo "$as_me: consider installing libquadmath-devel and reconfiguring" >&6;} fi fi { $as_echo "$as_me:${as_lineno-$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-3.1.2/AUTHORS0000644000175000017500000000013314361065322011130 00000000000000Author and copyright holder of Algol 68 Genie is Marcel van der Veer . algol68g-3.1.2/configure.ac0000644000175000017500000007117514361065446012373 00000000000000# # Algol 68 Genie 3.1.2, configure.ac # # To configure a68g for the widest range of platforms, issue: # ./configure --enable-generic # # Following optional libraries are suggested for a full build on debian or derived linux distributions (Ubuntu, Raspberry Pi): # sudo apt install libncurses-dev libreadline-dev libmpfr libgmp libgsl-dev r-mathlib libplot-dev libghc-postgresql-libpq-dev # AC_INIT([algol68g], [3.1.2], [Marcel van der Veer ]) 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)]) ]) # Configure path for the GNU Scientific Library # Christopher R. Gabriel , April 2000 AC_DEFUN([AX_PATH_GSL], [ AC_ARG_WITH(gsl-prefix,[ --with-gsl-prefix=PFX Prefix where GSL is installed (optional)], gsl_prefix="$withval", gsl_prefix="") AC_ARG_WITH(gsl-exec-prefix,[ --with-gsl-exec-prefix=PFX Exec prefix where GSL is installed (optional)], gsl_exec_prefix="$withval", gsl_exec_prefix="") AC_ARG_ENABLE(gsltest, [ --disable-gsltest Do not try to compile and run a test GSL program], , enable_gsltest=yes) if test "x${GSL_CONFIG+set}" != xset ; then if test "x$gsl_prefix" != x ; then GSL_CONFIG="$gsl_prefix/bin/gsl-config" fi if test "x$gsl_exec_prefix" != x ; then GSL_CONFIG="$gsl_exec_prefix/bin/gsl-config" fi fi AC_PATH_PROG(GSL_CONFIG, gsl-config, no) min_gsl_version=ifelse([$1], ,2.5,$1) AC_MSG_CHECKING(for GSL version >= $min_gsl_version) no_gsl="" if test "$GSL_CONFIG" = "no" ; then no_gsl=yes else GSL_CFLAGS=`$GSL_CONFIG --cflags` GSL_LIBS=`$GSL_CONFIG --libs` gsl_major_version=`$GSL_CONFIG --version | \ sed 's/^\([[0-9]]*\).*/\1/'` if test "x${gsl_major_version}" = "x" ; then gsl_major_version=0 fi gsl_minor_version=`$GSL_CONFIG --version | \ sed 's/^\([[0-9]]*\)\.\{0,1\}\([[0-9]]*\).*/\2/'` if test "x${gsl_minor_version}" = "x" ; then gsl_minor_version=0 fi gsl_micro_version=`$GSL_CONFIG --version | \ sed 's/^\([[0-9]]*\)\.\{0,1\}\([[0-9]]*\)\.\{0,1\}\([[0-9]]*\).*/\3/'` if test "x${gsl_micro_version}" = "x" ; then gsl_micro_version=0 fi if test "x$enable_gsltest" = "xyes" ; then ac_save_CFLAGS="$CFLAGS" ac_save_LIBS="$LIBS" CFLAGS="$CFLAGS $GSL_CFLAGS" LIBS="$LIBS $GSL_LIBS" rm -f conf.gsltest AC_TRY_RUN([ #include #include #include char* my_strdup (const char *str); char* my_strdup (const char *str) { char *new_str; if (str) { new_str = (char *)malloc ((strlen (str) + 1) * sizeof(char)); strcpy (new_str, str); } else new_str = NULL; return new_str; } int main (void) { int major = 0, minor = 0, micro = 0; int n; char *tmp_version; system ("touch conf.gsltest"); /* HP/UX 9 (%@#!) writes to sscanf strings */ tmp_version = my_strdup("$min_gsl_version"); n = sscanf(tmp_version, "%d.%d.%d", &major, &minor, µ) ; if (n != 2 && n != 3) { printf("%s, bad version string\n", "$min_gsl_version"); exit(1); } if (($gsl_major_version > major) || (($gsl_major_version == major) && ($gsl_minor_version > minor)) || (($gsl_major_version == major) && ($gsl_minor_version == minor) && ($gsl_micro_version >= micro))) { exit(0); } else { exit(1); } } ],, no_gsl=yes,[echo $ac_n "cross compiling; assumed OK... $ac_c"]) CFLAGS="$ac_save_CFLAGS" LIBS="$ac_save_LIBS" fi fi if test "x$no_gsl" = x ; then AC_MSG_RESULT(yes) ifelse([$2], , :, [$2]) else AC_MSG_RESULT(no) if test "$GSL_CONFIG" = "no" ; then echo "*** The gsl-config script installed by GSL could not be found" echo "*** If GSL was installed in PREFIX, make sure PREFIX/bin is in" echo "*** your path, or set the GSL_CONFIG environment variable to the" echo "*** full path to gsl-config." else if test -f conf.gsltest ; then : else echo "*** Could not run GSL test program, checking why..." CFLAGS="$CFLAGS $GSL_CFLAGS" LIBS="$LIBS $GSL_LIBS" AC_TRY_LINK([ #include ], [ return 0; ], [ echo "*** The test program compiled, but did not run. This usually means" echo "*** that the run-time linker is not finding GSL or finding the wrong" echo "*** version of GSL. If it is not finding GSL, you'll need to set your" echo "*** LD_LIBRARY_PATH environment variable, or edit /etc/ld.so.conf to point" echo "*** to the installed location Also, make sure you have run ldconfig if that" echo "*** is required on your system" echo "***" echo "*** If you have an old version installed, it is best to remove it, although" echo "*** you may also be able to get things to work by modifying LD_LIBRARY_PATH"], [ echo "*** The test program failed to compile or link. See the file config.log for the" echo "*** exact error that occured. This usually means GSL was incorrectly installed" echo "*** or that you have moved GSL since it was installed. In the latter case, you" echo "*** may want to edit the gsl-config script: $GSL_CONFIG" ]) CFLAGS="$ac_save_CFLAGS" LIBS="$ac_save_LIBS" fi fi # GSL_CFLAGS="" # GSL_LIBS="" ifelse([$3], , :, [$3]) fi AC_SUBST(GSL_CFLAGS) AC_SUBST(GSL_LIBS) rm -f conf.gsltest ]) AU_ALIAS([AM_PATH_GSL], [AX_PATH_GSL]) # # Platform ids. # AC_MSG_NOTICE([host system...]) AC_CANONICAL_BUILD AC_CANONICAL_HOST AC_CANONICAL_TARGET bsd_include_dirs=no enable_haiku=no AC_MSG_CHECKING([platform]) case "$host" in # # Linux. # # aarch64*-*-linux* is for RaspberryPi-4 on ARM-64 - otherwise http/tcp isnt found # Generic *-*-linux-gnu catches for instance s390x-ibm-linux-gnu # *86-*-gnu | *86_64-*-gnu | *86-*-linux* | *86_64-*-linux* | arm*-*-linux* | aarch*-*-linux* | *-*-linux-gnu) AC_DEFINE(BUILD_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(BUILD_CYGWIN, 1, [Define this if CYGWIN was detected]) 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(BUILD_BSD, 1, [Define this if DARWIN was detected]) AC_DEFINE(HAVE_IEEE_754, 1, [Define this if IEEE_754 compliant]) AC_MSG_WARN([configuring interpreter-only]) AC_MSG_RESULT([mac os x]) ;; # # FreeBSD. # *86-*-freebsd* | *86_64-*-freebsd*) AC_DEFINE(BUILD_BSD, 1, [Define this if FreeBSD was detected]) AC_DEFINE(HAVE_IEEE_754, 1, [Define this if IEEE_754 compliant]) AC_MSG_WARN([configuring interpreter-only]) AC_MSG_RESULT([freebsd]) ;; # # NetBSD. # *86-*-netbsd* | *86_64-*-netbsd*) AC_DEFINE(BUILD_BSD, 1, [Define this if NetBSD was detected]) AC_DEFINE(HAVE_IEEE_754, 1, [Define this if IEEE_754 compliant]) AC_MSG_WARN([configuring interpreter-only]) AC_MSG_RESULT([netbsd]) ;; # # OpenBSD. # *86-*-openbsd* | *86_64-*-openbsd*) AC_DEFINE(BUILD_BSD, 1, [Define this if OpenBSD was detected]) AC_DEFINE(HAVE_IEEE_754, 1, [Define this if IEEE_754 compliant]) bsd_include_dirs=yes AC_MSG_RESULT([openbsd]) ;; # # Haiku. # *86-*-haiku* | *86_64-*-haiku*) AC_DEFINE(BUILD_HAIKU, 1, [Define this if HAIKU was detected]) AC_DEFINE(HAVE_IEEE_754, 1, [Define this if IEEE_754 compliant]) AC_MSG_RESULT([haiku]) ;; # # 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(generic, [AS_HELP_STRING([--enable-generic], [build for legacy 32 bit systems (default is "no")])], , enable_generic=no) AC_ARG_ENABLE(compiler, [AS_HELP_STRING([--enable-compiler], [enable unit compiler (default is "yes")])], , enable_compiler=yes) AC_ARG_ENABLE(quadmath, [AS_HELP_STRING([--enable-quadmath], [if available, enable GCC quadmath library (default is "yes")])], , enable_quadmath=yes) AC_ARG_ENABLE(mathlib, [AS_HELP_STRING([--enable-mathlib], [if available, enable R mathlib library (default is "yes")])], , enable_mathlib=yes) AC_ARG_ENABLE(curses, [AS_HELP_STRING([--enable-curses], [if available, enable curses library (default is "yes")])], , enable_curses=yes) AC_ARG_ENABLE(gsl, [AS_HELP_STRING([--enable-gsl], [if available, enable GNU scientific library (default is "yes")])], , enable_gsl=yes) AC_ARG_ENABLE(mpfr, [AS_HELP_STRING([--enable-mpfr], [if available, enable GNU MPFR (default is "yes")])], , enable_mpfr=yes) AC_ARG_ENABLE(parallel, [AS_HELP_STRING([--enable-parallel], [enable Algol 68 parallel-clause (default is "yes")])], , enable_parallel=yes) AC_ARG_ENABLE(plotutils, [AS_HELP_STRING([--enable-plotutils], [if available, enable GNU plotting utilities (default is "yes")])], , enable_plotutils=yes) AC_ARG_ENABLE(postgresql, [AS_HELP_STRING([--enable-postgresql], [if available, enable PostgreSQL (default is "yes")])], , enable_postgresql=yes) AC_ARG_ENABLE(readline, [AS_HELP_STRING([--enable-readline], [if available, enable readline library (default is "yes")])], , enable_readline=yes) AC_ARG_ENABLE(standard-types, [AS_HELP_STRING([--enable-standard-types], [enable int*4 and real*8 modes (default is "yes")])], , enable_standard_types=yes) AC_ARG_ENABLE(long-types, [AS_HELP_STRING([--enable-long-types], [if available, enable int*8 and real*10, real*16 modes (default is "yes")])], , enable_long_types=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(arch, [AS_HELP_STRING([--enable-arch=cpu], [if using gcc, enable emitting architecture-tuned assembly code (default is "no")])], , enable_arch=no) if test "x$enable_generic" = "xyes"; then enable_standard_types=yes enable_long_types=no fi # # Initialisation. # AC_MSG_NOTICE([initialising...]) AM_INIT_AUTOMAKE([subdir-objects serial-tests]) AC_PREFIX_DEFAULT(/usr/local) AC_CONFIG_SRCDIR([src/include/a68g.h]) AC_CONFIG_HEADERS([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([gcc clang]) # AC_PROG_CC([clang]) 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]) AC_DEFINE_UNQUOTED(C_COMPILER, "$CC", [Name of C compiler detected]) # On rhel8 "rpmbuild" sneaks in -pie and -fPIE, so a68g also needs to pass through. # On Suse15 the header files for pgsql and R have their own directories. COPTFLAGS="-g -O2 -Wall -I /usr/include/pgsql -I /usr/lib64/R/include" LDOPTFLAG="-L /usr/lib64/R/lib" # from /usr/lib/rpm/redhat/macros CFLAGS="${CFLAGS:-$COPTFLAGS}" ; export CFLAGS LDFLAGS="${LDFLAGS:-$LDOPTFLAGS}" ; export LDFLAGS A68G_AC_PROG_CC_CFLAGS([-Wall]) A68G_AC_PROG_CC_CFLAGS([-Wshadow]) A68G_AC_PROG_CC_CFLAGS([-Wunused-variable]) A68G_AC_PROG_CC_CFLAGS([-Wunused-parameter]) A68G_AC_PROG_CC_CFLAGS([-Wno-long-long]) A68G_AC_PROG_CC_CFLAGS([-fno-diagnostics-color]) # # Test on gcc capabilities. # AC_MSG_CHECKING([__attribute__((aligned())) supported]) AC_RUN_IFELSE([AC_LANG_PROGRAM([], [typedef int aint __attribute__((aligned(8)));])], [AC_MSG_RESULT(yes)], [AC_MSG_RESULT(no) AC_MSG_FAILURE([stop -- C compiler does not support __attribute__aligned directive])], []) AC_C_INLINE() # # Set -I/usr/local/include for *BSD # if test "x$bsd_include_dirs" = "xyes"; then AC_DEFINE(INCLUDE_DIR, "-I/usr/local/include", [Platform dependent]) else AC_DEFINE(INCLUDE_DIR, "", [Platform dependent]) fi # # 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_CC_C99 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( [AC_LANG_SOURCE([ #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( [AC_LANG_SOURCE[ #include #include __pid_t dummy; ])], [AC_MSG_RESULT([__pid_t]) AC_DEFINE(a68_pid_t, __pid_t, [Define this if we have __pid_t])], [AC_MSG_RESULT([pid_t]) AC_DEFINE(a68_pid_t, pid_t, [Define this if we have no __pid_t])] ) AC_MSG_CHECKING([__mode_t or mode_t]) AC_COMPILE_IFELSE( [AC_LANG_SOURCE([ #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...]) # GSL on OpenBSD if test -d /usr/local/include/gsl; then CFLAGS="$CFLAGS -I/usr/local/include" CPPFLAGS="$CPPFLAGS -I/usr/local/include" CXXFLAGS="$CXXFLAGS -I/usr/local/include" LDFLAGS="$LDFLAGS -L/usr/local/lib" fi # R on Debian # # if test -d /usr/share/R/include; then # AC_DEFINE(HAVE_USR_SHARE_R_INCLUDE, 1, [Define this if /usr/share/R/include was detected]) # CFLAGS="$CFLAGS -I/usr/share/R/include" # CPPFLAGS="$CPPFLAGS -I/usr/share/R/include" # CXXFLAGS="$CXXFLAGS -I/usr/share/R/include" # LDFLAGS="$LDFLAGS -L/usr/share/R/lib" # fi # Postgresql 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 if test -d /usr/include/postgresql; then AC_DEFINE(HAVE_USR_INCLUDE_POSTGRESQL, 1, [Define this if /usr/include/postgresql was detected]) CFLAGS="$CFLAGS -I/usr/include/postgresql" CPPFLAGS="$CPPFLAGS -I/usr/include/postgresql" CXXFLAGS="$CXXFLAGS -I/usr/include/postgresql" LDFLAGS="$LDFLAGS -L/usr/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 complex.h ctype.h errno.h fcntl.h fenv.h float.h limits.h netdb.h netinet/in.h regex.h setjmp.h signal.h stdarg.h stddef.h stdio.h stdlib.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(posix_memalign) AC_CHECK_FUNCS(aligned_alloc) AC_CHECK_FUNCS(malloc) AC_CHECK_FUNCS(free) AC_CHECK_FUNCS(setjmp) AC_CHECK_FUNCS(longjmp) AC_CHECK_FUNCS(memcpy) AC_CHECK_FUNCS(memmove) AC_CHECK_FUNCS(memset) AC_CHECK_FUNCS(strcmp) AC_CHECK_FUNCS(strncmp) AC_CHECK_FUNCS(strncpy) AC_CHECK_FUNCS(printf) AC_CHECK_FUNCS(fprintf) AC_CHECK_FUNCS(snprintf) AC_CHECK_FUNCS(signal) AC_CHECK_FUNCS(exit) AC_CHECK_FUNCS(sqrt) AC_CHECK_FUNCS(csqrt) # # Checks for functions / macros. # AC_MSG_CHECKING([for isfinite]) AC_COMPILE_IFELSE( [AC_LANG_PROGRAM([#include ], [int a = isfinite(0.0)])], [AC_MSG_RESULT(yes) AC_DEFINE(HAVE_ISFINITE, 1, [Define if isfinite() is available])], [AC_MSG_RESULT(no)] ) AC_MSG_CHECKING([for finite]) AC_COMPILE_IFELSE( [AC_LANG_PROGRAM([#include ], [int a = finite(0.0)])], [AC_MSG_RESULT(yes) AC_DEFINE(HAVE_FINITE, 1, [Define if finite() is available])], [AC_MSG_RESULT(no)] ) AC_MSG_CHECKING([for isinf]) AC_COMPILE_IFELSE( [AC_LANG_PROGRAM([#include ], [int a = isinf(0.0)])], [AC_MSG_RESULT(yes) AC_DEFINE(HAVE_ISINF, 1, [Define if isinf() is available])], [AC_MSG_RESULT(no)] ) AC_MSG_CHECKING([for isnan]) AC_COMPILE_IFELSE( [AC_LANG_PROGRAM([#include ], [int a = isnan(0.0)])], [AC_MSG_RESULT(yes) AC_DEFINE(HAVE_ISNAN, 1, [Define if isnan() is available])], [AC_MSG_RESULT(no)] ) AC_MSG_NOTICE([optional headers and libraries...]) if test "x$enable_standard_types" = "xyes"; then AC_MSG_CHECKING([int is 32 bit]) AC_RUN_IFELSE([AC_LANG_PROGRAM([], [return sizeof (int) != 4;])], [AC_MSG_RESULT(yes)], [AC_MSG_RESULT(no) enable_long_types=no], []) AC_MSG_CHECKING([unsigned is 32 bit]) AC_RUN_IFELSE([AC_LANG_PROGRAM([], [return sizeof (unsigned) != 4;])], [AC_MSG_RESULT(yes)], [AC_MSG_RESULT(no) enable_long_types=no], []) AC_MSG_CHECKING([double is 64 bit]) AC_RUN_IFELSE([AC_LANG_PROGRAM([], [return sizeof (double) != 8;])], [AC_MSG_RESULT(yes)], [AC_MSG_RESULT(no) enable_long_types=no], []) AC_MSG_CHECKING([uint64_t is 64 bit]) AC_RUN_IFELSE([AC_LANG_PROGRAM([#include ], [return sizeof (uint64_t) != 8;])], [AC_MSG_RESULT(yes)], [AC_MSG_RESULT(no) enable_standard_types=no enable_long_types=no], []) fi if test "x$enable_standard_types" = "xno"; then AC_MSG_FAILURE([stop -- unexpected lengths for int and/or double and/or uint64_t]) fi if test "x$enable_long_types" = "xyes"; then AC_MSG_CHECKING([64-bit long long int is available]) AC_RUN_IFELSE([AC_LANG_PROGRAM([], [return sizeof (long long) != 8;])], [AC_MSG_RESULT(yes)], [AC_MSG_RESULT(no) enable_long_types=no], []) AC_MSG_CHECKING([64-bit long long unsigned is available]) AC_RUN_IFELSE([AC_LANG_PROGRAM([], [return sizeof (long long unsigned) != 8;])], [AC_MSG_RESULT(yes)], [AC_MSG_RESULT(no) enable_long_types=no], []) AC_MSG_CHECKING([80-bit __float80 is available]) AC_RUN_IFELSE([AC_LANG_PROGRAM([], [return sizeof (__float80) != 16;])], [AC_MSG_RESULT(yes)], [AC_MSG_RESULT(no) enable_long_types=no], []) AC_MSG_CHECKING([80-bit __float80 has 64-bit mantissa]) AC_RUN_IFELSE([AC_LANG_PROGRAM([#include ], [return LDBL_MANT_DIG != 64;])], [AC_MSG_RESULT(yes)], [AC_MSG_RESULT(no) enable_long_types=no], []) AC_MSG_CHECKING([128-bit __float128 is available]) AC_RUN_IFELSE([AC_LANG_PROGRAM([], [return sizeof (__float128) != 16;])], [AC_MSG_RESULT(yes)], [AC_MSG_RESULT(no) enable_long_types=no], []) if test "x$enable_long_types" = "xyes"; then AC_DEFINE(HAVE_LONG_TYPES, 1, [Define this if a good INT*8/REAL*10/REAL*16 installation was detected]) fi fi if test "x$enable_long_types" = "xyes"; then if test "x$enable_quadmath" = "xyes"; then AC_MSG_NOTICE([quadmath...]) AC_CHECK_HEADERS([quadmath.h], [], [enable_quadmath=no], []) AC_CHECK_LIB([quadmath], [lgammaq], [], [enable_quadmath=no]) if test "x$enable_quadmath" = "xyes"; then AC_DEFINE(HAVE_QUADMATH, 1, [Define this if a good quadmath installation was detected]) fi fi else AC_MSG_NOTICE([quadmath ignored for this system]) enable_quadmath=no fi if test "x$enable_long_types" = "xyes"; then if test "x$enable_mpfr" = "xyes"; then AC_MSG_NOTICE([GNU MPFR...]) AC_CHECK_LIB([gmp], [__gmpz_init], [], [enable_mpfr=no]) if test "x$enable_mpfr" = "xyes"; then AC_CHECK_HEADERS([mpfr.h]) if test "x$enable_mpfr" = "xyes"; then AC_CHECK_LIB([mpfr], [mpfr_gamma], [], [enable_mpfr=no]) AC_CHECK_LIB([mpfr], [mpfr_gamma_inc], [], [enable_mpfr=no]) AC_CHECK_LIB([mpfr], [mpfr_get_float128], [], [enable_mpfr=no]) AC_CHECK_LIB([mpfr], [mpfr_set_float128], [], [enable_mpfr=no]) if test "x$enable_mpfr" = "xyes"; then AC_DEFINE(HAVE_GNU_MPFR, 1, [Define this if a recent GNU MPFR installation was detected]) fi fi fi fi else AC_MSG_NOTICE([GNU MPFR ignored for this system]) enable_mpfr=no fi if test "x$enable_parallel" = "xyes"; then AC_MSG_NOTICE([POSIX pthreads...]) AC_CHECK_HEADERS([pthread.h], [], [enable_parallel=no], []) AC_CHECK_LIB([pthread], [pthread_attr_getstacksize], [], [enable_parallel=no]) if test "x$enable_parallel" = "xyes"; then AC_DEFINE(BUILD_PARALLEL_CLAUSE, 1, [Define this if a good pthread installation was detected]) fi fi if test "x$enable_mathlib" = "xyes"; then AC_MSG_NOTICE([mathlib...]) AC_CHECK_HEADERS([Rmath.h], [], [enable_mathlib=no], [#define MATHLIB_STANDALONE #include ]) AC_CHECK_LIB([Rmath], [ptukey], [], [enable_mathlib=no]) if test "x$enable_mathlib" = "xyes"; then AC_DEFINE(HAVE_MATHLIB, 1, [Define this if a good mathlib installation was detected]) fi fi if test "x$enable_gsl" = "xyes"; then AC_MSG_NOTICE([GNU Scientific Library...]) AX_PATH_GSL(2.5, [enable_gsl=yes], [enable_gsl=no]) if test "x$enable_gsl" = "xyes"; then AC_CHECK_LIB([gslcblas], [cblas_dgemm], [], [enable_gsl=no]) AC_CHECK_LIB([gsl], [gsl_blas_ddot], [], [enable_gsl=no]) 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 gsl/gsl_version.h], [], [enable_gsl=no], []) fi if test "x$enable_gsl" = "xyes"; then AC_DEFINE(HAVE_GSL, 1, [Define this if a good GNU GSL installation was detected]) fi fi if test "x$enable_plotutils" = "xyes"; then AC_MSG_NOTICE([GNU plotutils...]) AC_CHECK_HEADERS([plot.h], [], [enable_plotutils=no], []) AC_CHECK_LIB([plot], [pl_alabel_r], [], [enable_plotutils=no]) if test "x$enable_plotutils" = "xyes"; then AC_DEFINE(HAVE_GNU_PLOTUTILS, 1, [Define this if a good GNU plotutils installation was detected]) fi fi if test "x$enable_curses" = "xyes"; then AC_MSG_NOTICE([curses...]) 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([tinfo], [stdscr], [], [enable_curses=no]) AC_CHECK_LIB([tic], [stdscr], [], [enable_curses=no]) 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_postgresql" = "xyes"; then AC_MSG_NOTICE([PostgreSQL...]) AC_CHECK_HEADERS([libpq-fe.h], [], [enable_postgresql=no], []) AC_CHECK_LIB([pq], [PQbackendPID], [], [enable_postgresql=no]) if test "x$enable_postgresql" = "xyes"; then AC_DEFINE(HAVE_POSTGRESQL, 1, [Define this if a good PostgreSQL installation was detected]) fi fi if test "x$enable_compiler" = "xyes"; then libdl_found=no AC_MSG_NOTICE([Dynamic loader via libdl...]) AC_CHECK_HEADERS([dlfcn.h]) AC_SEARCH_LIBS([dlopen], [dl], [], enable_compiler=no) if test "x$enable_compiler" = "xyes"; then AC_DEFINE(HAVE_DL, 1, [Define this if a good DL installation was detected]) libdl_found=yes fi fi # Are we on Haiku? if test "x$enable_compiler" = "xyes"; then if test "x$libdl_found" = "xno"; then AC_MSG_NOTICE([Dynamic loader via libroot...]) AC_CHECK_HEADERS([dlfcn.h]) AC_CHECK_LIB([root], [dlopen], [], enable_compiler=no) if test "x$enable_compiler" = "xyes"; then AC_DEFINE(HAVE_DL, 1, [Define this if a good DL installation was detected]) fi 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 AC_MSG_NOTICE([]) if test "x$enable_quadmath" = "xyes"; then if test "x$enable_long_types" = "xyes"; then AC_MSG_NOTICE([building with hardware support for long modes]) AC_MSG_NOTICE([building with quadmath]) fi fi if test "x$enable_parallel" = "xyes"; then AC_MSG_NOTICE([building with parallel clause]) fi if test "x$enable_mpfr" = "xyes"; then AC_MSG_NOTICE([building with GNU MPFR]) fi if test "x$enable_mpfr" = "xno"; then if test "x$GCC" = "xyes"; then AC_MSG_NOTICE([GNU MPFR found but not used]) fi fi if test "x$enable_mathlib" = "xyes"; then AC_MSG_NOTICE([building with R mathlib]) fi if test "x$enable_gsl" = "xyes"; then AC_MSG_NOTICE([building with GNU Scientific Library]) fi if test "x$enable_curses" = "xyes"; then AC_MSG_NOTICE([building with curses]) fi if test "x$enable_plotutils" = "xyes"; then AC_MSG_NOTICE([building with GNU plotutils]) 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([]) if test "x$GCC" = "xyes"; then if test "x$enable_quadmath" = "xno"; then AC_MSG_NOTICE([consider installing libquadmath-devel and reconfiguring]) fi fi AC_MSG_NOTICE([now type 'make' optionally followed by 'make check' or 'make install']) algol68g-3.1.2/a68g-config.h0000644000175000017500000003054414361065305012253 00000000000000/* a68g-config.h. Generated from a68g-config.h.in by configure. */ /* a68g-config.h.in. Generated from configure.ac by autoheader. */ /* Define this if OpenBSD was detected */ /* #undef BUILD_BSD */ /* Define this if CYGWIN was detected */ /* #undef BUILD_CYGWIN */ /* Define this if HAIKU was detected */ /* #undef BUILD_HAIKU */ /* Define this if LINUX was detected */ #define BUILD_LINUX 1 /* Define this if a good pthread installation was detected */ #define BUILD_PARALLEL_CLAUSE 1 /* Name of C compiler detected */ #define C_COMPILER "gcc" /* Define to 1 if `TIOCGWINSZ' requires . */ #define GWINSZ_IN_SYS_IOCTL 1 /* Define to 1 if you have the `aligned_alloc' function. */ #define HAVE_ALIGNED_ALLOC 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_COMPLEX_H 1 /* Define to 1 if you have the `csqrt' function. */ #define HAVE_CSQRT 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_FENV_H 1 /* Define if finite() is available */ #define HAVE_FINITE 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 GCC was detected */ #define HAVE_GCC 1 /* Define this if a recent GNU MPFR installation was detected */ #define HAVE_GNU_MPFR 1 /* Define this if a good GNU plotutils installation was detected */ #define HAVE_GNU_PLOTUTILS 1 /* Define this if a good GNU GSL installation was detected */ #define HAVE_GSL 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 to 1 if you have the header file. */ #define HAVE_GSL_GSL_VERSION_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 if isfinite() is available */ #define HAVE_ISFINITE 1 /* Define if isinf() is available */ #define HAVE_ISINF 1 /* Define if isnan() is available */ #define HAVE_ISNAN 1 /* Define to 1 if you have the `gmp' library (-lgmp). */ #define HAVE_LIBGMP 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 `mpfr' library (-lmpfr). */ #define HAVE_LIBMPFR 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 `quadmath' library (-lquadmath). */ #define HAVE_LIBQUADMATH 1 /* Define to 1 if you have the `readline' library (-lreadline). */ #define HAVE_LIBREADLINE 1 /* Define to 1 if you have the `Rmath' library (-lRmath). */ #define HAVE_LIBRMATH 1 /* Define to 1 if you have the `root' library (-lroot). */ /* #undef HAVE_LIBROOT */ /* Define to 1 if you have the `tic' library (-ltic). */ #define HAVE_LIBTIC 1 /* Define to 1 if you have the `tinfo' library (-ltinfo). */ #define HAVE_LIBTINFO 1 /* Define to 1 if you have the header file. */ #define HAVE_LIMITS_H 1 /* Define to 1 if you have the `longjmp' function. */ #define HAVE_LONGJMP 1 /* Define this if a good INT*8/REAL*10/REAL*16 installation was detected */ #define HAVE_LONG_TYPES 1 /* Define to 1 if you have the `malloc' function. */ #define HAVE_MALLOC 1 /* Define this if a good mathlib installation was detected */ #define HAVE_MATHLIB 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. */ #define HAVE_MPFR_H 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 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 /opt/local/pgsql/include was detected */ /* #undef HAVE_OPT_LOCAL_PGSQL_INCLUDE */ /* Define this as PIC option */ #define HAVE_PIC "-fPIC" /* Define to 1 if you have the header file. */ #define HAVE_PLOT_H 1 /* Define to 1 if you have the `posix_memalign' function. */ #define HAVE_POSIX_MEMALIGN 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 a good quadmath installation was detected */ #define HAVE_QUADMATH 1 /* Define to 1 if you have the header file. */ #define HAVE_QUADMATH_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 header file. */ #define HAVE_RMATH_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 `sqrt' function. */ #define HAVE_SQRT 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/include/postgresql was detected */ #define HAVE_USR_INCLUDE_POSTGRESQL 1 /* 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 */ /* Platform dependent */ #define INCLUDE_DIR "" /* Define to 1 if assertions should be disabled. */ /* #undef NDEBUG */ /* 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 3.1.2" /* Define to the one symbol short name of this package. */ #define PACKAGE_TARNAME "algol68g" /* Define to the home page for this package. */ #define PACKAGE_URL "" /* Define to the version of this package. */ #define PACKAGE_VERSION "3.1.2" /* Define to 1 if you have the ANSI C header files. */ #define STDC_HEADERS 1 /* Version number of package */ #define VERSION "3.1.2" /* 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 */ #define a68_pid_t pid_t /* Define to `__inline__' or `__inline' if that's what the C compiler calls it, or to nothing if 'inline' is not supported under any name. */ #ifndef __cplusplus /* #undef inline */ #endif /* 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-3.1.2/COPYING0000644000175000017500000010451513774524144011135 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-3.1.2/compile0000755000175000017500000001635013774524144011457 00000000000000#! /bin/sh # Wrapper for compilers which do not understand '-c -o'. scriptversion=2018-03-07.03; # UTC # Copyright (C) 1999-2020 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, see . # 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 # . nl=' ' # We need space, tab and new line, in precisely that order. Quoting is # there to prevent tools from complaining about whitespace usage. IFS=" "" $nl" file_conv= # func_file_conv build_file lazy # Convert a $build file to $host form and store it in $file # Currently only supports Windows hosts. If the determined conversion # type is listed in (the comma separated) LAZY, no conversion will # take place. func_file_conv () { file=$1 case $file in / | /[!/]*) # absolute file, and not a UNC file if test -z "$file_conv"; then # lazily determine how to convert abs files case `uname -s` in MINGW*) file_conv=mingw ;; CYGWIN* | MSYS*) file_conv=cygwin ;; *) file_conv=wine ;; esac fi case $file_conv/,$2, in *,$file_conv,*) ;; mingw/*) file=`cmd //C echo "$file " | sed -e 's/"\(.*\) " *$/\1/'` ;; cygwin/* | msys/*) file=`cygpath -m "$file" || echo "$file"` ;; wine/*) file=`winepath -w "$file" || echo "$file"` ;; esac ;; esac } # func_cl_dashL linkdir # Make cl look for libraries in LINKDIR func_cl_dashL () { func_file_conv "$1" if test -z "$lib_path"; then lib_path=$file else lib_path="$lib_path;$file" fi linker_opts="$linker_opts -LIBPATH:$file" } # func_cl_dashl library # Do a library search-path lookup for cl func_cl_dashl () { lib=$1 found=no save_IFS=$IFS IFS=';' for dir in $lib_path $LIB do IFS=$save_IFS if $shared && test -f "$dir/$lib.dll.lib"; then found=yes lib=$dir/$lib.dll.lib break fi if test -f "$dir/$lib.lib"; then found=yes lib=$dir/$lib.lib break fi if test -f "$dir/lib$lib.a"; then found=yes lib=$dir/lib$lib.a break fi done IFS=$save_IFS if test "$found" != yes; then lib=$lib.lib fi } # func_cl_wrapper cl arg... # Adjust compile command to suit cl func_cl_wrapper () { # Assume a capable shell lib_path= shared=: linker_opts= 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'. eat=1 case $2 in *.o | *.[oO][bB][jJ]) func_file_conv "$2" set x "$@" -Fo"$file" shift ;; *) func_file_conv "$2" set x "$@" -Fe"$file" shift ;; esac ;; -I) eat=1 func_file_conv "$2" mingw set x "$@" -I"$file" shift ;; -I*) func_file_conv "${1#-I}" mingw set x "$@" -I"$file" shift ;; -l) eat=1 func_cl_dashl "$2" set x "$@" "$lib" shift ;; -l*) func_cl_dashl "${1#-l}" set x "$@" "$lib" shift ;; -L) eat=1 func_cl_dashL "$2" ;; -L*) func_cl_dashL "${1#-L}" ;; -static) shared=false ;; -Wl,*) arg=${1#-Wl,} save_ifs="$IFS"; IFS=',' for flag in $arg; do IFS="$save_ifs" linker_opts="$linker_opts $flag" done IFS="$save_ifs" ;; -Xlinker) eat=1 linker_opts="$linker_opts $2" ;; -*) set x "$@" "$1" shift ;; *.cc | *.CC | *.cxx | *.CXX | *.[cC]++) func_file_conv "$1" set x "$@" -Tp"$file" shift ;; *.c | *.cpp | *.CPP | *.lib | *.LIB | *.Lib | *.OBJ | *.obj | *.[oO]) func_file_conv "$1" mingw set x "$@" "$file" shift ;; *) set x "$@" "$1" shift ;; esac fi shift done if test -n "$linker_opts"; then linker_opts="-link$linker_opts" fi exec "$@" $linker_opts exit 1 } eat= 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 $? ;; cl | *[/\\]cl | cl.exe | *[/\\]cl.exe | \ icl | *[/\\]icl | icl.exe | *[/\\]icl.exe ) func_cl_wrapper "$@" # Doesn't return... ;; esac ofile= cfile= 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 's|^.*[\\/]||; s|^[a-zA-Z]:||; 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 test "$cofile" = "$ofile" || mv "$cofile" "$ofile" elif test -f "${cofile}bj"; then test "${cofile}bj" = "$ofile" || mv "${cofile}bj" "$ofile" fi rmdir "$lockdir" exit $ret # Local Variables: # mode: shell-script # sh-indentation: 2 # eval: (add-hook 'before-save-hook 'time-stamp) # time-stamp-start: "scriptversion=" # time-stamp-format: "%:y-%02m-%02d.%02H" # time-stamp-time-zone: "UTC0" # time-stamp-end: "; # UTC" # End: algol68g-3.1.2/NEWS0000644000175000017500000002537714361065322010600 00000000000000Version 3.1.2, January 2023 * Distribution update. Version 3.1.1, January 2023 * Fix configuration bug preventing building on Cygwin. * Fix undefined errno upon succesful relpath call on some systems. Version 3.1.0, November 2022 * Fix several bugs reported for 3.0.0-8. * Apply several OS dependent patches reported for 3.0.0-8. * READ and INCLUDE relative to the source file, not the present working directory. This conforms to the C preprocessor standard. Versions 3.0.1-8, January/September 2022 * Fix several bugs reported for 3.0.0-7. * Apply several OS dependent patches reported for 3.0.0-7. * Update a68g.exe to GSL 2.7.1 and R mathlib 4.1.2. Version 3.0.0, December 2021 * On platforms that support them: 64 bit INT/BITS and 128-bit LONG INT, LONG BITS and LONG REAL. These platforms include amd64, x86_64 and i386 with GCC. * More bindings for routines from the GNU Scientific Library. * Adds a generalized incomplete gamma function. * Builds with R mathlib bindings, if available. * Fixes several minor bugs. Version 2.8.4, November 2016 * Fixes several minor bugs. Version 2.8.3, March 2016 * Fixes garbage collector bug. * Fixes "execve output" that caused a "too many open files" type error. * Fixes ncurses support on Ubuntu. Version 2.8.2, October 2015 * Several bug fixes. * Cleaner interface for command line arguments through routines a68gargc and a68gargv. Version 2.8.1, January 2015 * Update source code for recent versions of gcc, autoconf, automake and TeX. * Documentation updates. Version 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 similar to 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-3.1.2/ChangeLog0000644000175000017500000000002114361065322011626 00000000000000See file "NEWS". algol68g-3.1.2/install-sh0000755000175000017500000003577613774524144012122 00000000000000#!/bin/sh # install - install a program, script, or datafile scriptversion=2020-11-14.01; # UTC # 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. tab=' ' nl=' ' IFS=" $tab$nl" # Set DOITPROG to "echo" to test this script. doit=${DOITPROG-} doit_exec=${doit:-exec} # 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_mkdir= # Desired mode of installed file. mode=0755 # Create dirs (including intermediate dirs) using mode 755. # This is like GNU 'install' as of coreutils 8.32 (2020). mkdir_umask=22 backupsuffix= chgrpcmd= chmodcmd=$chmodprog chowncmd= mvcmd=$mvprog rmcmd="$rmprog -f" stripcmd= src= dst= dir_arg= dst_arg= copy_on_change=false is_target_a_directory=possibly 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 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. -p pass -p to $cpprog. -s $stripprog installed files. -S SUFFIX attempt to back up existing files, with suffix SUFFIX. -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 By default, rm is invoked with -f; when overridden with RMPROG, it's up to you to specify -f if you want it. If -S is not specified, no backups are attempted. Email bug reports to bug-automake@gnu.org. Automake home page: https://www.gnu.org/software/automake/ " 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 *' '* | *"$tab"* | *"$nl"* | *'*'* | *'?'* | *'['*) echo "$0: invalid mode: $mode" >&2 exit 1;; esac shift;; -o) chowncmd="$chownprog $2" shift;; -p) cpprog="$cpprog -p";; -s) stripcmd=$stripprog;; -S) backupsuffix="$2" shift;; -t) is_target_a_directory=always dst_arg=$2 # Protect names problematic for 'test' and other utilities. case $dst_arg in -* | [=\(\)!]) dst_arg=./$dst_arg;; esac shift;; -T) is_target_a_directory=never;; --version) echo "$0 $scriptversion"; exit $?;; --) shift break;; -*) echo "$0: invalid option: $1" >&2 exit 1;; *) break;; esac shift done # We allow the use of options -d and -T together, by making -d # take the precedence; this is for compatibility with GNU install. if test -n "$dir_arg"; then if test -n "$dst_arg"; then echo "$0: target directory not allowed when installing a directory." >&2 exit 1 fi fi 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 # Protect names problematic for 'test' and other utilities. case $dst_arg in -* | [=\(\)!]) dst_arg=./$dst_arg;; esac 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 if test $# -gt 1 || test "$is_target_a_directory" = always; then if test ! -d "$dst_arg"; then echo "$0: $dst_arg: Is not a directory." >&2 exit 1 fi fi fi if test -z "$dir_arg"; then do_exit='(exit $ret); exit $ret' trap "ret=129; $do_exit" 1 trap "ret=130; $do_exit" 2 trap "ret=141; $do_exit" 13 trap "ret=143; $do_exit" 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 problematic for 'test' and other utilities. case $src in -* | [=\(\)!]) src=./$src;; esac if test -n "$dir_arg"; then dst=$src dstdir=$dst test -d "$dstdir" dstdir_status=$? # Don't chown directories that already exist. if test $dstdir_status = 0; then chowncmd="" fi 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 # If destination is a directory, append the input filename. if test -d "$dst"; then if test "$is_target_a_directory" = never; then echo "$0: $dst_arg: Is a directory" >&2 exit 1 fi dstdir=$dst dstbase=`basename "$src"` case $dst in */) dst=$dst$dstbase;; *) dst=$dst/$dstbase;; esac dstdir_status=0 else dstdir=`dirname "$dst"` test -d "$dstdir" dstdir_status=$? fi fi case $dstdir in */) dstdirslash=$dstdir;; *) dstdirslash=$dstdir/;; esac obsolete_mkdir_used=false if test $dstdir_status != 0; then case $posix_mkdir in '') # 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 # The $RANDOM variable is not portable (e.g., dash). Use it # here however when possible just to lower collision chance. tmpdir=${TMPDIR-/tmp}/ins$RANDOM-$$ trap ' ret=$? rmdir "$tmpdir/a/b" "$tmpdir/a" "$tmpdir" 2>/dev/null exit $ret ' 0 # Because "mkdir -p" follows existing symlinks and we likely work # directly in world-writeable /tmp, make sure that the '$tmpdir' # directory is successfully created first before we actually test # 'mkdir -p'. if (umask $mkdir_umask && $mkdirprog $mkdir_mode "$tmpdir" && exec $mkdirprog $mkdir_mode -p -- "$tmpdir/a/b") >/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-writable bit of parent directory when it shouldn't. # FreeBSD 6.1 mkdir -m -p sets mode of existing directory. test_tmpdir="$tmpdir/a" ls_ld_tmpdir=`ls -ld "$test_tmpdir"` case $ls_ld_tmpdir in d????-?r-*) different_mode=700;; d????-?--*) different_mode=755;; *) false;; esac && $mkdirprog -m$different_mode -p -- "$test_tmpdir" && { ls_ld_tmpdir_1=`ls -ld "$test_tmpdir"` test "$ls_ld_tmpdir" = "$ls_ld_tmpdir_1" } } then posix_mkdir=: fi rmdir "$tmpdir/a/b" "$tmpdir/a" "$tmpdir" else # Remove any dirs left behind by ancient mkdir implementations. rmdir ./$mkdir_mode ./-p ./-- "$tmpdir" 2>/dev/null fi trap '' 0;; esac if $posix_mkdir && ( umask $mkdir_umask && $doit_exec $mkdirprog $mkdir_mode -p -- "$dstdir" ) then : else # 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 oIFS=$IFS IFS=/ set -f set fnord $dstdir shift set +f IFS=$oIFS prefixes= for d do test X"$d" = X && 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=${dstdirslash}_inst.$$_ rmtmp=${dstdirslash}_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 && { test -z "$stripcmd" || { # Create $dsttmp read-write so that cp doesn't create it read-only, # which would cause strip to fail. if test -z "$doit"; then : >"$dsttmp" # No need to fork-exec 'touch'. else $doit touch "$dsttmp" fi } } && $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` && set -f && set X $old && old=:$2:$4:$5:$6 && set X $new && new=:$2:$4:$5:$6 && set +f && test "$old" = "$new" && $cmpprog "$dst" "$dsttmp" >/dev/null 2>&1 then rm -f "$dsttmp" else # If $backupsuffix is set, and the file being installed # already exists, attempt a backup. Don't worry if it fails, # e.g., if mv doesn't support -f. if test -n "$backupsuffix" && test -f "$dst"; then $doit $mvcmd -f "$dst" "$dst$backupsuffix" 2>/dev/null fi # 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 "$dst" 2>/dev/null || { $doit $mvcmd -f "$dst" "$rmtmp" 2>/dev/null && { $doit $rmcmd "$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 'before-save-hook 'time-stamp) # time-stamp-start: "scriptversion=" # time-stamp-format: "%:y-%02m-%02d.%02H" # time-stamp-time-zone: "UTC0" # time-stamp-end: "; # UTC" # End: algol68g-3.1.2/a68g-config.h.in0000644000175000017500000002727014361065455012670 00000000000000/* a68g-config.h.in. Generated from configure.ac by autoheader. */ /* Define this if OpenBSD was detected */ #undef BUILD_BSD /* Define this if CYGWIN was detected */ #undef BUILD_CYGWIN /* Define this if HAIKU was detected */ #undef BUILD_HAIKU /* Define this if LINUX was detected */ #undef BUILD_LINUX /* Define this if a good pthread installation was detected */ #undef BUILD_PARALLEL_CLAUSE /* Name of C compiler detected */ #undef C_COMPILER /* Define to 1 if `TIOCGWINSZ' requires . */ #undef GWINSZ_IN_SYS_IOCTL /* Define to 1 if you have the `aligned_alloc' function. */ #undef HAVE_ALIGNED_ALLOC /* Define to 1 if you have the header file. */ #undef HAVE_ASSERT_H /* Define to 1 if you have the header file. */ #undef HAVE_COMPLEX_H /* Define to 1 if you have the `csqrt' function. */ #undef HAVE_CSQRT /* 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_FENV_H /* Define if finite() is available */ #undef HAVE_FINITE /* 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 GCC was detected */ #undef HAVE_GCC /* Define this if a recent GNU MPFR installation was detected */ #undef HAVE_GNU_MPFR /* Define this if a good GNU plotutils installation was detected */ #undef HAVE_GNU_PLOTUTILS /* Define this if a good GNU GSL installation was detected */ #undef HAVE_GSL /* 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 to 1 if you have the header file. */ #undef HAVE_GSL_GSL_VERSION_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 if isfinite() is available */ #undef HAVE_ISFINITE /* Define if isinf() is available */ #undef HAVE_ISINF /* Define if isnan() is available */ #undef HAVE_ISNAN /* Define to 1 if you have the `gmp' library (-lgmp). */ #undef HAVE_LIBGMP /* 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 `mpfr' library (-lmpfr). */ #undef HAVE_LIBMPFR /* 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 `quadmath' library (-lquadmath). */ #undef HAVE_LIBQUADMATH /* Define to 1 if you have the `readline' library (-lreadline). */ #undef HAVE_LIBREADLINE /* Define to 1 if you have the `Rmath' library (-lRmath). */ #undef HAVE_LIBRMATH /* Define to 1 if you have the `root' library (-lroot). */ #undef HAVE_LIBROOT /* Define to 1 if you have the `tic' library (-ltic). */ #undef HAVE_LIBTIC /* Define to 1 if you have the `tinfo' library (-ltinfo). */ #undef HAVE_LIBTINFO /* Define to 1 if you have the header file. */ #undef HAVE_LIMITS_H /* Define to 1 if you have the `longjmp' function. */ #undef HAVE_LONGJMP /* Define this if a good INT*8/REAL*10/REAL*16 installation was detected */ #undef HAVE_LONG_TYPES /* Define to 1 if you have the `malloc' function. */ #undef HAVE_MALLOC /* Define this if a good mathlib installation was detected */ #undef HAVE_MATHLIB /* 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_MPFR_H /* 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 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 /opt/local/pgsql/include was detected */ #undef HAVE_OPT_LOCAL_PGSQL_INCLUDE /* Define this as PIC option */ #undef HAVE_PIC /* Define to 1 if you have the header file. */ #undef HAVE_PLOT_H /* Define to 1 if you have the `posix_memalign' function. */ #undef HAVE_POSIX_MEMALIGN /* 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 a good quadmath installation was detected */ #undef HAVE_QUADMATH /* Define to 1 if you have the header file. */ #undef HAVE_QUADMATH_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 header file. */ #undef HAVE_RMATH_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 `sqrt' function. */ #undef HAVE_SQRT /* 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/include/postgresql was detected */ #undef HAVE_USR_INCLUDE_POSTGRESQL /* 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 /* Platform dependent */ #undef INCLUDE_DIR /* Define to 1 if assertions should be disabled. */ #undef NDEBUG /* 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 home page for this package. */ #undef PACKAGE_URL /* 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 a68_pid_t /* Define to `__inline__' or `__inline' if that's what the C compiler calls it, or to nothing if 'inline' is not supported under any name. */ #ifndef __cplusplus #undef inline #endif /* 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-3.1.2/INSTALL0000644000175000017500000003661413774524144011137 00000000000000Installation Instructions ************************* Copyright (C) 1994-1996, 1999-2002, 2004-2016 Free Software Foundation, Inc. Copying and distribution of this file, with or without modification, are permitted in any medium without royalty provided the copyright notice and this notice are preserved. This file is offered as-is, without warranty of any kind. Basic Installation ================== Briefly, the shell command './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. Some packages provide this 'INSTALL' file but do not implement all of the features documented below. The lack of an optional feature in a given package is not necessarily a bug. More recommendations for GNU packages can be found in *note Makefile Conventions: (standards)Makefile Conventions. 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, generally using the just-built uninstalled binaries. 4. Type 'make install' to install the programs and any data files and documentation. When installing into a prefix owned by root, it is recommended that the package be configured and built as a regular user, and only the 'make install' phase executed with root privileges. 5. Optionally, type 'make installcheck' to repeat any self-tests, but this time using the binaries in their final installed location. This target does not install anything. Running this target as a regular user, particularly if the prior 'make install' required root privileges, verifies that the installation completed correctly. 6. 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. 7. Often, you can also type 'make uninstall' to remove the installed files again. In practice, not all packages have tested that uninstallation works correctly, even though it is required by the GNU Coding Standards. 8. Some packages, particularly those that use Automake, provide 'make distcheck', which can by used by developers to test that all other targets like 'make install' and 'make uninstall' work correctly. This target is generally not run by end users. 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 '..'. This is known as a "VPATH" build. 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. On MacOS X 10.5 and later systems, you can create libraries and executables that work on multiple system types--known as "fat" or "universal" binaries--by specifying multiple '-arch' options to the compiler but only a single '-arch' option to the preprocessor. Like this: ./configure CC="gcc -arch i386 -arch x86_64 -arch ppc -arch ppc64" \ CXX="g++ -arch i386 -arch x86_64 -arch ppc -arch ppc64" \ CPP="gcc -E" CXXCPP="g++ -E" This is not guaranteed to produce working output in all cases, you may have to build one architecture at a time and combine the results using the 'lipo' tool if you have problems. 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', where PREFIX must be an absolute file name. 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. In general, the default for these options is expressed in terms of '${prefix}', so that specifying just '--prefix' will affect all of the other directory specifications that were not explicitly provided. The most portable way to affect installation locations is to pass the correct locations to 'configure'; however, many packages provide one or both of the following shortcuts of passing variable assignments to the 'make install' command line to change installation locations without having to reconfigure or recompile. The first method involves providing an override variable for each affected directory. For example, 'make install prefix=/alternate/directory' will choose an alternate location for all directory configuration variables that were expressed in terms of '${prefix}'. Any directories that were specified during 'configure', but not in terms of '${prefix}', must each be overridden at install time for the entire installation to be relocated. The approach of makefile variable overrides for each directory variable is required by the GNU Coding Standards, and ideally causes no recompilation. However, some platforms have known limitations with the semantics of shared libraries that end up requiring recompilation when using this method, particularly noticeable in packages that use GNU Libtool. The second method involves providing the 'DESTDIR' variable. For example, 'make install DESTDIR=/alternate/directory' will prepend '/alternate/directory' before all installation names. The approach of 'DESTDIR' overrides is not required by the GNU Coding Standards, and does not work on platforms that have drive letters. On the other hand, it does better at avoiding recompilation issues, and works well even when some directory options were not specified in terms of '${prefix}' at 'configure' time. Optional Features ================= 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'. 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. Some packages offer the ability to configure how verbose the execution of 'make' will be. For these packages, running './configure --enable-silent-rules' sets the default to minimal output, which can be overridden with 'make V=1'; while running './configure --disable-silent-rules' sets the default to verbose, which can be overridden with 'make V=0'. Particular systems ================== On HP-UX, the default C compiler is not ANSI C compatible. If GNU CC is not installed, it is recommended to use the following options in order to use an ANSI C compiler: ./configure CC="cc -Ae -D_XOPEN_SOURCE=500" and if that doesn't work, install pre-built binaries of GCC for HP-UX. HP-UX 'make' updates targets which have the same time stamps as their prerequisites, which makes it generally unusable when shipped generated files such as 'configure' are involved. Use GNU 'make' instead. On OSF/1 a.k.a. Tru64, some versions of the default C compiler cannot parse its '' header file. The option '-nodtk' can be used as a workaround. If GNU CC is not installed, it is therefore recommended to try ./configure CC="cc" and if that doesn't work, try ./configure CC="cc -nodtk" On Solaris, don't put '/usr/ucb' early in your 'PATH'. This directory contains several dysfunctional programs; working variants of these programs are available in '/usr/bin'. So, if you need '/usr/ucb' in your 'PATH', put it _after_ '/usr/bin'. On Haiku, software installed for all users goes in '/boot/common', not '/usr/local'. It is recommended to use the following options: ./configure --prefix=/boot/common 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 limitation. Until the limitation is lifted, you can use this workaround: CONFIG_SHELL=/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 all of the options to 'configure', and exit. '--help=short' '--help=recursive' Print a summary of the options unique to this package's 'configure', and exit. The 'short' variant lists options used only in the top level, while the 'recursive' variant lists options also present in any nested packages. '--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. '--prefix=DIR' Use DIR as the installation prefix. *note Installation Names:: for more details, including other options available for fine-tuning the installation locations. '--no-create' '-n' Run the configure checks, but stop before creating any output files. 'configure' also accepts some other, not widely useful, options. Run 'configure --help' for more details. algol68g-3.1.2/config.guess0000755000175000017500000012637313770154163012424 00000000000000#! /bin/sh # Attempt to guess a canonical system name. # Copyright 1992-2018 Free Software Foundation, Inc. timestamp='2018-02-24' # 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 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 . # # 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 Exception is an additional permission under section 7 # of the GNU General Public License, version 3 ("GPLv3"). # # Originally written by Per Bothner; maintained since 2000 by Ben Elliston. # # You can get the latest version of this script from: # https://git.savannah.gnu.org/gitweb/?p=config.git;a=blob_plain;f=config.guess # # Please send patches to . me=`echo "$0" | sed -e 's,.*/,,'` usage="\ Usage: $0 [OPTION] Output the configuration name of the system \`$me' is run on. Options: -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 1992-2018 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 case "$UNAME_SYSTEM" in Linux|GNU|GNU/*) # If the system lacks a compiler, then just pick glibc. # We could probably try harder. LIBC=gnu eval "$set_cc_for_build" cat <<-EOF > "$dummy.c" #include #if defined(__UCLIBC__) LIBC=uclibc #elif defined(__dietlibc__) LIBC=dietlibc #else LIBC=gnu #endif EOF eval "`$CC_FOR_BUILD -E "$dummy.c" 2>/dev/null | grep '^LIBC' | sed 's, ,,g'`" # If ldd exists, use it to detect musl libc. if command -v ldd >/dev/null && \ ldd --version 2>&1 | grep -q ^musl then LIBC=musl fi ;; esac # 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 tuples: *-*-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=`(uname -p 2>/dev/null || \ "/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 ;; earmv*) arch=`echo "$UNAME_MACHINE_ARCH" | sed -e 's,^e\(armv[0-9]\).*$,\1,'` endian=`echo "$UNAME_MACHINE_ARCH" | sed -ne 's,^.*\(eb\)$,\1,p'` machine="${arch}${endian}"-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) and ABI. case "$UNAME_MACHINE_ARCH" in earm*) os=netbsdelf ;; 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 # Determine ABI tags. case "$UNAME_MACHINE_ARCH" in earm*) expr='s/^earmv[0-9]/-eabi/;s/eb$//' abi=`echo "$UNAME_MACHINE_ARCH" | sed -e "$expr"` ;; 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/[-_].*//' | cut -d. -f1,2` ;; 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}${abi}" exit ;; *:Bitrig:*:*) UNAME_MACHINE_ARCH=`arch | sed 's/Bitrig.//'` echo "$UNAME_MACHINE_ARCH"-unknown-bitrig"$UNAME_RELEASE" exit ;; *:OpenBSD:*:*) UNAME_MACHINE_ARCH=`arch | sed 's/OpenBSD.//'` echo "$UNAME_MACHINE_ARCH"-unknown-openbsd"$UNAME_RELEASE" exit ;; *:LibertyBSD:*:*) UNAME_MACHINE_ARCH=`arch | sed 's/^.*BSD\.//'` echo "$UNAME_MACHINE_ARCH"-unknown-libertybsd"$UNAME_RELEASE" exit ;; *:MidnightBSD:*:*) echo "$UNAME_MACHINE"-unknown-midnightbsd"$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 ;; *:Sortix:*:*) echo "$UNAME_MACHINE"-unknown-sortix exit ;; *:Redox:*:*) echo "$UNAME_MACHINE"-unknown-redox exit ;; mips:OSF1:*.*) echo mips-dec-osf1 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 ;; 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/lslpp ] ; then IBM_REV=`/usr/bin/lslpp -Lqc bos.rte.libc | awk -F: '{ print $3 }' | sed s/[0-9]*$/0/` 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:4.4BSD:*) 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:*:*) UNAME_PROCESSOR=`/usr/bin/uname -p` case "$UNAME_PROCESSOR" in amd64) UNAME_PROCESSOR=x86_64 ;; i386) UNAME_PROCESSOR=i586 ;; esac echo "$UNAME_PROCESSOR"-unknown-freebsd"`echo "$UNAME_RELEASE"|sed -e 's/[-(].*//'`" exit ;; i*:CYGWIN*:*) echo "$UNAME_MACHINE"-pc-cygwin exit ;; *:MINGW64*:*) echo "$UNAME_MACHINE"-pc-mingw64 exit ;; *:MINGW*:*) echo "$UNAME_MACHINE"-pc-mingw32 exit ;; *:MSYS*:*) echo "$UNAME_MACHINE"-pc-msys 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 ;; i*:UWIN*:*) echo "$UNAME_MACHINE"-pc-uwin exit ;; amd64:CYGWIN*:*:* | x86_64:CYGWIN*:*:*) echo x86_64-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-$LIBC`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 "[:upper:]" "[:lower:]"``echo "$UNAME_RELEASE"|sed -e 's/[-(].*//'`-$LIBC" exit ;; i*86:Minix:*:*) echo "$UNAME_MACHINE"-pc-minix exit ;; aarch64:Linux:*:*) echo "$UNAME_MACHINE"-unknown-linux-"$LIBC" exit ;; aarch64_be:Linux:*:*) UNAME_MACHINE=aarch64_be echo "$UNAME_MACHINE"-unknown-linux-"$LIBC" 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=gnulibc1 ; fi echo "$UNAME_MACHINE"-unknown-linux-"$LIBC" exit ;; arc:Linux:*:* | arceb:Linux:*:*) echo "$UNAME_MACHINE"-unknown-linux-"$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-"$LIBC" else if echo __ARM_PCS_VFP | $CC_FOR_BUILD -E - 2>/dev/null \ | grep -q __ARM_PCS_VFP then echo "$UNAME_MACHINE"-unknown-linux-"$LIBC"eabi else echo "$UNAME_MACHINE"-unknown-linux-"$LIBC"eabihf fi fi exit ;; avr32*:Linux:*:*) echo "$UNAME_MACHINE"-unknown-linux-"$LIBC" exit ;; cris:Linux:*:*) echo "$UNAME_MACHINE"-axis-linux-"$LIBC" exit ;; crisv32:Linux:*:*) echo "$UNAME_MACHINE"-axis-linux-"$LIBC" exit ;; e2k:Linux:*:*) echo "$UNAME_MACHINE"-unknown-linux-"$LIBC" exit ;; frv:Linux:*:*) echo "$UNAME_MACHINE"-unknown-linux-"$LIBC" exit ;; hexagon:Linux:*:*) echo "$UNAME_MACHINE"-unknown-linux-"$LIBC" exit ;; i*86:Linux:*:*) echo "$UNAME_MACHINE"-pc-linux-"$LIBC" exit ;; ia64:Linux:*:*) echo "$UNAME_MACHINE"-unknown-linux-"$LIBC" exit ;; k1om:Linux:*:*) echo "$UNAME_MACHINE"-unknown-linux-"$LIBC" exit ;; m32r*:Linux:*:*) echo "$UNAME_MACHINE"-unknown-linux-"$LIBC" exit ;; m68*:Linux:*:*) echo "$UNAME_MACHINE"-unknown-linux-"$LIBC" 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-$LIBC"; exit; } ;; mips64el:Linux:*:*) echo "$UNAME_MACHINE"-unknown-linux-"$LIBC" exit ;; openrisc*:Linux:*:*) echo or1k-unknown-linux-"$LIBC" exit ;; or32:Linux:*:* | or1k*:Linux:*:*) echo "$UNAME_MACHINE"-unknown-linux-"$LIBC" exit ;; padre:Linux:*:*) echo sparc-unknown-linux-"$LIBC" exit ;; parisc64:Linux:*:* | hppa64:Linux:*:*) echo hppa64-unknown-linux-"$LIBC" 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-"$LIBC" ;; PA8*) echo hppa2.0-unknown-linux-"$LIBC" ;; *) echo hppa-unknown-linux-"$LIBC" ;; esac exit ;; ppc64:Linux:*:*) echo powerpc64-unknown-linux-"$LIBC" exit ;; ppc:Linux:*:*) echo powerpc-unknown-linux-"$LIBC" exit ;; ppc64le:Linux:*:*) echo powerpc64le-unknown-linux-"$LIBC" exit ;; ppcle:Linux:*:*) echo powerpcle-unknown-linux-"$LIBC" exit ;; riscv32:Linux:*:* | riscv64:Linux:*:*) echo "$UNAME_MACHINE"-unknown-linux-"$LIBC" exit ;; s390:Linux:*:* | s390x:Linux:*:*) echo "$UNAME_MACHINE"-ibm-linux-"$LIBC" exit ;; sh64*:Linux:*:*) echo "$UNAME_MACHINE"-unknown-linux-"$LIBC" exit ;; sh*:Linux:*:*) echo "$UNAME_MACHINE"-unknown-linux-"$LIBC" exit ;; sparc:Linux:*:* | sparc64:Linux:*:*) echo "$UNAME_MACHINE"-unknown-linux-"$LIBC" exit ;; tile*:Linux:*:*) echo "$UNAME_MACHINE"-unknown-linux-"$LIBC" exit ;; vax:Linux:*:*) echo "$UNAME_MACHINE"-dec-linux-"$LIBC" exit ;; x86_64:Linux:*:*) if objdump -f /bin/sh | grep -q elf32-x86-64; then echo "$UNAME_MACHINE"-pc-linux-"$LIBC"x32 else echo "$UNAME_MACHINE"-pc-linux-"$LIBC" fi exit ;; xtensa*:Linux:*:*) echo "$UNAME_MACHINE"-unknown-linux-"$LIBC" 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.*:*) 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 configure 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 ;; x86_64:Haiku:*:*) echo x86_64-unknown-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 ;; SX-ACE:SUPER-UX:*:*) echo sxace-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 eval "$set_cc_for_build" if test "$UNAME_PROCESSOR" = unknown ; then UNAME_PROCESSOR=powerpc fi if test "`echo "$UNAME_RELEASE" | sed -e 's/\..*//'`" -le 10 ; then 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 case $UNAME_PROCESSOR in i386) UNAME_PROCESSOR=x86_64 ;; powerpc) UNAME_PROCESSOR=powerpc64 ;; esac fi # On 10.4-10.6 one might compile for PowerPC via gcc -arch ppc if (echo '#ifdef __POWERPC__'; echo IS_PPC; echo '#endif') | \ (CCOPTS="" $CC_FOR_BUILD -E - 2>/dev/null) | \ grep IS_PPC >/dev/null then UNAME_PROCESSOR=powerpc fi fi elif test "$UNAME_PROCESSOR" = i386 ; then # Avoid executing cc on OS X 10.9, as it ships with a stub # that puts up a graphical alert prompting to install # developer tools. Any system running Mac OS X 10.7 or # later (Darwin 11 and later) is required to have a 64-bit # processor. This is not true of the ARM version of Darwin # that Apple uses in portable devices. UNAME_PROCESSOR=x86_64 fi 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 ;; NSV-*:NONSTOP_KERNEL:*:*) echo nsv-tandem-nsk"$UNAME_RELEASE" exit ;; NSX-*:NONSTOP_KERNEL:*:*) echo nsx-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 ;; x86_64:VMkernel:*:*) echo "$UNAME_MACHINE"-unknown-esx exit ;; amd64:Isilon\ OneFS:*:*) echo x86_64-unknown-onefs exit ;; esac echo "$0: unable to guess system type" >&2 case "$UNAME_MACHINE:$UNAME_SYSTEM" in mips:Linux | mips64:Linux) # If we got here on MIPS GNU/Linux, output extra information. cat >&2 <&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-functions 'time-stamp) # time-stamp-start: "timestamp='" # time-stamp-format: "%:y-%02m-%02d" # time-stamp-end: "'" # End: algol68g-3.1.2/config.sub0000755000175000017500000010645013770154163012061 00000000000000#! /bin/sh # Configuration validation subroutine script. # Copyright 1992-2018 Free Software Foundation, Inc. timestamp='2018-02-22' # 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 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 . # # 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 Exception is an additional permission under section 7 # of the GNU General Public License, version 3 ("GPLv3"). # Please send patches to . # # 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: # https://git.savannah.gnu.org/gitweb/?p=config.git;a=blob_plain;f=config.sub # 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 or ALIAS Canonicalize a configuration name. Options: -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 1992-2018 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-musl* | linux-uclibc* | uclinux-uclibc* | uclinux-gnu* | kfreebsd*-gnu* | \ knetbsd*-gnu* | netbsd*-gnu* | netbsd*-eabi* | \ kopensolaris*-gnu* | cloudabi*-eabi* | \ storm-chaos* | os2-emx* | rtmk-nova*) os=-$maybe_os basic_machine=`echo "$1" | sed 's/^\(.*\)-\([^-]*-[^-]*\)$/\1/'` ;; android-linux) os=-linux-android basic_machine=`echo "$1" | sed 's/^\(.*\)-\([^-]*-[^-]*\)$/\1/'`-unknown ;; *) 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*178) os=-lynxos178 ;; -lynx*5) os=-lynxos5 ;; -lynx*) os=-lynxos ;; -ptx*) basic_machine=`echo "$1" | sed -e 's/86-.*/86-sequent/'` ;; -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 \ | aarch64 | aarch64_be \ | alpha | alphaev[4-8] | alphaev56 | alphaev6[78] | alphapca5[67] \ | alpha64 | alpha64ev[4-8] | alpha64ev56 | alpha64ev6[78] | alpha64pca5[67] \ | am33_2.0 \ | arc | arceb \ | arm | arm[bl]e | arme[lb] | armv[2-8] | armv[3-8][lb] | armv7[arm] \ | avr | avr32 \ | ba \ | be32 | be64 \ | bfin \ | c4x | c8051 | clipper \ | d10v | d30v | dlx | dsp16xx \ | e2k | epiphany \ | fido | fr30 | frv | ft32 \ | h8300 | h8500 | hppa | hppa1.[01] | hppa2.0 | hppa2.0[nw] | hppa64 \ | hexagon \ | i370 | i860 | i960 | ia16 | ia64 \ | ip2k | iq2000 \ | k1om \ | le32 | le64 \ | lm32 \ | m32c | m32r | m32rle | m68000 | m68k | m88k \ | maxq | mb | microblaze | microblazeel | 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 \ | mipsisa32r6 | mipsisa32r6el \ | mipsisa64 | mipsisa64el \ | mipsisa64r2 | mipsisa64r2el \ | mipsisa64r6 | mipsisa64r6el \ | mipsisa64sb1 | mipsisa64sb1el \ | mipsisa64sr71k | mipsisa64sr71kel \ | mipsr5900 | mipsr5900el \ | mipstx39 | mipstx39el \ | mn10200 | mn10300 \ | moxie \ | mt \ | msp430 \ | nds32 | nds32le | nds32be \ | nios | nios2 | nios2eb | nios2el \ | ns16k | ns32k \ | open8 | or1k | or1knd | or32 \ | pdp10 | pj | pjl \ | powerpc | powerpc64 | powerpc64le | powerpcle \ | pru \ | pyramid \ | riscv32 | riscv64 \ | rl78 | rx \ | score \ | sh | sh[1234] | sh[24]a | sh[24]aeb | sh[23]e | sh[234]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 \ | visium \ | wasm32 \ | 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 ;; leon|leon[3-9]) basic_machine=sparc-$basic_machine ;; m6811 | m68hc11 | m6812 | m68hc12 | m68hcs12x | nvptx | picochip) basic_machine=$basic_machine-unknown os=-none ;; m88110 | m680[12346]0 | m683?2 | m68360 | m5200 | v70 | w65) ;; ms1) basic_machine=mt-unknown ;; strongarm | thumb | xscale) basic_machine=arm-unknown ;; xgate) basic_machine=$basic_machine-unknown os=-none ;; 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-* \ | aarch64-* | aarch64_be-* \ | alpha-* | alphaev[4-8]-* | alphaev56-* | alphaev6[78]-* \ | alpha64-* | alpha64ev[4-8]-* | alpha64ev56-* | alpha64ev6[78]-* \ | alphapca5[67]-* | alpha64pca5[67]-* | arc-* | arceb-* \ | arm-* | armbe-* | armle-* | armeb-* | armv*-* \ | avr-* | avr32-* \ | ba-* \ | be32-* | be64-* \ | bfin-* | bs2000-* \ | c[123]* | c30-* | [cjt]90-* | c4x-* \ | c8051-* | clipper-* | craynv-* | cydra-* \ | d10v-* | d30v-* | dlx-* \ | e2k-* | elxsi-* \ | f30[01]-* | f700-* | fido-* | fr30-* | frv-* | fx80-* \ | h8300-* | h8500-* \ | hppa-* | hppa1.[01]-* | hppa2.0-* | hppa2.0[nw]-* | hppa64-* \ | hexagon-* \ | i*86-* | i860-* | i960-* | ia16-* | ia64-* \ | ip2k-* | iq2000-* \ | k1om-* \ | le32-* | le64-* \ | lm32-* \ | m32c-* | m32r-* | m32rle-* \ | m68000-* | m680[012346]0-* | m68360-* | m683?2-* | m68k-* \ | m88110-* | m88k-* | maxq-* | mcore-* | metag-* \ | microblaze-* | microblazeel-* \ | 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-* \ | mipsisa32r6-* | mipsisa32r6el-* \ | mipsisa64-* | mipsisa64el-* \ | mipsisa64r2-* | mipsisa64r2el-* \ | mipsisa64r6-* | mipsisa64r6el-* \ | mipsisa64sb1-* | mipsisa64sb1el-* \ | mipsisa64sr71k-* | mipsisa64sr71kel-* \ | mipsr5900-* | mipsr5900el-* \ | mipstx39-* | mipstx39el-* \ | mmix-* \ | mt-* \ | msp430-* \ | nds32-* | nds32le-* | nds32be-* \ | nios-* | nios2-* | nios2eb-* | nios2el-* \ | none-* | np1-* | ns16k-* | ns32k-* \ | open8-* \ | or1k*-* \ | orion-* \ | pdp10-* | pdp11-* | pj-* | pjl-* | pn-* | power-* \ | powerpc-* | powerpc64-* | powerpc64le-* | powerpcle-* \ | pru-* \ | pyramid-* \ | riscv32-* | riscv64-* \ | rl78-* | 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-* \ | visium-* \ | wasm32-* \ | 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-pc 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 ;; asmjs) basic_machine=asmjs-unknown ;; 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*) basic_machine=m68k-bull os=-sysv3 ;; e500v[12]) basic_machine=powerpc-unknown os=$os"spe" ;; e500v[12]-*) basic_machine=powerpc-`echo "$basic_machine" | sed 's/^[^-]*-//'` os=$os"spe" ;; 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 ;; hppaosf) basic_machine=hppa1.1-hp os=-osf ;; hppro) basic_machine=hppa1.1-hp os=-proelf ;; i370-ibm* | ibm*) basic_machine=i370-ibm ;; 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 ;; 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 ;; leon-*|leon[3-9]-*) basic_machine=sparc-`echo "$basic_machine" | sed 's/-.*//'` ;; m68knommu) basic_machine=m68k-unknown os=-linux ;; m68knommu-*) basic_machine=m68k-`echo "$basic_machine" | sed 's/^[^-]*-//'` os=-linux ;; magnum | m3230) basic_machine=mips-mips os=-sysv ;; merlin) basic_machine=ns32k-utek os=-sysv ;; microblaze*) basic_machine=microblaze-xilinx ;; mingw64) basic_machine=x86_64-pc os=-mingw64 ;; mingw32) basic_machine=i686-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 ;; moxiebox) basic_machine=moxie-unknown os=-moxiebox ;; msdos) basic_machine=i386-pc os=-msdos ;; ms1-*) basic_machine=`echo "$basic_machine" | sed -e 's/ms1-/mt-/'` ;; msys) basic_machine=i686-pc os=-msys ;; mvs) basic_machine=i370-ibm os=-mvs ;; nacl) basic_machine=le32-unknown os=-nacl ;; 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 ;; nsv-tandem) basic_machine=nsv-tandem ;; nsx-tandem) basic_machine=nsx-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) 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) 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 | rdos64) basic_machine=x86_64-pc os=-rdos ;; rdos32) 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 ;; sh5el) basic_machine=sh5le-unknown ;; 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 ;; x64) basic_machine=x86_64-pc ;; 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 ;; 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 ;; 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 ;; 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 ;; -unixware*) os=-sysv4.2uw ;; -gnu/linux*) os=`echo $os | sed -e 's|gnu/linux|linux-gnu|'` ;; # es1800 is here to avoid being matched by es* (a different OS) -es1800*) os=-ose ;; # Now 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* | -plan9* \ | -amigaos* | -amigados* | -msdos* | -newsos* | -unicos* | -aof* \ | -aos* | -aros* | -cloudabi* | -sortix* \ | -nindy* | -vxsim* | -vxworks* | -ebmon* | -hms* | -mvs* \ | -clix* | -riscos* | -uniplus* | -iris* | -rtu* | -xenix* \ | -hiux* | -knetbsd* | -mirbsd* | -netbsd* \ | -bitrig* | -openbsd* | -solidbsd* | -libertybsd* \ | -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* | -glidix* \ | -cygwin* | -msys* | -pe* | -psos* | -moss* | -proelf* | -rtems* \ | -midipix* | -mingw32* | -mingw64* | -linux-gnu* | -linux-android* \ | -linux-newlib* | -linux-musl* | -linux-uclibc* \ | -uxpv* | -beos* | -mpeix* | -udk* | -moxiebox* \ | -interix* | -uwin* | -mks* | -rhapsody* | -darwin* \ | -openstep* | -oskit* | -conix* | -pw32* | -nonstopux* \ | -storm-chaos* | -tops10* | -tenex* | -tops20* | -its* \ | -os2* | -vos* | -palmos* | -uclinux* | -nucleus* \ | -morphos* | -superux* | -rtmk* | -windiss* \ | -powermax* | -dnix* | -nx6 | -nx7 | -sei* | -dragonfly* \ | -skyos* | -haiku* | -rdos* | -toppers* | -drops* | -es* \ | -onefs* | -tirtos* | -phoenix* | -fuchsia* | -redox* | -bme* \ | -midnightbsd*) # 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 | -xray | -os68k* | -v88r* \ | -windows* | -osx | -abug | -netware* | -os9* \ | -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 ;; -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 ;; -*mint | -mint[0-9]* | -*MiNT | -MiNT[0-9]*) os=-mint ;; -zvmoe) os=-zvmoe ;; -dicos*) os=-dicos ;; -pikeos*) # Until real need of OS specific support for # particular features comes up, bare metal # configurations are quite functional. case $basic_machine in arm*) os=-eabi ;; *) os=-elf ;; esac ;; -nacl*) ;; -ios) ;; -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 ;; c8051-*) os=-elf ;; hexagon-*) os=-elf ;; 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 ;; 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 ;; pru-*) os=-elf ;; *-be) os=-beos ;; *-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 ;; *-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-functions 'time-stamp) # time-stamp-start: "timestamp='" # time-stamp-format: "%:y-%02m-%02d" # time-stamp-end: "'" # End: algol68g-3.1.2/missing0000755000175000017500000001533613774524144011503 00000000000000#! /bin/sh # Common wrapper for a few potentially missing GNU programs. scriptversion=2018-03-07.03; # UTC # Copyright (C) 1996-2020 Free Software Foundation, Inc. # Originally written 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, see . # 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 case $1 in --is-lightweight) # Used by our autoconf macros to check whether the available missing # script is modern enough. exit 0 ;; --run) # Back-compat with the calling convention used by older automake. shift ;; -h|--h|--he|--hel|--help) echo "\ $0 [OPTION]... PROGRAM [ARGUMENT]... Run 'PROGRAM [ARGUMENT]...', returning a proper advice when this fails due to PROGRAM being missing or too old. Options: -h, --help display this help and exit -v, --version output version information and exit Supported PROGRAM values: aclocal autoconf autoheader autom4te automake makeinfo bison yacc flex lex help2man Version suffixes to PROGRAM as well as the prefixes 'gnu-', 'gnu', and 'g' are ignored when checking the name. 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 # Run the given program, remember its exit status. "$@"; st=$? # If it succeeded, we are done. test $st -eq 0 && exit 0 # Also exit now if we it failed (or wasn't found), and '--version' was # passed; such an option is passed most likely to detect whether the # program is present and works. case $2 in --version|--help) exit $st;; esac # Exit code 63 means version mismatch. This often happens when the user # tries to use an ancient version of a tool on a file that requires a # minimum version. if test $st -eq 63; then msg="probably too old" elif test $st -eq 127; then # Program was missing. msg="missing on your system" else # Program was found and executed, but failed. Give up. exit $st fi perl_URL=https://www.perl.org/ flex_URL=https://github.com/westes/flex gnu_software_URL=https://www.gnu.org/software program_details () { case $1 in aclocal|automake) echo "The '$1' program is part of the GNU Automake package:" echo "<$gnu_software_URL/automake>" echo "It also requires GNU Autoconf, GNU m4 and Perl in order to run:" echo "<$gnu_software_URL/autoconf>" echo "<$gnu_software_URL/m4/>" echo "<$perl_URL>" ;; autoconf|autom4te|autoheader) echo "The '$1' program is part of the GNU Autoconf package:" echo "<$gnu_software_URL/autoconf/>" echo "It also requires GNU m4 and Perl in order to run:" echo "<$gnu_software_URL/m4/>" echo "<$perl_URL>" ;; esac } give_advice () { # Normalize program name to check for. normalized_program=`echo "$1" | sed ' s/^gnu-//; t s/^gnu//; t s/^g//; t'` printf '%s\n' "'$1' is $msg." configure_deps="'configure.ac' or m4 files included by 'configure.ac'" case $normalized_program in autoconf*) echo "You should only need it if you modified 'configure.ac'," echo "or m4 files included by it." program_details 'autoconf' ;; autoheader*) echo "You should only need it if you modified 'acconfig.h' or" echo "$configure_deps." program_details 'autoheader' ;; automake*) echo "You should only need it if you modified 'Makefile.am' or" echo "$configure_deps." program_details 'automake' ;; aclocal*) echo "You should only need it if you modified 'acinclude.m4' or" echo "$configure_deps." program_details 'aclocal' ;; autom4te*) echo "You might have modified some maintainer files that require" echo "the 'autom4te' program to be rebuilt." program_details 'autom4te' ;; bison*|yacc*) echo "You should only need it if you modified a '.y' file." echo "You may want to install the GNU Bison package:" echo "<$gnu_software_URL/bison/>" ;; lex*|flex*) echo "You should only need it if you modified a '.l' file." echo "You may want to install the Fast Lexical Analyzer package:" echo "<$flex_URL>" ;; help2man*) echo "You should only need it if you modified a dependency" \ "of a man page." echo "You may want to install the GNU Help2man package:" echo "<$gnu_software_URL/help2man/>" ;; makeinfo*) echo "You should only need it if you modified a '.texi' file, or" echo "any other file indirectly affecting the aspect of the manual." echo "You might want to install the Texinfo package:" echo "<$gnu_software_URL/texinfo/>" echo "The spurious makeinfo call might also be the consequence of" echo "using a buggy 'make' (AIX, DU, IRIX), in which case you might" echo "want to install GNU make:" echo "<$gnu_software_URL/make/>" ;; *) echo "You might have modified some files without having the proper" echo "tools for further handling them. Check the 'README' file, it" echo "often tells you about the needed prerequisites for installing" echo "this package. You may also peek at any GNU archive site, in" echo "case some other package contains this missing '$1' program." ;; esac } give_advice "$1" | sed -e '1s/^/WARNING: /' \ -e '2,$s/^/ /' >&2 # Propagate the correct exit status (expected to be 127 for a program # not found, 63 for a program that failed due to version mismatch). exit $st # Local variables: # eval: (add-hook 'before-save-hook 'time-stamp) # time-stamp-start: "scriptversion=" # time-stamp-format: "%:y-%02m-%02d.%02H" # time-stamp-time-zone: "UTC0" # time-stamp-end: "; # UTC" # End: algol68g-3.1.2/depcomp0000755000175000017500000005602013774524144011454 00000000000000#! /bin/sh # depcomp - compile a program generating dependencies as side-effects scriptversion=2018-03-07.03; # UTC # Copyright (C) 1999-2020 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, see . # 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 outputting dependencies. libtool Whether libtool is used (yes/no). Report bugs to . EOF exit $? ;; -v | --v*) echo "depcomp $scriptversion" exit $? ;; esac # Get the directory component of the given path, and save it in the # global variables '$dir'. Note that this directory component will # be either empty or ending with a '/' character. This is deliberate. set_dir_from () { case $1 in */*) dir=`echo "$1" | sed -e 's|/[^/]*$|/|'`;; *) dir=;; esac } # Get the suffix-stripped basename of the given path, and save it the # global variable '$base'. set_base_from () { base=`echo "$1" | sed -e 's|^.*/||' -e 's/\.[^.]*$//'` } # If no dependency file was actually created by the compiler invocation, # we still have to create a dummy depfile, to avoid errors with the # Makefile "include basename.Plo" scheme. make_dummy_depfile () { echo "#dummy" > "$depfile" } # Factor out some common post-processing of the generated depfile. # Requires the auxiliary global variable '$tmpdepfile' to be set. aix_post_process_depfile () { # If the compiler actually managed to produce a dependency file, # post-process it. if test -f "$tmpdepfile"; then # Each line is of the form 'foo.o: dependency.h'. # Do two passes, one to just change these to # $object: dependency.h # and one to simply output # dependency.h: # which is needed to avoid the deleted-header problem. { sed -e "s,^.*\.[$lower]*:,$object:," < "$tmpdepfile" sed -e "s,^.*\.[$lower]*:[$tab ]*,," -e 's,$,:,' < "$tmpdepfile" } > "$depfile" rm -f "$tmpdepfile" else make_dummy_depfile fi } # A tabulation character. tab=' ' # A newline character. nl=' ' # Character ranges might be problematic outside the C locale. # These definitions help. upper=ABCDEFGHIJKLMNOPQRSTUVWXYZ lower=abcdefghijklmnopqrstuvwxyz digits=0123456789 alpha=${upper}${lower} 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" # Avoid interferences from the environment. gccflag= dashmflag= # 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 cygpath_u="cygpath -u -f -" if test "$depmode" = msvcmsys; then # This is just like msvisualcpp but w/o cygpath translation. # Just convert the backslash-escaped backslashes to single forward # slashes to satisfy depend.m4 cygpath_u='sed s,\\\\,/,g' depmode=msvisualcpp fi if test "$depmode" = msvc7msys; then # This is just like msvc7 but w/o cygpath translation. # Just convert the backslash-escaped backslashes to single forward # slashes to satisfy depend.m4 cygpath_u='sed s,\\\\,/,g' depmode=msvc7 fi if test "$depmode" = xlc; then # IBM C/C++ Compilers xlc/xlC can output gcc-like dependency information. gccflag=-qmakedep=gcc,-MF depmode=gcc 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 -ne 0; then rm -f "$tmpdepfile" exit $stat fi mv "$tmpdepfile" "$depfile" ;; gcc) ## Note that this doesn't just cater to obsosete pre-3.x GCC compilers. ## but also to in-use compilers like IMB xlc/xlC and the HP C compiler. ## (see the conditional assignment to $gccflag above). ## 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). Also, it might not be ## supported by the other compilers which use the 'gcc' depmode. ## - 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 -ne 0; then rm -f "$tmpdepfile" exit $stat fi rm -f "$depfile" echo "$object : \\" > "$depfile" # 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. ## 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. hp depmode also adds that space, but also prefixes the VPATH ## to the object. Take care to not repeat it in the output. ## Some versions of the HPUX 10.20 sed can't process this invocation ## correctly. Breaking it into two sed invocations is a workaround. tr ' ' "$nl" < "$tmpdepfile" \ | sed -e 's/^\\$//' -e '/^$/d' -e "s|.*$object$||" -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 -ne 0; then 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 ' ' "$nl" < "$tmpdepfile" \ | sed -e 's/^.*\.o://' -e 's/#.*$//' -e '/^$/ d' \ | tr "$nl" ' ' >> "$depfile" echo >> "$depfile" # The second pass generates a dummy entry for each header file. tr ' ' "$nl" < "$tmpdepfile" \ | sed -e 's/^.*\.o://' -e 's/#.*$//' -e '/^$/ d' -e 's/$/:/' \ >> "$depfile" else make_dummy_depfile fi rm -f "$tmpdepfile" ;; xlc) # 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 ;; 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. set_dir_from "$object" set_base_from "$object" 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 -ne 0; then rm -f "$tmpdepfile1" "$tmpdepfile2" "$tmpdepfile3" exit $stat fi for tmpdepfile in "$tmpdepfile1" "$tmpdepfile2" "$tmpdepfile3" do test -f "$tmpdepfile" && break done aix_post_process_depfile ;; tcc) # tcc (Tiny C Compiler) understand '-MD -MF file' since version 0.9.26 # FIXME: That version still under development at the moment of writing. # Make that this statement remains true also for stable, released # versions. # It will wrap lines (doesn't matter whether long or short) with a # trailing '\', as in: # # foo.o : \ # foo.c \ # foo.h \ # # It will put a trailing '\' even on the last line, and will use leading # spaces rather than leading tabs (at least since its commit 0394caf7 # "Emit spaces for -MD"). "$@" -MD -MF "$tmpdepfile" stat=$? if test $stat -ne 0; then rm -f "$tmpdepfile" exit $stat fi rm -f "$depfile" # Each non-empty line is of the form 'foo.o : \' or ' dep.h \'. # We have to change lines of the first kind to '$object: \'. sed -e "s|.*:|$object :|" < "$tmpdepfile" > "$depfile" # And for each line of the second kind, we have to emit a 'dep.h:' # dummy dependency, to avoid the deleted-header problem. sed -n -e 's|^ *\(.*\) *\\$|\1:|p' < "$tmpdepfile" >> "$depfile" rm -f "$tmpdepfile" ;; ## The order of this option in the case statement is important, since the ## shell code in configure will try each of these formats in the order ## listed in this file. A plain '-MD' option would be understood by many ## compilers, so we must ensure this comes after the gcc and icc options. pgcc) # Portland's C compiler understands '-MD'. # Will always output deps to 'file.d' where file is the root name of the # source file under compilation, even if file resides in a subdirectory. # The object file name does not affect the name of the '.d' file. # pgcc 10.2 will output # foo.o: sub/foo.c sub/foo.h # and will wrap long lines using '\' : # foo.o: sub/foo.c ... \ # sub/foo.h ... \ # ... set_dir_from "$object" # Use the source, not the object, to determine the base name, since # that's sadly what pgcc will do too. set_base_from "$source" tmpdepfile=$base.d # For projects that build the same source file twice into different object # files, the pgcc approach of using the *source* file root name can cause # problems in parallel builds. Use a locking strategy to avoid stomping on # the same $tmpdepfile. lockdir=$base.d-lock trap " echo '$0: caught signal, cleaning up...' >&2 rmdir '$lockdir' exit 1 " 1 2 13 15 numtries=100 i=$numtries while test $i -gt 0; do # mkdir is a portable test-and-set. if mkdir "$lockdir" 2>/dev/null; then # This process acquired the lock. "$@" -MD stat=$? # Release the lock. rmdir "$lockdir" break else # If the lock is being held by a different process, wait # until the winning process is done or we timeout. while test -d "$lockdir" && test $i -gt 0; do sleep 1 i=`expr $i - 1` done fi i=`expr $i - 1` done trap - 1 2 13 15 if test $i -le 0; then echo "$0: failed to acquire lock after $numtries attempts" >&2 echo "$0: check lockdir '$lockdir'" >&2 exit 1 fi if test $stat -ne 0; then 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. set_dir_from "$object" set_base_from "$object" 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 -ne 0; then 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,^.*\.[$lower]*:,$object:," "$tmpdepfile" > "$depfile" # Add 'dependent.h:' lines. sed -ne '2,${ s/^ *// s/ \\*$// s/$/:/ p }' "$tmpdepfile" >> "$depfile" else make_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. set_dir_from "$object" set_base_from "$object" if test "$libtool" = yes; then # Libtool 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$base.o.d # libtool 1.5 tmpdepfile2=$dir.libs/$base.o.d # Likewise. tmpdepfile3=$dir.libs/$base.d # Compaq CCC V6.2-504 "$@" -Wc,-MD else tmpdepfile1=$dir$base.d tmpdepfile2=$dir$base.d tmpdepfile3=$dir$base.d "$@" -MD fi stat=$? if test $stat -ne 0; then rm -f "$tmpdepfile1" "$tmpdepfile2" "$tmpdepfile3" exit $stat fi for tmpdepfile in "$tmpdepfile1" "$tmpdepfile2" "$tmpdepfile3" do test -f "$tmpdepfile" && break done # Same post-processing that is required for AIX mode. aix_post_process_depfile ;; msvc7) if test "$libtool" = yes; then showIncludes=-Wc,-showIncludes else showIncludes=-showIncludes fi "$@" $showIncludes > "$tmpdepfile" stat=$? grep -v '^Note: including file: ' "$tmpdepfile" if test $stat -ne 0; then rm -f "$tmpdepfile" exit $stat fi rm -f "$depfile" echo "$object : \\" > "$depfile" # The first sed program below extracts the file names and escapes # backslashes for cygpath. The second sed program outputs the file # name when reading, but also accumulates all include files in the # hold buffer in order to output them again at the end. This only # works with sed implementations that can handle large buffers. sed < "$tmpdepfile" -n ' /^Note: including file: *\(.*\)/ { s//\1/ s/\\/\\\\/g p }' | $cygpath_u | sort -u | sed -n ' s/ /\\ /g s/\(.*\)/'"$tab"'\1 \\/p s/.\(.*\) \\/\1:/ H $ { s/.*/'"$tab"'/ G p }' >> "$depfile" echo >> "$depfile" # make sure the fragment doesn't end with a backslash rm -f "$tmpdepfile" ;; msvc7msys) # 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 ;; #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 "X$1" != 'X--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|^[$tab ]*[^:$tab ][^:][^:]*:[$tab ]*|$object: |" > "$tmpdepfile" rm -f "$depfile" cat < "$tmpdepfile" > "$depfile" # Some versions of the HPUX 10.20 sed can't process this sed invocation # correctly. Breaking it into two sed invocations is a workaround. tr ' ' "$nl" < "$tmpdepfile" \ | 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 "X$1" != 'X--mode=compile'; do shift done shift fi # X makedepend shift cleared=no eat=no for arg do case $cleared in no) set ""; shift cleared=yes ;; esac if test $eat = yes; then eat=no continue fi 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. -arch) eat=yes ;; -*|$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" # makedepend may prepend the VPATH from the source file name to the object. # No need to regex-escape $object, excess matching of '.' is harmless. sed "s|^.*\($object *:\)|\1|" "$tmpdepfile" > "$depfile" # Some versions of the HPUX 10.20 sed can't process the last invocation # correctly. Breaking it into two sed invocations is a workaround. sed '1,2d' "$tmpdepfile" \ | tr ' ' "$nl" \ | 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 "X$1" != 'X--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. "$@" || exit $? # Remove the call to Libtool. if test "$libtool" = yes; then while test "X$1" != 'X--mode=compile'; do shift done shift fi IFS=" " for arg do case "$arg" in -o) shift ;; $object) shift ;; "-Gm"|"/Gm"|"-Gi"|"/Gi"|"-ZI"|"/ZI") set fnord "$@" shift shift ;; *) set fnord "$@" "$arg" shift shift ;; esac done "$@" -E 2>/dev/null | sed -n '/^#line [0-9][0-9]* "\([^"]*\)"/ s::\1:p' | $cygpath_u | sort -u > "$tmpdepfile" rm -f "$depfile" echo "$object : \\" > "$depfile" sed < "$tmpdepfile" -n -e 's% %\\ %g' -e '/^\(.*\)$/ s::'"$tab"'\1 \\:p' >> "$depfile" echo "$tab" >> "$depfile" sed < "$tmpdepfile" -n -e 's% %\\ %g' -e '/^\(.*\)$/ s::\1\::p' >> "$depfile" rm -f "$tmpdepfile" ;; msvcmsys) # 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 ;; none) exec "$@" ;; *) echo "Unknown depmode $depmode" 1>&2 exit 1 ;; esac exit 0 # Local Variables: # mode: shell-script # sh-indentation: 2 # eval: (add-hook 'before-save-hook 'time-stamp) # time-stamp-start: "scriptversion=" # time-stamp-format: "%:y-%02m-%02d.%02H" # time-stamp-time-zone: "UTC0" # time-stamp-end: "; # UTC" # End: algol68g-3.1.2/aclocal.m40000644000175000017500000012170014361065446011733 00000000000000# generated automatically by aclocal 1.16.3 -*- Autoconf -*- # Copyright (C) 1996-2020 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_CONFIG_MACRO_DIRS], [m4_defun([_AM_CONFIG_MACRO_DIRS], [])m4_defun([AC_CONFIG_MACRO_DIRS], [_AM_CONFIG_MACRO_DIRS($@)])]) m4_ifndef([AC_AUTOCONF_VERSION], [m4_copy([m4_PACKAGE_VERSION], [AC_AUTOCONF_VERSION])])dnl m4_if(m4_defn([AC_AUTOCONF_VERSION]), [2.69],, [m4_warning([this file was generated for autoconf 2.69. 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-2020 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.16' 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.16.3], [], [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 AM_INIT_AUTOMAKE. AC_DEFUN([AM_SET_CURRENT_AUTOMAKE_VERSION], [AM_AUTOMAKE_VERSION([1.16.3])dnl m4_ifndef([AC_AUTOCONF_VERSION], [m4_copy([m4_PACKAGE_VERSION], [AC_AUTOCONF_VERSION])])dnl _AM_AUTOCONF_VERSION(m4_defn([AC_AUTOCONF_VERSION]))]) # AM_AUX_DIR_EXPAND -*- Autoconf -*- # Copyright (C) 2001-2020 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], [AC_REQUIRE([AC_CONFIG_AUX_DIR_DEFAULT])dnl # Expand $ac_aux_dir to an absolute path. am_aux_dir=`cd "$ac_aux_dir" && pwd` ]) # AM_CONDITIONAL -*- Autoconf -*- # Copyright (C) 1997-2020 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_CONDITIONAL(NAME, SHELL-CONDITION) # ------------------------------------- # Define a conditional. AC_DEFUN([AM_CONDITIONAL], [AC_PREREQ([2.52])dnl m4_if([$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 m4_define([_AM_COND_VALUE_$1], [$2])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-2020 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. # 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", "OBJC", "OBJCXX", "UPC", or "GJC". # 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 m4_if([$1], [CC], [depcc="$CC" am_compiler_list=], [$1], [CXX], [depcc="$CXX" am_compiler_list=], [$1], [OBJC], [depcc="$OBJC" am_compiler_list='gcc3 gcc'], [$1], [OBJCXX], [depcc="$OBJCXX" 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". rm -rf conftest.dir 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 am__universal=false m4_case([$1], [CC], [case " $depcc " in #( *\ -arch\ *\ -arch\ *) am__universal=true ;; esac], [CXX], [case " $depcc " in #( *\ -arch\ *\ -arch\ *) am__universal=true ;; esac]) 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 10 /bin/sh. echo '/* dummy */' > sub/conftst$i.h done echo "${am__include} ${am__quote}sub/conftest.Po${am__quote}" > confmf # 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. Also, some Intel # versions had trouble with output in subdirs. am__obj=sub/conftest.${OBJEXT-o} am__minus_obj="-o $am__obj" case $depmode in gcc) # This depmode causes a compiler race in universal mode. test "$am__universal" = false || continue ;; 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 ;; msvc7 | msvc7msys | msvisualcpp | msvcmsys) # This compiler won't grok '-c -o', but also, the minuso test has # not run yet. These depmodes are late enough in the game, and # so weak that their functioning should not be impacted. am__obj=conftest.${OBJEXT-o} am__minus_obj= ;; none) break ;; esac if depmode=$depmode \ source=sub/conftest.c object=$am__obj \ depfile=sub/conftest.Po tmpdepfile=sub/conftest.TPo \ $SHELL ./depcomp $depcc -c $am__minus_obj 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 $am__obj 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], [dnl AS_HELP_STRING( [--enable-dependency-tracking], [do not reject slow dependency extractors]) AS_HELP_STRING( [--disable-dependency-tracking], [speeds up one-time build])]) if test "x$enable_dependency_tracking" != xno; then am_depcomp="$ac_aux_dir/depcomp" AMDEPBACKSLASH='\' am__nodep='_no' fi AM_CONDITIONAL([AMDEP], [test "x$enable_dependency_tracking" != xno]) AC_SUBST([AMDEPBACKSLASH])dnl _AM_SUBST_NOTMAKE([AMDEPBACKSLASH])dnl AC_SUBST([am__nodep])dnl _AM_SUBST_NOTMAKE([am__nodep])dnl ]) # Generate code to set up dependency tracking. -*- Autoconf -*- # Copyright (C) 1999-2020 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_OUTPUT_DEPENDENCY_COMMANDS # ------------------------------ AC_DEFUN([_AM_OUTPUT_DEPENDENCY_COMMANDS], [{ # Older Autoconf quotes --file arguments for eval, but not when files # are listed without --file. Let's play safe and only enable the eval # if we detect the quoting. # TODO: see whether this extra hack can be removed once we start # requiring Autoconf 2.70 or later. AS_CASE([$CONFIG_FILES], [*\'*], [eval set x "$CONFIG_FILES"], [*], [set x $CONFIG_FILES]) shift # Used to flag and report bootstrapping failures. am_rc=0 for am_mf do # Strip MF so we end up with the name of the file. am_mf=`AS_ECHO(["$am_mf"]) | sed -e 's/:.*$//'` # Check whether this is an Automake generated Makefile which includes # dependency-tracking related rules and includes. # Grep'ing the whole file directly is not great: AIX grep has a line # limit of 2048, but all sed's we know have understand at least 4000. sed -n 's,^am--depfiles:.*,X,p' "$am_mf" | grep X >/dev/null 2>&1 \ || continue am_dirpart=`AS_DIRNAME(["$am_mf"])` am_filepart=`AS_BASENAME(["$am_mf"])` AM_RUN_LOG([cd "$am_dirpart" \ && sed -e '/# am--include-marker/d' "$am_filepart" \ | $MAKE -f - am--depfiles]) || am_rc=$? done if test $am_rc -ne 0; then AC_MSG_FAILURE([Something went wrong bootstrapping makefile fragments for automatic dependency tracking. If GNU make was not used, consider re-running the configure script with MAKE="gmake" (or whatever is necessary). You can also try re-running configure with the '--disable-dependency-tracking' option to at least be able to build the package (albeit without support for automatic dependency tracking).]) fi AS_UNSET([am_dirpart]) AS_UNSET([am_filepart]) AS_UNSET([am_mf]) AS_UNSET([am_rc]) rm -f conftest-deps.mk } ])# _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. # This creates each '.Po' and '.Plo' makefile fragment that we'll 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" MAKE="${MAKE-make}"])]) # Do all the work for Automake. -*- Autoconf -*- # Copyright (C) 1996-2020 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 macro actually does too much. Some checks are only needed if # your package does certain things. But this isn't really a big deal. dnl Redefine AC_PROG_CC to automatically invoke _AM_PROG_CC_C_O. m4_define([AC_PROG_CC], m4_defn([AC_PROG_CC]) [_AM_PROG_CC_C_O ]) # 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.65])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], [AC_DIAGNOSE([obsolete], [$0: two- and three-arguments forms are deprecated.]) 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], [ok]):m4_ifdef([AC_PACKAGE_VERSION], [ok]), [ok:ok],, [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]) AC_REQUIRE([AM_PROG_INSTALL_SH])dnl AC_REQUIRE([AM_PROG_INSTALL_STRIP])dnl AC_REQUIRE([AC_PROG_MKDIR_P])dnl # For better backward compatibility. To be removed once Automake 1.9.x # dies out for good. For more background, see: # # AC_SUBST([mkdir_p], ['$(MKDIR_P)']) # We need awk for the "check" target (and possibly the TAP driver). 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])], [m4_define([AC_PROG_CC], m4_defn([AC_PROG_CC])[_AM_DEPENDENCIES([CC])])])dnl AC_PROVIDE_IFELSE([AC_PROG_CXX], [_AM_DEPENDENCIES([CXX])], [m4_define([AC_PROG_CXX], m4_defn([AC_PROG_CXX])[_AM_DEPENDENCIES([CXX])])])dnl AC_PROVIDE_IFELSE([AC_PROG_OBJC], [_AM_DEPENDENCIES([OBJC])], [m4_define([AC_PROG_OBJC], m4_defn([AC_PROG_OBJC])[_AM_DEPENDENCIES([OBJC])])])dnl AC_PROVIDE_IFELSE([AC_PROG_OBJCXX], [_AM_DEPENDENCIES([OBJCXX])], [m4_define([AC_PROG_OBJCXX], m4_defn([AC_PROG_OBJCXX])[_AM_DEPENDENCIES([OBJCXX])])])dnl ]) AC_REQUIRE([AM_SILENT_RULES])dnl dnl The testsuite driver may need to know about EXEEXT, so add the dnl 'am__EXEEXT' conditional if _AM_COMPILER_EXEEXT was seen. This dnl macro is hooked onto _AC_COMPILER_EXEEXT early, see below. AC_CONFIG_COMMANDS_PRE(dnl [m4_provide_if([_AM_COMPILER_EXEEXT], [AM_CONDITIONAL([am__EXEEXT], [test -n "$EXEEXT"])])])dnl # POSIX will say in a future version that running "rm -f" with no argument # is OK; and we want to be able to make that assumption in our Makefile # recipes. So use an aggressive probe to check that the usage we want is # actually supported "in the wild" to an acceptable degree. # See automake bug#10828. # To make any issue more visible, cause the running configure to be aborted # by default if the 'rm' program in use doesn't match our expectations; the # user can still override this though. if rm -f && rm -fr && rm -rf; then : OK; else cat >&2 <<'END' Oops! Your 'rm' program seems unable to run without file operands specified on the command line, even when the '-f' option is present. This is contrary to the behaviour of most rm programs out there, and not conforming with the upcoming POSIX standard: Please tell bug-automake@gnu.org about your system, including the value of your $PATH and any error possibly output before this message. This can help us improve future automake versions. END if test x"$ACCEPT_INFERIOR_RM_PROGRAM" = x"yes"; then echo 'Configuration will proceed anyway, since you have set the' >&2 echo 'ACCEPT_INFERIOR_RM_PROGRAM variable to "yes"' >&2 echo >&2 else cat >&2 <<'END' Aborting the configuration process, to ensure you take notice of the issue. You can download and install GNU coreutils to get an 'rm' implementation that behaves properly: . If you want to complete the configuration process using your problematic 'rm' anyway, export the environment variable ACCEPT_INFERIOR_RM_PROGRAM to "yes", and re-run configure. END AC_MSG_ERROR([Your 'rm' program is bad, sorry.]) fi fi dnl The trailing newline in this macro's definition is deliberate, for dnl backward compatibility and to allow trailing 'dnl'-style comments dnl after the AM_INIT_AUTOMAKE invocation. See automake bug#16841. ]) dnl Hook into '_AC_COMPILER_EXEEXT' early to learn its expansion. Do not dnl add the conditional right here, as _AC_COMPILER_EXEEXT may be further dnl mangled by Autoconf and run in a shell conditional statement. m4_define([_AC_COMPILER_EXEEXT], m4_defn([_AC_COMPILER_EXEEXT])[m4_provide([_AM_COMPILER_EXEEXT])]) # 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-2020 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 if test x"${install_sh+set}" != xset; then case $am_aux_dir in *\ * | *\ *) install_sh="\${SHELL} '$am_aux_dir/install-sh'" ;; *) install_sh="\${SHELL} $am_aux_dir/install-sh" esac fi AC_SUBST([install_sh])]) # Copyright (C) 2003-2020 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. # 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-2020 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_MAKE_INCLUDE() # ----------------- # Check whether make has an 'include' directive that can support all # the idioms we need for our automatic dependency tracking code. AC_DEFUN([AM_MAKE_INCLUDE], [AC_MSG_CHECKING([whether ${MAKE-make} supports the include directive]) cat > confinc.mk << 'END' am__doit: @echo this is the am__doit target >confinc.out .PHONY: am__doit END am__include="#" am__quote= # BSD make does it like this. echo '.include "confinc.mk" # ignored' > confmf.BSD # Other make implementations (GNU, Solaris 10, AIX) do it like this. echo 'include confinc.mk # ignored' > confmf.GNU _am_result=no for s in GNU BSD; do AM_RUN_LOG([${MAKE-make} -f confmf.$s && cat confinc.out]) AS_CASE([$?:`cat confinc.out 2>/dev/null`], ['0:this is the am__doit target'], [AS_CASE([$s], [BSD], [am__include='.include' am__quote='"'], [am__include='include' am__quote=''])]) if test "$am__include" != "#"; then _am_result="yes ($s style)" break fi done rm -f confinc.* confmf.* AC_MSG_RESULT([${_am_result}]) AC_SUBST([am__include])]) AC_SUBST([am__quote])]) # Fake the existence of programs that GNU maintainers use. -*- Autoconf -*- # Copyright (C) 1997-2020 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_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 is modern enough. # If it is, 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 if test x"${MISSING+set}" != xset; then MISSING="\${SHELL} '$am_aux_dir/missing'" fi # Use eval to expand $SHELL if eval "$MISSING --is-lightweight"; then am_missing_run="$MISSING " else am_missing_run= AC_MSG_WARN(['missing' script is too old or missing]) fi ]) # Helper functions for option handling. -*- Autoconf -*- # Copyright (C) 2001-2020 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_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], [m4_foreach_w([_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])]) # Copyright (C) 1999-2020 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_CC_C_O # --------------- # Like AC_PROG_CC_C_O, but changed for automake. We rewrite AC_PROG_CC # to automatically call this. AC_DEFUN([_AM_PROG_CC_C_O], [AC_REQUIRE([AM_AUX_DIR_EXPAND])dnl AC_REQUIRE_AUX_FILE([compile])dnl AC_LANG_PUSH([C])dnl AC_CACHE_CHECK( [whether $CC understands -c and -o together], [am_cv_prog_cc_c_o], [AC_LANG_CONFTEST([AC_LANG_PROGRAM([])]) # Make sure it works both with $CC and with simple cc. # Following AC_PROG_CC_C_O, we do the test twice because some # compilers refuse to overwrite an existing .o file with -o, # though they will create one. am_cv_prog_cc_c_o=yes for am_i in 1 2; do if AM_RUN_LOG([$CC -c conftest.$ac_ext -o conftest2.$ac_objext]) \ && test -f conftest2.$ac_objext; then : OK else am_cv_prog_cc_c_o=no break fi done rm -f core conftest* unset am_i]) if test "$am_cv_prog_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_LANG_POP([C])]) # For backward compatibility. AC_DEFUN_ONCE([AM_PROG_CC_C_O], [AC_REQUIRE([AC_PROG_CC])]) # Copyright (C) 2001-2020 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_RUN_LOG(COMMAND) # ------------------- # Run COMMAND, save the exit status in ac_status, and log it. # (This has been adapted from Autoconf's _AC_RUN_LOG macro.) AC_DEFUN([AM_RUN_LOG], [{ echo "$as_me:$LINENO: $1" >&AS_MESSAGE_LOG_FD ($1) >&AS_MESSAGE_LOG_FD 2>&AS_MESSAGE_LOG_FD ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&AS_MESSAGE_LOG_FD (exit $ac_status); }]) # Check to make sure that the build environment is sane. -*- Autoconf -*- # Copyright (C) 1996-2020 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_SANITY_CHECK # --------------- AC_DEFUN([AM_SANITY_CHECK], [AC_MSG_CHECKING([whether build environment is sane]) # Reject unsafe characters in $srcdir or the absolute working directory # name. Accept space and tab only in the latter. am_lf=' ' case `pwd` in *[[\\\"\#\$\&\'\`$am_lf]]*) AC_MSG_ERROR([unsafe absolute working directory name]);; esac case $srcdir in *[[\\\"\#\$\&\'\`$am_lf\ \ ]]*) AC_MSG_ERROR([unsafe srcdir value: '$srcdir']);; esac # 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 ( am_has_slept=no for am_try in 1 2; do echo "timestamp, slept: $am_has_slept" > conftest.file 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 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 if test "$[2]" = conftest.file || test $am_try -eq 2; then break fi # Just in case. sleep 1 am_has_slept=yes done 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]) # If we didn't sleep, we still need to ensure time stamps of config.status and # generated files are strictly newer. am_sleep_pid= if grep 'slept: no' conftest.file >/dev/null 2>&1; then ( sleep 1 ) & am_sleep_pid=$! fi AC_CONFIG_COMMANDS_PRE( [AC_MSG_CHECKING([that generated files are newer than configure]) if test -n "$am_sleep_pid"; then # Hide warnings about reused PIDs. wait $am_sleep_pid 2>/dev/null fi AC_MSG_RESULT([done])]) rm -f conftest.file ]) # Copyright (C) 2009-2020 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_SILENT_RULES([DEFAULT]) # -------------------------- # Enable less verbose build rules; with the default set to DEFAULT # ("yes" being less verbose, "no" or empty being verbose). AC_DEFUN([AM_SILENT_RULES], [AC_ARG_ENABLE([silent-rules], [dnl AS_HELP_STRING( [--enable-silent-rules], [less verbose build output (undo: "make V=1")]) AS_HELP_STRING( [--disable-silent-rules], [verbose build output (undo: "make V=0")])dnl ]) case $enable_silent_rules in @%:@ ((( yes) AM_DEFAULT_VERBOSITY=0;; no) AM_DEFAULT_VERBOSITY=1;; *) AM_DEFAULT_VERBOSITY=m4_if([$1], [yes], [0], [1]);; esac dnl dnl A few 'make' implementations (e.g., NonStop OS and NextStep) dnl do not support nested variable expansions. dnl See automake bug#9928 and bug#10237. am_make=${MAKE-make} AC_CACHE_CHECK([whether $am_make supports nested variables], [am_cv_make_support_nested_variables], [if AS_ECHO([['TRUE=$(BAR$(V)) BAR0=false BAR1=true V=1 am__doit: @$(TRUE) .PHONY: am__doit']]) | $am_make -f - >/dev/null 2>&1; then am_cv_make_support_nested_variables=yes else am_cv_make_support_nested_variables=no fi]) if test $am_cv_make_support_nested_variables = yes; then dnl Using '$V' instead of '$(V)' breaks IRIX make. AM_V='$(V)' AM_DEFAULT_V='$(AM_DEFAULT_VERBOSITY)' else AM_V=$AM_DEFAULT_VERBOSITY AM_DEFAULT_V=$AM_DEFAULT_VERBOSITY fi AC_SUBST([AM_V])dnl AM_SUBST_NOTMAKE([AM_V])dnl AC_SUBST([AM_DEFAULT_V])dnl AM_SUBST_NOTMAKE([AM_DEFAULT_V])dnl AC_SUBST([AM_DEFAULT_VERBOSITY])dnl AM_BACKSLASH='\' AC_SUBST([AM_BACKSLASH])dnl _AM_SUBST_NOTMAKE([AM_BACKSLASH])dnl ]) # Copyright (C) 2001-2020 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-2020 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]) # AM_SUBST_NOTMAKE(VARIABLE) # -------------------------- # Public sister of _AM_SUBST_NOTMAKE. AC_DEFUN([AM_SUBST_NOTMAKE], [_AM_SUBST_NOTMAKE($@)]) # Check how to create a tarball. -*- Autoconf -*- # Copyright (C) 2004-2020 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_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. Yes, it's still used # in the wild :-( We should find a proper way to deprecate it ... AC_SUBST([AMTAR], ['$${TAR-tar}']) # We'll loop over all known methods to create a tar archive until one works. _am_tools='gnutar m4_if([$1], [ustar], [plaintar]) pax cpio none' m4_if([$1], [v7], [am__tar='$${TAR-tar} chof - "$$tardir"' am__untar='$${TAR-tar} xf -'], [m4_case([$1], [ustar], [# The POSIX 1988 'ustar' format is defined with fixed-size fields. # There is notably a 21 bits limit for the UID and the GID. In fact, # the 'pax' utility can hang on bigger UID/GID (see automake bug#8343 # and bug#13588). am_max_uid=2097151 # 2^21 - 1 am_max_gid=$am_max_uid # The $UID and $GID variables are not portable, so we need to resort # to the POSIX-mandated id(1) utility. Errors in the 'id' calls # below are definitely unexpected, so allow the users to see them # (that is, avoid stderr redirection). am_uid=`id -u || echo unknown` am_gid=`id -g || echo unknown` AC_MSG_CHECKING([whether UID '$am_uid' is supported by ustar format]) if test $am_uid -le $am_max_uid; then AC_MSG_RESULT([yes]) else AC_MSG_RESULT([no]) _am_tools=none fi AC_MSG_CHECKING([whether GID '$am_gid' is supported by ustar format]) if test $am_gid -le $am_max_gid; then AC_MSG_RESULT([yes]) else AC_MSG_RESULT([no]) _am_tools=none fi], [pax], [], [m4_fatal([Unknown tar format])]) AC_MSG_CHECKING([how to create a $1 tar archive]) # Go ahead even if we have the value already cached. We do so because we # need to set the values for the 'am__tar' and 'am__untar' variables. _am_tools=${am_cv_prog_tar_$1-$_am_tools} 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-3.1.2/test-set/0000755000175000017500000000000014361065617011722 500000000000000algol68g-3.1.2/test-set/09-hamming.a680000644000175000017500000000432314361065331014023 00000000000000COMMENT This program is part of the Algol 68 Genie test set. A small selection of the Algol 68 Genie regression test set is distributed with Algol 68 Genie. The purpose of those programs is to perform some checks to judge whether A68G behaves as expected. None of these programs should end ungraciously with for instance an addressing fault. COMMENT PR quiet regression PR COMMENT After the program published on rosettacode.org by Marcel van der Veer. COMMENT PR precision=100 PR MODE SERIES = FLEX [1 : 0] UNT, # Initially, no elements # UNT = LONG LONG INT; # A 100-digit unsigned integer # PROC hamming number = (INT n) UNT: # The n-th Hamming number # CASE n IN 1, 2, 3, 4, 5, 6, 8, 9, 10, 12 # First 10 in a table # OUT # Additional operators # OP MIN = (INT i, j) INT: (i < j | i | j), MIN = (UNT i, j) UNT: (i < j | i | j); PRIO MIN = 9; OP LAST = (SERIES h) UNT: h[UPB h]; # Last element of a series # OP +:= = (REF SERIES s, UNT elem) VOID: # Extend a series by one element, only keep the elements you need # (INT lwb = (i MIN j) MIN k, upb = UPB s; sweep heap; # If the GC is botched, a68g will sigsegv # REF SERIES new s = HEAP FLEX [lwb : upb + 1] UNT; (new s[lwb : upb] := s[lwb : upb], new s[upb + 1] := elem); s := new s ); # Determine the n-th hamming number iteratively # SERIES h := 1, # Series, initially one element # UNT m2 := 2, m3 := 3, m5 := 5, # Multipliers # INT i := 1, j := 1, k := 1; # Counters # TO n - 1 DO h +:= (m2 MIN m3) MIN m5; (LAST h = m2 | m2 := 2 * h[i +:= 1]); (LAST h = m3 | m3 := 3 * h[j +:= 1]); (LAST h = m5 | m5 := 5 * h[k +:= 1]) OD; LAST h ESAC; FOR k FROM 10 BY 10 TO 90 DO print ((whole (k, 0), " = ", whole (hamming number (k), 0), new line)) OD; CO Only for machines with ample RAM! FOR k FROM 100 BY 100 TO 900 DO print ((whole (k, 0), " = ", whole (hamming number (k), 0), new line)) OD; FOR k FROM 1000 BY 1000 TO 3000 DO sweep heap; print ((whole (k, 0), " = ", whole (hamming number (k), 0), new line)) OD; CO algol68g-3.1.2/test-set/12-mandelbrot.a680000644000175000017500000000332314361065331014523 00000000000000COMMENT This program is part of the Algol 68 Genie test set. A small selection of the Algol 68 Genie regression test set is distributed with Algol 68 Genie. The purpose of those programs is to perform some checks to judge whether A68G behaves as expected. None of these programs should end ungraciously with for instance an addressing fault. COMMENT PR quiet regression PR # Plot (part of) the Mandelbrot set, that are points z[0] in the complex plane for which the sequence z[n+1] := z[n] ** 2 + z[0] (n >= 0) is bounded. # PR need plotutils PR INT pix = 300, max iter = 256, REAL zoom = 0.33 / pix; [-pix : pix, -pix : pix] INT plane; COMPL ctr = 0.05 I 0.75 # center of set #; # Compute the length of an orbit. # PROC iterate = (COMPL z0) INT: BEGIN COMPL z := z0, INT iter := 1; WHILE (iter +:= 1) < max iter # not converged # AND ABS z < 2 # not diverged # DO z := z * z + z0 OD; iter END; # Compute set and find maximum orbit length. # INT max col := 0; FOR x FROM -pix TO pix DO FOR y FROM -pix TO pix DO COMPL z0 = ctr + (x * zoom) I (y * zoom); IF (plane [x, y] := iterate (z0)) < max iter THEN (plane [x, y] > max col | max col := plane [x, y]) FI OD OD; # Make a plot. # FILE plot; INT num pix = 2 * pix + 1; open (plot, "mandelbrot.gif", stand draw channel); make device (plot, "gif", whole (num pix, 0) + "x" + whole (num pix, 0)); FOR x FROM -pix TO pix DO FOR y FROM -pix TO pix DO INT col = (plane [x, y] > max col | max col | plane [x, y]); REAL c = sqrt (1- col / max col); # sqrt to enhance contrast # draw colour (plot, c, c, c); draw point (plot, (x + pix) / (num pix - 1), (y + pix) / (num pix - 1)) OD OD; close (plot) algol68g-3.1.2/test-set/21-rationals.a680000644000175000017500000000527614361065331014401 00000000000000COMMENT This program is part of the Algol 68 Genie test set. A small selection of the Algol 68 Genie regression test set is distributed with Algol 68 Genie. The purpose of those programs is to perform some checks to judge whether A68G behaves as expected. None of these programs should end ungraciously with for instance an addressing fault. COMMENT PR quiet regression PR COMMENT Find rational approximation to a given real number. After an algorithm of David Eppstein. Based on the theory of continued fractions: IF x = a1 + 1/(a2 + 1/(a3 + 1/(a4 + ...))) THEN the best approximation is found by truncating this series (with some adjustments in the last term). Note the fraction can be recovered as the first column of the matrix ( a1 1 ) ( a2 1 ) ( a3 1 ) ... ( 1 0 ) ( 1 0 ) ( 1 0 ) Instead of keeping the sequence of continued fraction terms, we just keep the last partial product of these matrices. COMMENT PROC show = (LONG LONG REAL nom, den, val) VOID: print ((new line, 3 * blank, whole(nom, 0), " / ", whole(den, 0), new line, 3 * blank, " = ", fixed (nom / den, 0, long real width), 3 * blank, " +- ", fixed (nom / den - val, 0, long real width))); PROC approx = (LONG LONG REAL val, LONG LONG INT max den) VOID: BEGIN [0 .. 1][0 .. 1] LONG LONG REAL m; LONG LONG REAL x := val; LONG LONG INT ai; # initialize matrix # m[0][0] := m[1][1] := 1; m[0][1] := m[1][0] := 0; # loop finding terms until denom gets too large # WHILE m[1][0] * (ai := ENTIER x) + m[1][1] <= max den DO LONG LONG INT t := ENTIER (m[0][0] * ai + m[0][1]); m[0][1] := m[0][0]; m[0][0] := t; t := ENTIER (m[1][0] * ai + m[1][1]); m[1][1] := m[1][0]; m[1][0] := t; x := 1 / (x - ai) OD; # now remaining x is between 0 and 1 / ai approx as either 0 or 1 / m where m is max that will fit in max den first try zero # show (m[0][0], m[1][0], val); # now try other possibility # ai := ENTIER ((maxden - m[1][1]) / m[1][0]); m[0][0] := m[0][0] * ai + m[0][1]; m[1][0] := m[1][0] * ai + m[1][1]; show (m[0][0], m[1][0], val); new line (stand out) END; PROC fractional = (LONG REAL val) VOID: BEGIN print (("Rational approximations for ", fixed (val, 0, long real width))); approx (val, 1000); approx (val, max int OVER 10); approx (val, long max int OVER 10) END; fractional (long pi); fractional (long sqrt (2)); new line (stand out) algol68g-3.1.2/test-set/08-guldens.a680000644000175000017500000000174114361065331014044 00000000000000COMMENT This program is part of the Algol 68 Genie test set. A small selection of the Algol 68 Genie regression test set is distributed with Algol 68 Genie. The purpose of those programs is to perform some checks to judge whether A68G behaves as expected. None of these programs should end ungraciously with for instance an addressing fault. COMMENT PR quiet regression PR # Op hoeveel manieren is 5 gulden te verdelen in rijksdaalders, guldens, kwartjes, dubbeltjes en stuivers? # PR echo "correct: 1441" PR PROC verdeel en tel = (INT bedrag, max) INT: IF bedrag = 0 THEN 1 # Precies goed, combinatie gevonden # ELIF bedrag < 0 THEN 0 # Ai, teveel afgetrokken, ongeldig # ELSE [] INT waarden = (5, 10, 25, 100, 250); INT aantal := 0; FOR i TO UPB waarden WHILE waarden[i] <= max DO aantal +:= verdeel en tel (bedrag - waarden[i], waarden[i]) OD; aantal FI; INT waarde = 500; print (verdeel en tel (waarde, waarde)) algol68g-3.1.2/test-set/03-digits.a680000644000175000017500000000143114361065331013655 00000000000000COMMENT This program is part of the Algol 68 Genie test set. A small selection of the Algol 68 Genie regression test set is distributed with Algol 68 Genie. The purpose of those programs is to perform some checks to judge whether A68G behaves as expected. None of these programs should end ungraciously with for instance an addressing fault. COMMENT PR quiet regression PR PR precision=5000 PR [999] BOOL b; FOR k TO 999 DO b[k] := FALSE OD; STRING z = fixed (1 / LONG LONG 998001, 0, 5000); INT k := 5; TO 998 WHILE k + 2 < UPB z DO STRING t = z[k : k + 2]; INT n = (ABS t[1] - ABS "0") * 100 + (ABS t[2] - ABS "0") * 10 + (ABS t[3] - ABS "0"); b[n] := TRUE; k +:= 3 OD; FOR k TO 999 DO IF ~ b[k] THEN print ((whole (k, 0), " is not in the series", new line)) FI OD algol68g-3.1.2/test-set/04-end-of-time.a680000644000175000017500000000243314361065331014502 00000000000000COMMENT This program is part of the Algol 68 Genie test set. A small selection of the Algol 68 Genie regression test set is distributed with Algol 68 Genie. The purpose of those programs is to perform some checks to judge whether A68G behaves as expected. None of these programs should end ungraciously with for instance an addressing fault. COMMENT PR quiet regression PR PR echo "This test will take a long time ... " PR # The legends of "The towers of Hanoi" or "Tower of Brahma" (both being modern fiction) state that when a stack of 100 disks has been moved disk-by-disk from one stack to a second using a third (under condition that a disk never sits on a smaller one), the end of time will have come. For labouring monks, that amounts to order 10^22 years. Let's see how long the universe has left when a modern computer moves the disks. # BOOL good := FALSE; FOR i FROM 25 WHILE NOT good DO PROC move = (INT n, u, v, w) VOID: IF n = 1 THEN moves +:= 1 ELSE move (n - 1, u, w, v); moves +:= 1; move (n - 1, w, v, u) FI; INT moves := 0; REAL clock = cpu time; move (i, 1, 2, 3); REAL diff = cpu time - clock; IF good := diff > 10 THEN printf (($l"disks: "g(0)", moves per second: "h(1)l$, i, moves / diff)) FI OD algol68g-3.1.2/test-set/10-hilbert.a680000644000175000017500000002520414361065331014025 00000000000000COMMENT This program is part of the Algol 68 Genie test set. A small selection of the Algol 68 Genie regression test set is distributed with Algol 68 Genie. The purpose of those programs is to perform some checks to judge whether A68G behaves as expected. None of these programs should end ungraciously with for instance an addressing fault. COMMENT PR quiet regression PR COMMENT An application for multi-precision LONG LONG INT. Calculate the determinant of Hilbert matrices using fractions. A comprehensive implementation of fractions is in the MC Algol 68 test set (appl08). COMMENT BEGIN # Data structure. # MODE FRAC = STRUCT (LINT n, d), LINT = LONG INT; OP NOM = (FRAC u) LINT: n OF u, DEN = (FRAC u) LINT: d OF u; PR precision 101 PR # Now LINT holds a googol. # # Basic operations. # OP RECIPROCAL = (LINT i) FRAC: IF i >= 0 THEN (1, i) ELSE (-1, -i) FI; OP - = (FRAC u) FRAC: (-NOM u, DEN u); OP + = (FRAC u, FRAC v) FRAC: BEGIN LINT k = DEN u GCD DEN v; LINT du = DEN u OVER k, dv = DEN v OVER k; LINT n = NOM u * dv + NOM v * du; LINT l = n GCD k, d = dv * du; (n OVER l, k OVER l * d) END; OP +:= = (REF FRAC u, FRAC v) REF FRAC: u := u + v; OP - = (FRAC u, FRAC v) FRAC: BEGIN LINT k = DEN u GCD DEN v; LINT du = DEN u OVER k, dv = DEN v OVER k; LINT n = NOM u * dv - NOM v * du; LINT l = n GCD k, d = dv * du; (n OVER l, k OVER l * d) END; OP -:= = (REF FRAC u, FRAC v) REF FRAC: u := u - v; OP * = (FRAC u, v) FRAC: BEGIN LINT i = NOM u GCD DEN v, j = NOM v GCD DEN u; ((NOM u OVER i) * (NOM v OVER j), (DEN u OVER j) * (DEN v OVER i)) END; OP *:= = (REF FRAC u, FRAC v) REF FRAC: u := u * v; OP / = (FRAC u, FRAC v) FRAC: IF LINT i = NOM u GCD NOM v, j = DEN v GCD DEN u; NOM v >= 0 THEN ((NOM u OVER i) * (DEN v OVER j), (DEN u OVER j) * (NOM v OVER i)) ELSE (- (NOM u OVER i) * (DEN v OVER j), - (DEN u OVER j) * (NOM v OVER i)) FI; OP /:= = (REF FRAC u, FRAC v) REF FRAC: u := u / v; # Comparing rationals with integrals. # OP = = (FRAC u, LINT i) BOOL: NOM u = i ANDF DEN u = 1; OP /= = (FRAC u, LINT i) BOOL: NOT (u = i); # Matrix algebra. # OP INNER = ([] FRAC u, v) FRAC: # Innerproduct of two arrays of rationals # BEGIN FRAC s := (0, 1); FOR i TO UPB u DO s +:= u[i] * v[i] OD; s END; PRIO INNER = 8; PROC lu decomposition = (REF [, ] FRAC a, REF [] INT p) VOID: # LU-decomposition cf. Crout, of a matrix of rationals. # BEGIN INT n = 1 UPB a; FOR k TO n DO FRAC piv := (0, 1), INT k1 := k - 1; REF INT pk = p[k]; REF [] FRAC aik = a[, k], aki = a[k,]; FOR i FROM k TO n DO aik[i] -:= a[i, 1 : k1] INNER aik[1 : k1]; IF piv = LINT (0) AND aik[i] /= LINT (0) THEN piv := aik[i]; pk := i FI OD; IF piv = LINT (0) THEN print((newline, newline, "Singular matrix")); stop FI; IF pk /= k THEN FOR i TO n DO FRAC 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] INNER a[1 : k1, i] /:= piv OD OD END; PROC determinant = ([,] FRAC a) FRAC: # Determinant of a decomposed matrix is its trace. # BEGIN FRAC d := (1, 1); FOR i TO 1 UPB a DO d *:= a[i, i] OD; d END; # Recursive definition of greatest common divisor. # OP GCD = (LINT a, b) LINT: IF b = 0 THEN ABS a ELSE b GCD (a MOD b) FI; PRIO GCD = 8; # Table of required results. # [] LINT table = BEGIN LONG 1, LONG 12, LONG 2160, LONG 6048000, LONG 266716800000, LONG 186313420339200000, LONG 2067909047925770649600000, LONG 365356847125734485878112256000000 END; # Compute determinant of Hilbert matrix of increasing rank. # printf(($"Determinant of the Hilbert matrix - LONG INT"$)); FOR n TO UPB table DO [1 : n, 1 : n] FRAC a; FOR i TO n DO a[i,i] := RECIPROCAL LINT (i * 2 - 1); FOR j FROM i + 1 TO n DO a[i, j] := a[j, i] := RECIPROCAL LINT (i + j - 1) OD OD; lu decomposition(a, LOC [1 : n] INT); FORMAT small int = $2z-d$, huge int = $z","3z","3z","3z","3z","3z","3z","3z","3z","3z","3z"," 3z","3z","3z","3z","3z","3z","3z","2z-d$; FRAC det = determinant (a); printf(($2l"Order : "$, small int, n)); printf(($l "Result: "$, small int, NOM det, $" / "$, huge int, DEN det)); printf(($l "Table : "$, small int, 1, $" / "$, huge int, table[n])) OD; new line (standout) END; BEGIN # Data structure. # MODE FRAC = STRUCT (LINT n, d), LINT = LONG LONG INT; OP NOM = (FRAC u) LINT: n OF u, DEN = (FRAC u) LINT: d OF u; PR precision 101 PR # Now LINT holds a googol. # # Basic operations. # OP RECIPROCAL = (LINT i) FRAC: IF i >= 0 THEN (1, i) ELSE (-1, -i) FI; OP - = (FRAC u) FRAC: (-NOM u, DEN u); OP + = (FRAC u, FRAC v) FRAC: BEGIN LINT k = DEN u GCD DEN v; LINT du = DEN u OVER k, dv = DEN v OVER k; LINT n = NOM u * dv + NOM v * du; LINT l = n GCD k, d = dv * du; (n OVER l, k OVER l * d) END; OP +:= = (REF FRAC u, FRAC v) REF FRAC: u := u + v; OP - = (FRAC u, FRAC v) FRAC: BEGIN LINT k = DEN u GCD DEN v; LINT du = DEN u OVER k, dv = DEN v OVER k; LINT n = NOM u * dv - NOM v * du; LINT l = n GCD k, d = dv * du; (n OVER l, k OVER l * d) END; OP -:= = (REF FRAC u, FRAC v) REF FRAC: u := u - v; OP * = (FRAC u, v) FRAC: BEGIN LINT i = NOM u GCD DEN v, j = NOM v GCD DEN u; ((NOM u OVER i) * (NOM v OVER j), (DEN u OVER j) * (DEN v OVER i)) END; OP *:= = (REF FRAC u, FRAC v) REF FRAC: u := u * v; OP / = (FRAC u, FRAC v) FRAC: IF LINT i = NOM u GCD NOM v, j = DEN v GCD DEN u; NOM v >= 0 THEN ((NOM u OVER i) * (DEN v OVER j), (DEN u OVER j) * (NOM v OVER i)) ELSE (- (NOM u OVER i) * (DEN v OVER j), - (DEN u OVER j) * (NOM v OVER i)) FI; OP /:= = (REF FRAC u, FRAC v) REF FRAC: u := u / v; # Comparing rationals with integrals. # OP = = (FRAC u, LINT i) BOOL: NOM u = i ANDF DEN u = 1; OP /= = (FRAC u, LINT i) BOOL: NOT (u = i); # Matrix algebra. # OP INNER = ([] FRAC u, v) FRAC: # Innerproduct of two arrays of rationals # BEGIN FRAC s := (0, 1); FOR i TO UPB u DO s +:= u[i] * v[i] OD; s END; PRIO INNER = 8; PROC lu decomposition = (REF [, ] FRAC a, REF [] INT p) VOID: # LU-decomposition cf. Crout, of a matrix of rationals. # BEGIN INT n = 1 UPB a; FOR k TO n DO FRAC piv := (0, 1), INT k1 := k - 1; REF INT pk = p[k]; REF [] FRAC aik = a[, k], aki = a[k,]; FOR i FROM k TO n DO aik[i] -:= a[i, 1 : k1] INNER aik[1 : k1]; IF piv = LINT (0) AND aik[i] /= LINT (0) THEN piv := aik[i]; pk := i FI OD; IF piv = LINT (0) THEN print((newline, newline, "Singular matrix")); stop FI; IF pk /= k THEN FOR i TO n DO FRAC 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] INNER a[1 : k1, i] /:= piv OD OD END; PROC determinant = ([,] FRAC a) FRAC: # Determinant of a decomposed matrix is its trace. # BEGIN FRAC d := (1, 1); FOR i TO 1 UPB a DO d *:= a[i, i] OD; d END; # Recursive definition of greatest common divisor. # OP GCD = (LINT a, b) LINT: IF b = 0 THEN ABS a ELSE b GCD (a MOD b) FI; PRIO GCD = 8; # Table of required results. # [] LINT table = BEGIN LONG LONG 1, LONG LONG 12, LONG LONG 2160, LONG LONG 6048000, LONG LONG 266716800000, LONG LONG 186313420339200000, LONG LONG 2067909047925770649600000, LONG LONG 365356847125734485878112256000000, LONG LONG 1028781784378569697887052962909388800000000, LONG LONG 46206893947914691316295628839036278726983680000000000 END; # Compute determinant of Hilbert matrix of increasing rank. # printf(($"Determinant of the Hilbert matrix - LONG LONG INT"$)); FOR n TO UPB table DO [1 : n, 1 : n] FRAC a; FOR i TO n DO a[i,i] := RECIPROCAL LINT (i * 2 - 1); FOR j FROM i + 1 TO n DO a[i, j] := a[j, i] := RECIPROCAL LINT (i + j - 1) OD OD; lu decomposition(a, LOC [1 : n] INT); FORMAT small int = $2z-d$, huge int = $z","3z","3z","3z","3z","3z","3z","3z","3z","3z","3z"," 3z","3z","3z","3z","3z","3z","3z","2z-d$; FRAC det = determinant (a); printf(($2l"Order : "$, small int, n)); printf(($l "Result: "$, small int, NOM det, $" / "$, huge int, DEN det)); printf(($l "Table : "$, small int, 1, $" / "$, huge int, table[n])) OD; new line (standout) END algol68g-3.1.2/test-set/11-lisp.a680000644000175000017500000001260514361065331013345 00000000000000# Commands for this miniature LISP interpreter 1 2 3 4 append ( 1 2 ) ( 3 4 ) + 1 ( * 2 3 ) quit # COMMENT This program is part of the Algol 68 Genie test set. A small selection of the Algol 68 Genie regression test set is distributed with Algol 68 Genie. The purpose of those programs is to perform some checks to judge whether A68G behaves as expected. None of these programs should end ungraciously with for instance an addressing fault. COMMENT PR quiet regression PR # Data structure to represent a list # MODE NUMBER = LONG INT, VALUE = UNION (ATOM, LIST), ATOM = STRING, LIST = REF NODE, NODE = STRUCT (VALUE car, cdr); LIST nil = NIL; PROC error = (STRING t) VOID: print ((new line, "error: ", t)); PROC is atom = (VALUE v) BOOL: (v | (ATOM): TRUE | FALSE); PROC is nil = (VALUE v) BOOL: (v | (LIST l): l :=: nil | FALSE); PROC value to number = (VALUE v) NUMBER: CASE v IN (ATOM a): BEGIN NUMBER sum := 0, weight := 1; FOR i FROM UPB a BY -1 TO LWB a DO sum +:= weight * (ABS a[i] - ABS "0"); weight *:= 10 OD; sum END, (LIST l): (is nil (l) | error ("numeral of nil"); 0 | value to number (CAR l)) ESAC; PROC number to atom = (NUMBER n) ATOM: whole (n, 0); OP CONS = (VALUE v, w) VALUE: HEAP NODE := (v, w); PRIO CONS = 9; OP + = (VALUE v, w) VALUE: CASE v IN (ATOM a): v CONS (w | (ATOM): w, (LIST): CAR w), (LIST k): IF is nil (k) THEN w ELIF is nil (CDR k) THEN CAR k CONS (w | (ATOM): w, (LIST): CAR w) ELSE CAR k CONS (CDR k + w) FI ESAC; OP CAR = (VALUE v) VALUE: CASE v IN (ATOM): (error ("car of atom"); nil), (LIST l): (l :=: nil | error ("car of nil"); nil | car OF l) ESAC; OP CDR = (VALUE v) VALUE: CASE v IN (ATOM): (error ("cdr of atom"); nil), (LIST l): (l :=: nil | error ("cdr of nil"); nil | cdr OF l) ESAC; OP EQ = (VALUE v, w) BOOL: CASE v IN (ATOM a): (w | (ATOM b): a = b | FALSE), (LIST l): (w | (LIST k): l :=: k | FALSE) ESAC; PROC print list = (LIST l) VOID: CASE print value (CAR l); CDR l IN (ATOM a): (print (blank); print value (a)), (LIST k): (~ is nil (k) | print (blank); print list (k)) ESAC; PROC print value = (VALUE v) VOID: CASE v IN (ATOM a): print (a), (LIST l): (is nil (l) | print ("nil") | (print ("("); print list (l); print (")"))) ESAC; PROC interpreter = (ATOM cmd, VALUE args) VALUE: IF cmd = "'" THEN CAR args ELIF cmd = "+" THEN number to atom (value to number (evaluate (CAR args)) + value to number (evaluate (CDR args))) ELIF cmd = "-" THEN number to atom (value to number (evaluate (CAR args)) - value to number (evaluate (CDR args))) ELIF cmd = "*" THEN number to atom (value to number (evaluate (CAR args)) * value to number (evaluate (CDR args))) ELIF cmd = "/" THEN number to atom (value to number (evaluate (CAR args)) OVER value to number (evaluate (CDR args))) ELIF cmd = "append" THEN CAR args + CDR args ELIF cmd = "evaluate" THEN evaluate (args) ELIF cmd = "quit" THEN stop ELSE cmd CONS args FI; PROC evaluate = (VALUE v) VALUE: CASE v IN (ATOM a): a, (LIST k): IF is nil (k) THEN nil ELSE CASE CAR k IN (ATOM a): interpreter (a, CDR k), (LIST l): evaluate (CAR k) CONS evaluate (CDR k) ESAC FI ESAC; # Construct a list # MODE STACK = STRUCT (STRING elem, REF STACK next); REF STACK stack := NIL; PROC pop = VOID: stack := next OF stack; PROC push = (STRING s) VOID: stack := HEAP STACK := (s, stack); PROC top = STRING: elem OF stack; PROC parse stack = VALUE: IF stack :=: REF STACK (NIL) THEN nil ELIF top = "(" THEN pop; VALUE left value := parse stack; left value CONS parse stack ELIF top = ")" THEN pop; nil ELSE VALUE left value := HEAP ATOM := top; pop; left value CONS parse stack FI; # In this case we parse from a string # PROC parse string = (STRING s) VALUE: BEGIN stack := NIL; INT i := UPB s; WHILE i > LWB s DO WHILE i > LWB s ANDF s[i] = " " DO i -:= 1 OD; INT j = i; WHILE i > LWB s ANDF s[i] ~= " " DO i -:= 1 OD; IF i + 1 <= j THEN push (s[i + 1 .. j]) FI OD; parse stack END; # A test program # FILE f; VOID (open (f, program idf, standin channel)); get (f, new line); DO STRING s; get (f, (s, new line)); VALUE l := parse string (blank + s); print (">"); print value (l); new line (stand out); print value (evaluate (l)); new line (stand out) OD algol68g-3.1.2/test-set/19-queens.a680000644000175000017500000000251314361065331013703 00000000000000COMMENT This program is part of the Algol 68 Genie test set. A small selection of the Algol 68 Genie regression test set is distributed with Algol 68 Genie. The purpose of those programs is to perform some checks to judge whether A68G behaves as expected. None of these programs should end ungraciously with for instance an addressing fault. COMMENT PR quiet regression PR CO n queens in classic backtracker CO BEGIN INT rank = 8; printf (($"Rank="g(0)l$, rank)); [1 : rank] CCOL column, INT sols found := 0; PROC place from = (CROW this row) VOID: IF this row > rank THEN sols found +:= 1; FOR row TO rank DO print(("abcdefghijklmnopqrstuvwxyz"[row], whole(column[row], 0), " ")) OD; print ((sols found MOD 4 = 0 | new line | " ")) ELSE FOR i TO rank DO IF BOOL safe := TRUE; FOR j TO this row - 1 WHILE safe DO safe := safe AND NOT (column[j] = i ORF (column[j] - i = this row - j ORF column[j] - i = j - this row)) OD; safe THEN column[this row] := i; place from (this row + 1) FI OD FI; place from (1); MODE CROW = INT, CCOL = INT; SKIP END algol68g-3.1.2/test-set/20-quicksort.a680000644000175000017500000000221514361065331014416 00000000000000COMMENT This program is part of the Algol 68 Genie test set. A small selection of the Algol 68 Genie regression test set is distributed with Algol 68 Genie. The purpose of those programs is to perform some checks to judge whether A68G behaves as expected. None of these programs should end ungraciously with for instance an addressing fault. COMMENT PR quiet regression PR BEGIN MODE TREE = REF NODE, NODE = STRUCT (INT k, TREE s, l); TREE empty = NIL, PROC tree = (INT k) TREE: HEAP NODE := (k, NIL, NIL); OP PRINT = (TREE t) VOID: IF t ISNT empty THEN PRINT s OF t; print ((whole (k OF t, 0), " ")); PRINT l OF t FI; OP +:= = (REF TREE t, INT k) VOID: IF t IS empty THEN t := tree (k) ELSE (k < k OF t | s OF t | l OF t) +:= k FI; TREE list := empty; list +:= 128; list +:= 16; list +:= 1; list +:= 512; list +:= 4; list +:= 64; list +:= 8; list +:= 2; list +:= 256; list +:= 32; PRINT list; new line (standout) END algol68g-3.1.2/test-set/16-procedures.a680000644000175000017500000000314514361065331014555 00000000000000COMMENT This program is part of the Algol 68 Genie test set. A small selection of the Algol 68 Genie regression test set is distributed with Algol 68 Genie. The purpose of those programs is to perform some checks to judge whether A68G behaves as expected. None of these programs should end ungraciously with for instance an addressing fault. COMMENT PR quiet regression PR # Partial parametrisation. # BEGIN # Raising a routine to a power # MODE FUN = PROC (LONG LONG REAL) LONG LONG REAL; PROC pow = (FUN f, INT n, LONG LONG REAL x) LONG LONG REAL: f (x) ** n; OP ** = (FUN f, INT n) FUN: pow (f, n, ); # Example: sin (3 x) = 3 sin (x) - 4 sin ** 3 (x), from DeMoivre's theorem # LONG LONG REAL x = long long pi / 4; print ((long long sin (3 * x), new line, 3 * long long sin (x) - 4 * (long long sin ** 3) (x), new line)); END; # Simple backtracking. How many ways are there to split 5 euros in 2 euro, 1 euro, 50 ct, 20 ct, 10 ct, 5 ct? # BEGIN [] INT values = (5, 10, 20, 50, 100, 200); PROC count = (INT rest, max) INT: IF rest = 0 THEN 1 # Just right, combination found # ELIF rest < 0 THEN 0 # Invalid, subtracted too much # ELSE INT combinations := 0; FOR i TO UPB values WHILE values[i] <= max DO combinations +:= count (rest - values[i], values[i]) OD; combinations FI; INT amount = 500 # cts #; print (("Number of ways to split ", whole (amount, 0), " into coins: ", whole (count (amount, amount), 0), new line)) END algol68g-3.1.2/test-set/06-fibonacci-grammar.a680000644000175000017500000000271514361065331015744 00000000000000COMMENT This program is part of the Algol 68 Genie test set. A small selection of the Algol 68 Genie regression test set is distributed with Algol 68 Genie. The purpose of those programs is to perform some checks to judge whether A68G behaves as expected. None of these programs should end ungraciously with for instance an addressing fault. COMMENT PR quiet regression PR COMMENT This example computes Fibonacci numbers by counting the number of derivations of the "Fibonacci grammar": fib: "a"; "a", fib; "aa", fib. The purpose is to illustrate the use of procedure closures which we call continuations. We use this to generate a recursive descent with backup parser following a simple translation from grammar rules to procedures. This program was contributed by Eric Voss and simplified/modified by Erwin Koning and Marcel van der Veer. COMMENT PROC grammar fib = (INT i, STRING s, CONT q) VOID: BEGIN terminal (i, "a", s, q); terminal (i, "a", s, (INT j) VOID: grammar fib (j, s, q)); terminal (i, "aa", s, (INT j) VOID: grammar fib (j, s, q)) END; PROC terminal = (INT i, STRING a, s, CONT q) VOID: (INT u = i + UPB a; u <= UPB s | q (u)); MODE CONT = PROC (INT) VOID; FOR k TO 10 DO STRING sentence = k * "a"; INT nr derivations := 0; grammar fib (0, sentence, (INT j) VOID: (j = UPB sentence | nr derivations +:= 1)); print (("Fibonacci number ", UPB sentence, " = ", nr derivations, new line)) OD algol68g-3.1.2/test-set/15-mersenne.a680000644000175000017500000000146214361065331014215 00000000000000COMMENT This program is part of the Algol 68 Genie test set. A small selection of the Algol 68 Genie regression test set is distributed with Algol 68 Genie. The purpose of those programs is to perform some checks to judge whether A68G behaves as expected. None of these programs should end ungraciously with for instance an addressing fault. COMMENT PR quiet regression PR CO Lucas-Lehmer Test: For p a prime, the Mersenne number 2**p-1 is prime iff 2**p-1 divides S(p-1) where S(n+1) = S(n)**2-2, and S(1)=4. CO PR precision=6800 timelimit=120 PR PR echo "This test will take a long time ... " PR INT k = 11213; CO Mersenne prime #23 CO LONG LONG INT cand = LONG LONG 2 ** k - 1, LONG LONG INT s := 4; FROM 3 TO k DO s := (s * s - 2) MOD cand OD; IF s = 0 THEN printf (($"M_"g(0)" is prime"l$, k)) FI algol68g-3.1.2/test-set/05-fft.a680000644000175000017500000000353414361065331013161 00000000000000COMMENT This program is part of the Algol 68 Genie test set. A small selection of the Algol 68 Genie regression test set is distributed with Algol 68 Genie. The purpose of those programs is to perform some checks to judge whether A68G behaves as expected. None of these programs should end ungraciously with for instance an addressing fault. COMMENT PR quiet regression PR PROC fft = (REF () LONG COMPLEX f, INT dir) VOID: IF COMMENT Unnormalised Fast Fourier Transform in recursive form: F (k) = F even (k) + exp (2 pi i k / n) * F odd (k). Parameter dir = +- 1 determines direction of the transform. Assume that the lower bound of f is zero, and that its length is a power of 2. COMMENT INT length = UPB f + 1; length > 1 THEN INT middle = length % 2; # Calculate transforms at sublevels # (0 .. middle - 1) LONG COMPLEX f even, f odd; FOR i FROM 0 TO middle - 1 DO f even (i) := f (2 * i); f odd (i) := f (2 * i + 1) OD; (fft (f even, dir), fft (f odd, dir)); # Calculate transform at this level # FOR k FROM 0 TO middle - 1 DO LONG REAL phi = dir * 2 * long pi * k / length; LONG COMPLEX factor = long cos (phi) I long sin (phi) * f odd (k); f (k) := f even (k) + factor; f (k + middle) := f even (k) - factor OD FI; # A trivial application for `fft' - calculate power spectrum # INT n = 32; (0 : n - 1) LONG COMPLEX f, (0 : n % 2 - 1) LONG REAL power; FOR i FROM 0 TO n - 1 DO f (i) := 0; FOR j BY 2 TO n % 2 - 1 DO f (i) +:= long sin (2 * long pi * i * j / n) / j OD OD; fft (f, 1); FOR i FROM 0 TO n % 2 - 1 DO power (i) := ABS f (i) / (n % 2) OD; printf (($lg$, power)); new line (stand out) algol68g-3.1.2/test-set/18-qgammainc.a680000644000175000017500000000215614361065331014342 00000000000000COMMENT This program is part of the Algol 68 Genie test set. A small selection of the Algol 68 Genie regression test set is distributed with Algol 68 Genie. The purpose of those programs is to perform some checks to judge whether A68G behaves as expected. None of these programs should end ungraciously with for instance an addressing fault. COMMENT PR quiet regression PR PR quiet regression PR PR need mpfr PR MODE NUM = LONG LONG REAL; REAL f, g, max dev := 0; (f := 1e-1, g := 1e-1); FOR k TO 1000 DO NUM s = f + next random * g, x = f + next random * g; NUM a68g = qgammainc(s, x), mpfr = mpfr qgammainc(s, x); # print ((a68g, blank, mpfr, newline)); # IF REAL dev = SHORTEN SHORTEN ((a68g - mpfr) / mpfr); dev > max dev THEN max dev := dev FI OD; (f := 1e-1, g := 1e3); TO 1000 DO NUM s = f + next random * g, x = f + next random * g; NUM a68g = qgammainc(s, x), mpfr = mpfr qgammainc(s, x); # print ((a68g, blank, mpfr, newline)); # IF REAL dev = SHORTEN SHORTEN ((a68g - mpfr) / mpfr); dev > max dev THEN max dev := dev FI OD; print (("max dev = ", max dev, new line)); algol68g-3.1.2/test-set/14-math.a680000644000175000017500000001416114361065331013331 00000000000000COMMENT This program is part of the Algol 68 Genie test set. A small selection of the Algol 68 Genie regression test set is distributed with Algol 68 Genie. The purpose of those programs is to perform some checks to judge whether A68G behaves as expected. None of these programs should end ungraciously with for instance an addressing fault. COMMENT PR quiet regression PR BEGIN MODE FLOAT = LONG REAL; INT samples = 10 000; PROC check = (STRING txt, FLOAT lwb, upb, PROC (FLOAT) FLOAT f, f inv) VOID: BEGIN BOOL ok := TRUE; print ((newline, txt, space)); TO samples DO FLOAT x; WHILE x := lwb + (upb - lwb) * long next random; NOT (x > lwb AND x < upb) DO ~ OD; FLOAT y = f inv (f (x)); IF y ~= 0 ANDF ABS (x / y - 1) > 1e-6 THEN print (("Error at x=", x," f(x)=", y, new line)); ok := FALSE FI OD; printf (($x":-"b(")","(")$, ok)) END; FLOAT real max = 1e9; check ("long sqrt", 0, real max, long sqrt, (FLOAT x) FLOAT: x * x); check ("long cbrt", - real max / 3, real max / 3, long cbrt, (FLOAT x) FLOAT: x * x * x); check ("long sin ", - long pi / 2, long pi / 2, long sin, long arcsin); check ("long cos ", 0, long pi, long cos, long arccos); check ("long tan ", - long pi / 2, long pi / 2, long tan, long arctan); check ("long asin", - 1, 1, long arcsin, long sin); check ("long acos", - 1, 1, long arccos, long cos); check ("long atan", - real max, real max, long arctan, long tan); check ("long ln ", small real, real max, long ln, long exp); check ("long erf ", -3, 3, long erf, long inverf) END; BEGIN MODE FLOAT = LONG LONG REAL; INT samples = 5 000; PROC check = (STRING txt, FLOAT lwb, upb, PROC (FLOAT) FLOAT f, f inv) VOID: BEGIN BOOL ok := TRUE; print ((newline, txt, space)); TO samples DO FLOAT x; WHILE x := lwb + (upb - lwb) * long long next random; NOT (x > lwb AND x < upb) DO ~ OD; FLOAT y = f inv (f (x)); IF y ~= 0 ANDF ABS (x / y - 1) > 1e-6 THEN print (("Error at x=", x," f(x)=", y, new line)); ok := FALSE FI OD; printf (($x":-"b(")","(")$, ok)) END; FLOAT real max = 1e9; check ("long long sqrt", 0, real max, long long sqrt, (FLOAT x) FLOAT: x * x); check ("long long cbrt", - real max / 3, real max / 3, long long cbrt, (FLOAT x) FLOAT: x * x * x); check ("long long sin ", - long long pi / 2, long long pi / 2, long long sin, long long arcsin); check ("long long cos ", 0, long long pi, long long cos, long long arccos); check ("long long tan ", - long long pi / 2, long long pi / 2, long long tan, long long arctan); check ("long long asin", - 1, 1, long long arcsin, long long sin); check ("long long acos", - 1, 1, long long arccos, long long cos); check ("long long atan", - real max, real max, long long arctan, long long tan); check ("long long ln ", small real, real max, long long ln, long long exp); check ("long long erf ", -3, 3, long long erf, long long inverf) END; BEGIN MODE PERPLEX = LONG COMPLEX; INT samples = 10 000; PROC check = (STRING txt, PERPLEX lwb, upb, PROC (PERPLEX) PERPLEX f, f inv) VOID: BEGIN BOOL ok := TRUE; print ((newline, txt, space)); TO samples DO PERPLEX x := (RE lwb + (RE upb - RE lwb) * long next random) I (IM lwb + (IM upb - IM lwb) * long next random); PERPLEX y = f inv (f (x)); IF ABS x ~= 0 ANDF ABS (x - y) / ABS x > 1e-6 THEN print (("Error at x=", x," f(x)=", y, new line)); ok := FALSE FI OD; printf (($x":-"b(")","(")$, ok)) END; DOUBLE real max = 1e9; check ("long complex sqrt", small real I small real, real max I real max, long complex sqrt, (PERPLEX x) PERPLEX: x * x); check ("long complex sin ", 0, 0.5 I 0.5, long complex sin, long complex arcsin); check ("long complex cos ", 0, 0.5 I -0.5, long complex cos, long complex arccos); check ("long complex tan ", 0, 0.5 I 0.5, long complex tan, long complex arctan); check ("long complex ln ", small real I small real, real max I real max, long complex ln, long complex exp) END; BEGIN MODE PERPLEX = LONG LONG COMPLEX; INT samples = 5 000; PROC check = (STRING txt, PERPLEX lwb, upb, PROC (PERPLEX) PERPLEX f, f inv) VOID: BEGIN BOOL ok := TRUE; print ((newline, txt, space)); TO samples DO PERPLEX x := (RE lwb + (RE upb - RE lwb) * long long next random) I (IM lwb + (IM upb - IM lwb) * long long next random); PERPLEX y = f inv (f (x)); IF ABS x ~= 0 ANDF ABS (x - y) / ABS x > 1e-6 THEN print (("Error at x=", x," f(x)=", y, new line)); ok := FALSE FI OD; printf (($x":-"b(")","(")$, ok)) END; DOUBLE real max = 1e9; check ("long long complex sqrt", small real I small real, real max I real max, long long complex sqrt, (PERPLEX x) PERPLEX: x * x); check ("long long complex sin ", 0, 0.5 I 0.5, long long complex sin, long long complex arcsin); check ("long long complex cos ", 0, 0.5 I -0.5, long long complex cos, long long complex arccos); check ("long long complex tan ", 0, 0.5 I 0.5, long long complex tan, long long complex arctan); check ("long long complex ln ", small real I small real, real max I real max, long long complex ln, long long complex exp) END algol68g-3.1.2/test-set/22-semana-santa.a680000644000175000017500000000410514361065331014744 00000000000000COMMENT This program is part of the Algol 68 Genie test set. A small selection of the Algol 68 Genie regression test set is distributed with Algol 68 Genie. The purpose of those programs is to perform some checks to judge whether A68G behaves as expected. None of these programs should end ungraciously with for instance an addressing fault. COMMENT PR quiet regression PR printf (($"Fechas de la Semana Santa"$)); FOR a FROM 2001 TO 2100 DO # Domingo de Pascua - algoritmo de J.M. Oudin [1940] # INT c = a % 100, n = a %* 19; INT k := (c - 17) % 25; INT i := (c - c % 4 - (c - k) % 3 + 19 * n + 15) %* 30; i -:= (i % 28) * (1 - (i % 28) * (29 % (i + 1)) * ((21 - n) % 11)); INT j := (a + a % 4 + i + 2 - c + c % 4) %* 7; INT l = i - j; INT m := 3 + (l + 40) % 44, d := l + 28 - 31 * (m % 4); PROC pon fecha = (STRING festivo, INT a, m, d) VOID: BEGIN PROC dia de la semana = (INT a0, m0, d0) INT: # Algoritmo de Zeller [1887]. # BEGIN INT a := a0, m := m0, d := d0, c; (m <= 2 | m +:= 12; a -:= 1); c := a OVER 100; a %*:= 100; 1 + (d + ((m + 1) * 26) OVER 10 + a + a OVER 4 + c OVER 4 - 2 * c) %* 7 END; print f (($3xg" " c("Sab", "Dom", "Lun", "Mar", "Mie", "Jue", "Vie")z-dx c("Ene", "Feb", "Mar", "Abr", "May", "Jun", "Jul", "Ago", "Sep", "Oct", "Nov", "Dic")$, festivo, dia de la semana(a, m, d), d, m)) END; PROC bisiesto = (INT a) BOOL: a %* 4 = 0 AND a %* 400 /= 0; PROC ultimo = (INT a, m) INT: (m | 31, (bisiesto (a) | 28 | 29), 31, 30, 31, 30, 31, 31, 30, 31, 30, 31); PROC regresar = (INT dias) VOID: TO dias DO (d > 1 | d -:= 1 | m -:= 1; d := ultimo (a, m)) OD; PROC avanzar = (INT dias) VOID: TO dias DO d +:= 1; (d > ultimo (a, m) | d := 1; m +:= 1) OD; printf (($l4d$, a)); regresar (7); pon fecha ("Domingo de Ramos", a, m, d); avanzar (7); pon fecha ("Domingo de Pascua", a, m, d) OD; newline (stand out) algol68g-3.1.2/test-set/02-decision.a680000644000175000017500000000470314361065331014173 00000000000000# a dog no a cat meow yes yes no no a fish swim yes yes no yes yes no # COMMENT This program is part of the Algol 68 Genie test set. A small selection of the Algol 68 Genie regression test set is distributed with Algol 68 Genie. The purpose of those programs is to perform some checks to judge whether A68G behaves as expected. None of these programs should end ungraciously with for instance an addressing fault. COMMENT PR quiet regression PR CO Paradigm for building decision trees in Algol 68. We wrote programs like this for ALGOL68C on TOPS-20 and VM/CMS. CO BEGIN # Q&A game # VOID (open (standin, program idf, standin channel)); read (new line); CELL library := get answer("give an initial answer"); WHILE guess object(library); put question("again") DO SKIP OD; # Data structure # MODE CELL = UNION (STRING, FORK), FORK = STRUCT (STRING text, REF CELL has, hasnt); OP TEXT = (FORK d) STRING: text OF d, HAS = (FORK d) REF CELL: has OF d, HASNT = (FORK d) REF CELL: hasnt OF d; PROC new fork = (STRING text, CELL has, hasnt) FORK: (HEAP STRING := text, HEAP CELL := has, HEAP CELL := hasnt); # Guessing and extending library # PROC guess object = (REF CELL sub lib) VOID: # How to guess an object # CASE sub lib IN (STRING s): (put question("is it " + s) | SKIP | sub lib := learn(s)), (FORK d): guess object((put question("does it " + TEXT d) | HAS d | HASNT d)) ESAC; PROC learn = (STRING guess) CELL: # Introduce new cell in tree # IF STRING answer = get answer("what is the answer"), question = get answer("what distinguishes " + answer); put question("does '" + question + "' apply to '" + answer + "'") THEN new fork(question, answer, guess) ELSE new fork(question, guess, answer) FI; # Interaction # PROC get answer = (STRING prompt) STRING: BEGIN STRING s; printf(($g"?"l$, prompt)); readf(($gl$, s)); printf(($"> "gl$, s)); s END; PROC put question = (STRING question) BOOL: IF STRING s = get answer(question); UPB s > 0 THEN s[1] = "y" ORF s[1] = "Y" ELSE put question (question) FI; SKIP END algol68g-3.1.2/test-set/01-chaos.a680000644000175000017500000000171414361065331013471 00000000000000COMMENT This program is part of the Algol 68 Genie test set. A small selection of the Algol 68 Genie regression test set is distributed with Algol 68 Genie. The purpose of those programs is to perform some checks to judge whether A68G behaves as expected. None of these programs should end ungraciously with for instance an addressing fault. COMMENT PR quiet regression PR # May's population chaos # INT width = 80; FOR n TO 100 DO REAL r = 4 * n / 100, REAL x := 0.01; OP NEXT = (REF REAL x) REAL: x := r * x * (1 - x); # Warm up # TO 1000 DO x := NEXT (x); (x > 1 | print ((new line, r, x))) OD; # Print chaos, or not # IF x > 1e-10 THEN [1 : width] CHAR line; FOR k TO width DO line[k] := " " OD; TO 1000 DO x := NEXT (x); line [1 + ENTIER ((width - 1) * x)] := "*" OD; print ((new line, fixed (r, 0, 2), blank, line)) FI OD; new line (stand out) algol68g-3.1.2/test-set/17-pseudo-switch.a680000644000175000017500000000201614361065331015175 00000000000000COMMENT This program is part of the Algol 68 Genie test set. A small selection of the Algol 68 Genie regression test set is distributed with Algol 68 Genie. The purpose of those programs is to perform some checks to judge whether A68G behaves as expected. None of these programs should end ungraciously with for instance an addressing fault. COMMENT PR quiet regression PR CO The following is derived from C.H. Lindsey, A History of Algol 68 ACM Sigplan Notices, Volume 28, No. 3 March 1993 CO PR echo "Jumps as row of PROC VOID ... " PR # ... But worse! Van Wijngaarden was now able to exhibit his pride and joy - his pseudo-switch [R8.2.7.2]. # [] PROC VOID switch = (e1, e2, e3); # ... or even ... # LOC [1 : 3] PROC VOID zwitch := (e1, e2, e3); zwitch[2] := e3; # ... To my shame, I must admit that this still works, although implementations tend not to support it. # switch[2]; print("Can't be here"); e3: e2: e1: print ("Jumped correctly"); newline (standout) # A68G supports it! -- MvdV # algol68g-3.1.2/test-set/13-mastermind.a680000644000175000017500000000513514361065331014543 00000000000000# ww ww wwww wwbb # COMMENT This program is part of the Algol 68 Genie test set. A small selection of the Algol 68 Genie regression test set is distributed with Algol 68 Genie. The purpose of those programs is to perform some checks to judge whether A68G behaves as expected. None of these programs should end ungraciously with for instance an addressing fault. COMMENT PR quiet regression PR # This breaks a unique code of `n' pegs and `m' colours you think of. # INT pegs = 4, colours = 6; MODE LIST = FLEX [1 : 0] COMBINATION, COMBINATION = [pegs] COLOUR, COLOUR = INT; OP +:= = (REF LIST u, COMBINATION v) REF LIST: # Add one combination to a list. # ([UPB u + 1] COMBINATION w; w[ : UPB u] := u; w[UPB w] := v; u := w); PROC gen = (REF COMBINATION part, INT peg) VOID: # Generate all unique [colours!/(colours-pegs)!] combinations. # IF peg > pegs THEN all combs +:= part ELSE FOR i TO colours DO IF BOOL unique := TRUE; FOR j TO peg - 1 WHILE unique DO unique := part[j] ~= i OD; unique THEN part[peg] := i; gen (part, peg + 1) FI OD FI; LIST all combs; gen (LOC COMBINATION, 1); PROC break code = (LIST sieved) VOID: # Present a trial and sieve the list with the entered score. # CASE UPB sieved + 1 IN # No elements. # printf ($l"Inconsistent scores"l$), # One element. # printf (($l"Solution is "4(xd)l$, sieved[1])) OUT # printf (($l"["g(0)"]"x4(xd)": "$, UPB sieved, sieved[1])); # printf (($l4(dx)$, sieved[1])); # Read the score as a sequence of "w" and "b". # INT col ok := 0, pos ok := 0, STRING z := ""; WHILE z = "" DO read ((z, new line)) OD; printf (($gl$, z)); FOR i TO UPB z DO (z[i] = "w" | col ok |: z[i] = "b" | pos ok) +:= 1 OD; (pos ok = pegs | stop); # Survivors are combinations with score as entered. # LIST survivors; FOR i FROM 2 TO UPB sieved DO INT col ok i := 0, pos ok i := 0; FOR u TO pegs DO FOR v TO pegs DO IF sieved[1][u] = sieved[i][v] THEN (u = v | pos ok i | col ok i) +:= 1 FI OD OD; (col ok = col ok i AND pos ok = pos ok i | survivors +:= sieved[i]) OD; # Solution must be among the survivors. # break code (survivors) ESAC; VOID (open (standin, program idf, standin channel)); read (new line); break code (all combs) algol68g-3.1.2/test-set/23-tukey.a680000644000175000017500000000156514361065331013545 00000000000000COMMENT This program is part of the Algol 68 Genie test set. A small selection of the Algol 68 Genie regression test set is distributed with Algol 68 Genie. The purpose of those programs is to perform some checks to judge whether A68G behaves as expected. None of these programs should end ungraciously with for instance an addressing fault. COMMENT PR quiet regression PR PR need mathlib PR PROC table = (REAL alpha) VOID: BEGIN printf (($"Confidence = ", d.dddl$, 1 - alpha)); print (" "); FOR k FROM 2 TO 10 DO printf (($x6zd$, k)) OD; print (new line); FOR df FROM 2 TO 20 DO print (whole (df, -2)); FOR k FROM 2 TO 10 DO printf (($xzzd.ddd$, r qtukey (alpha, 1, k, df, TRUE, FALSE))) OD; print (new line) OD END; table (0.9); print (new line); table (0.95) algol68g-3.1.2/test-set/24-whetstones.a680000644000175000017500000002751214361065331014610 00000000000000COMMENT This program is part of the Algol 68 Genie test set. A small selection of the Algol 68 Genie regression test set is distributed with Algol 68 Genie. The purpose of those programs is to perform some checks to judge whether A68G behaves as expected. None of these programs should end ungraciously with for instance an addressing fault. COMMENT PR quiet regression PR COMMENT Synthetic benchmark following Curnow & Wichmann. Follows Algol 60 code. Some (REAL*8) A60 results (MWHIPS): IBM 3090 Algol 60 Compiler 5.0 Sun 3/60 Nase Algol Interpreter 0.01 68020/68881 20 MHz Nase Algol2C 0.4 Sparc 2 Nase Algol Interpreter 0.06 40 MHz Nase Algol2C 4.2 Some (REAL*8) A68G results (MWHIPS): PowerPC 750 233 MHz A68G 2 Interpreter Pentium III 1.2 GHZ A68G 18 Interpreter Xeon E5420 2.5 GHz A68G 39 Interpreter Xeon E5420 2.5 GHz A68G 334 Unit compiler Core i5-5300U 2.3 GHz A68G 68 Interpreter Core i5-5300U 2.3 GHz A68G 530 Unit compiler COMMENT BEGIN [1 : 4] REAL e1; REAL t, t1, t2, cpu1, time, x1, x2, x3, x4, x, y, z; INT j, k, l, i, ii; PROC pa = (REF [] REAL e) VOID: TO 6 DO e[1] := (e[1] + e[2] + e[3] - e[4]) * t; e[2] := (e[1] + e[2] - e[3] + e[4]) * t; e[3] := (e[1] - e[2] + e[3] + e[4]) * t; e[4] := (- e[1] + e[2] + e[3] + e[4]) / t2 OD; PROC po = VOID: BEGIN e1[j] := e1[k]; e1[k] := e1[l]; e1[l] := e1[j] END; PROC p3 = (REF REAL x, y, z) VOID: BEGIN x := t * (x + y); y := t * (x + y); z := (x + y) / t2 END; INT max = 5; PROC test = VOID: TO max DO # Initialise constants # t := 0.499975; t1 := 0.50025; t2 := 2.0; # If i = 10 we have 1e6 whetstone instructions per loop # i := 100; ii := i; INT n2 = 12 * i, n3 = 14 * i, n4 = 345 * i, n6 = 210 * i, n7 = 32 * i, n8 = 899 * i, n9 = 616 * i, n11 = 93 * i; # MODULE 1. Simple identifiers # x1 := 1.0; x2 := x3 := x4 := -1.0; # MODULE 2. Array elements # e1[1] := 1.0; e1[2] := e1[3] := e1[4] := -1.0; TO n2 DO e1[1] := (e1[1] + e1[2] + e1[3] - e1[4]) * t; e1[2] := (e1[1] + e1[2] - e1[3] + e1[4]) * t; e1[3] := (e1[1] - e1[2] + e1[3] + e1[4]) * t; e1[4] := (- e1[1] + e1[2] + e1[3] + e1[4]) * t OD; # MODULE 3. Array parameters # TO n3 DO pa(e1) OD; # MODULE 4. Conditional jumps # j := 1; TO n4 DO IF j = 1 THEN j := 2 ELSE j := 3 FI; IF j > 2 THEN j := 0 ELSE j := 1 FI; IF j < 1 THEN j := 1 ELSE j := 0 FI OD; # MODULE 5. Omitted # # MODULE 6. Integers # j := 1; k := 2; l := 3; TO n6 DO j := j * (k - j) * (l - k); k := l * k - (l - j) * k; l := (l - k) * (k + j); e1[l - 1] := j + k + l; e1[k - 1] := j * k * l OD; # MODULE 7. Trigonometry # x := y := 0.5; TO n7 DO x := t * arctan(t2 * sin(x) * cos(x) / (cos (x + y) + cos(x - y) - 1.0)); y := t * arctan(t2 * sin(y) * cos(y) / (cos (x + y) + cos(x - y) - 1.0)) OD; # MODULE 8. Calls # x := y := z := 1.0; TO n8 DO p3(x, y, z) OD; # MODULE 9. Array references # j := 1; k := 2; l := 3; e1[1] := 1.0; e1[2] := 2.0; e1[3] := 3.0; TO n9 DO po OD; # MODULE 11. Standard functions # x := 0.75; TO n11 DO x := sqrt(exp(ln(x) / t1)) OD OD; cpu1 := seconds; test; time := (seconds - cpu1) / max; printf (($zzdx, "digits ", zzdx, " samples ", xz-d.2dx, " seconds ", xzz-d.dx, "MWhets", xzzdx, "collections"l$, real width, max, time, 1 / (time / (ii / 10)), collections)) END; BEGIN [1 : 4] LONG REAL e1; LONG REAL t, t1, t2, cpu1, time, x1, x2, x3, x4, x, y, z; INT j, k, l, i, ii; PROC pa = (REF [] LONG REAL e) VOID: TO 6 DO e[1] := (e[1] + e[2] + e[3] - e[4]) * t; e[2] := (e[1] + e[2] - e[3] + e[4]) * t; e[3] := (e[1] - e[2] + e[3] + e[4]) * t; e[4] := (- e[1] + e[2] + e[3] + e[4]) / t2 OD; PROC po = VOID: BEGIN e1[j] := e1[k]; e1[k] := e1[l]; e1[l] := e1[j] END; PROC p3 = (REF LONG REAL x, y, z) VOID: BEGIN x := t * (x + y); y := t * (x + y); z := (x + y) / t2 END; INT max = 5; PROC test = VOID: TO max DO # Initialise constants # t := 0.499975; t1 := 0.50025; t2 := 2.0; # If i = 10 we have 1e6 whetstone instructions per loop # i := 100; ii := i; INT n2 = 12 * i, n3 = 14 * i, n4 = 345 * i, n6 = 210 * i, n7 = 32 * i, n8 = 899 * i, n9 = 616 * i, n11 = 93 * i; # MODULE 1. Simple identifiers # x1 := 1.0; x2 := x3 := x4 := -1.0; # MODULE 2. Array elements # e1[1] := 1.0; e1[2] := e1[3] := e1[4] := -1.0; TO n2 DO e1[1] := (e1[1] + e1[2] + e1[3] - e1[4]) * t; e1[2] := (e1[1] + e1[2] - e1[3] + e1[4]) * t; e1[3] := (e1[1] - e1[2] + e1[3] + e1[4]) * t; e1[4] := (- e1[1] + e1[2] + e1[3] + e1[4]) * t OD; # MODULE 3. Array parameters # TO n3 DO pa(e1) OD; # MODULE 4. Conditional jumps # j := 1; TO n4 DO IF j = 1 THEN j := 2 ELSE j := 3 FI; IF j > 2 THEN j := 0 ELSE j := 1 FI; IF j < 1 THEN j := 1 ELSE j := 0 FI OD; # MODULE 5. Omitted # # MODULE 6. Integers # j := 1; k := 2; l := 3; TO n6 DO j := j * (k - j) * (l - k); k := l * k - (l - j) * k; l := (l - k) * (k + j); e1[l - 1] := j + k + l; e1[k - 1] := j * k * l OD; # MODULE 7. Trigonometry # x := y := 0.5; TO n7 DO x := t * long arctan(t2 * long sin(x) * long cos(x) / (long cos (x + y) + long cos(x - y) - 1.0)); y := t * long arctan(t2 * long sin(y) * long cos(y) / (long cos (x + y) + long cos(x - y) - 1.0)) OD; # MODULE 8. Calls # x := y := z := 1.0; TO n8 DO p3(x, y, z) OD; # MODULE 9. Array references # j := 1; k := 2; l := 3; e1[1] := 1.0; e1[2] := 2.0; e1[3] := 3.0; TO n9 DO po OD; # MODULE 11. Standard functions # x := 0.75; TO n11 DO x := long sqrt(long exp(long ln(x) / t1)) OD OD; cpu1 := seconds; test; time := (seconds - cpu1) / max; printf (($zzdx, "digits ", zzdx, " samples ", xz-d.2dx, " seconds ", xzz-d.dx, "MWhets", xzzdx, "collections"l$, long real width, max, time, 1 / (time / (ii / 10)), collections)) END; BEGIN [1 : 4] LONG LONG REAL e1; LONG LONG REAL t, t1, t2, cpu1, time, x1, x2, x3, x4, x, y, z; INT j, k, l, i, ii; PROC pa = (REF [] LONG LONG REAL e) VOID: TO 6 DO e[1] := (e[1] + e[2] + e[3] - e[4]) * t; e[2] := (e[1] + e[2] - e[3] + e[4]) * t; e[3] := (e[1] - e[2] + e[3] + e[4]) * t; e[4] := (- e[1] + e[2] + e[3] + e[4]) / t2 OD; PROC po = VOID: BEGIN e1[j] := e1[k]; e1[k] := e1[l]; e1[l] := e1[j] END; PROC p3 = (REF LONG LONG REAL x, y, z) VOID: BEGIN x := t * (x + y); y := t * (x + y); z := (x + y) / t2 END; INT max = 5; PROC test = VOID: TO max DO # Initialise constants # t := 0.499975; t1 := 0.50025; t2 := 2.0; # If i = 10 we have 1e6 whetstone instructions per loop # i := 100; ii := i; INT n2 = 12 * i, n3 = 14 * i, n4 = 345 * i, n6 = 210 * i, n7 = 32 * i, n8 = 899 * i, n9 = 616 * i, n11 = 93 * i; # MODULE 1. Simple identifiers # x1 := 1.0; x2 := x3 := x4 := -1.0; # MODULE 2. Array elements # e1[1] := 1.0; e1[2] := e1[3] := e1[4] := -1.0; TO n2 DO e1[1] := (e1[1] + e1[2] + e1[3] - e1[4]) * t; e1[2] := (e1[1] + e1[2] - e1[3] + e1[4]) * t; e1[3] := (e1[1] - e1[2] + e1[3] + e1[4]) * t; e1[4] := (- e1[1] + e1[2] + e1[3] + e1[4]) * t OD; # MODULE 3. Array parameters # TO n3 DO pa(e1) OD; # MODULE 4. Conditional jumps # j := 1; TO n4 DO IF j = 1 THEN j := 2 ELSE j := 3 FI; IF j > 2 THEN j := 0 ELSE j := 1 FI; IF j < 1 THEN j := 1 ELSE j := 0 FI OD; # MODULE 5. Omitted # # MODULE 6. Integers # j := 1; k := 2; l := 3; TO n6 DO j := j * (k - j) * (l - k); k := l * k - (l - j) * k; l := (l - k) * (k + j); e1[l - 1] := j + k + l; e1[k - 1] := j * k * l OD; # MODULE 7. Trigonometry # x := y := 0.5; TO n7 DO x := t * long long arctan(t2 * long long sin(x) * long long cos(x) / (long long cos (x + y) + long long cos(x - y) - 1.0)); y := t * long long arctan(t2 * long long sin(y) * long long cos(y) / (long long cos (x + y) + long long cos(x - y) - 1.0)) OD; # MODULE 8. Calls # x := y := z := 1.0; TO n8 DO p3(x, y, z) OD; # MODULE 9. Array references # j := 1; k := 2; l := 3; e1[1] := 1.0; e1[2] := 2.0; e1[3] := 3.0; TO n9 DO po OD; # MODULE 11. Standard functions # x := 0.75; TO n11 DO x := long long sqrt(long long exp(long long ln(x) / t1)) OD OD; cpu1 := seconds; test; time := (seconds - cpu1) / max; printf (($zzdx, "digits ", zzdx, " samples ", xz-d.2dx, " seconds ", xzz-d.dx, "MWhets", xzzdx, "collections"l$, long long real width, max, time, 1 / (time / (ii / 10)), collections)) END algol68g-3.1.2/test-set/07-formula-manipulation.a680000644000175000017500000002127014361065331016544 00000000000000COMMENT This program is part of the Algol 68 Genie test set. A small selection of the Algol 68 Genie regression test set is distributed with Algol 68 Genie. The purpose of those programs is to perform some checks to judge whether A68G behaves as expected. None of these programs should end ungraciously with for instance an addressing fault. COMMENT PR quiet regression PR # Based on example 11.10 in the Revised Report on Algol 68 # # Data structure # MODE FORMULA = UNION (REF CONST, REF VAR, REF DYADIC, REF MONADIC, REF CALL), DYADIC = STRUCT (FORMULA lhs, INT operator, FORMULA rhs), MONADIC = STRUCT (INT operator, FORMULA rhs), CALL = STRUCT (REF FUNCTION name, FORMULA parameter), FUNCTION = STRUCT (REF VAR bound var, FORMULA body), VAR = STRUCT (STRING name, NUMBER value), CONST = STRUCT (NUMBER value), NUMBER = LONG LONG REAL; # Access operators # OP VALUE = (REF CONST c) REF NUMBER: value OF c, VALUE = (REF VAR v) REF NUMBER: value OF v, NAME = (REF VAR v) REF STRING: name OF v, NAME = (REF CALL c) REF FUNCTION: name OF c, PARAMETER = (REF CALL c) REF FORMULA: parameter OF c, LHS = (REF DYADIC t) REF FORMULA: lhs OF t, RHS = (REF DYADIC t) REF FORMULA: rhs OF t, RHS = (REF MONADIC t) REF FORMULA: rhs OF t, OPERATOR = (REF DYADIC t) REF INT: operator OF t, OPERATOR = (REF MONADIC t) REF INT: operator OF t, BOUND = (REF FUNCTION f) REF REF VAR: bound var OF f, BODY = (REF FUNCTION f) REF FORMULA: body OF f; # Generate objects # PROC make dyadic = (FORMULA u, INT op, FORMULA v) REF DYADIC: NEW DYADIC := (u, op, v); PROC make monadic = (INT op, FORMULA v) REF MONADIC: NEW MONADIC := (op, v); PROC make call = (REF FUNCTION name, FORMULA parameter) REF CALL: NEW CALL := (name, parameter); PROC make function = (REF VAR bound var, FORMULA body) REF FUNCTION: NEW FUNCTION := (bound var, body); PROC make var = (STRING name, NUMBER value) REF VAR: NEW VAR := (name, value); PROC make const = (NUMBER x) REF CONST: (NEW CONST c; VALUE c := x; c); PROC zero = REF CONST: make const (0), one = REF CONST: make const (1), two = REF CONST: make const (2), three = REF CONST: make const (3); # Basic routines and operators # PROC is var = (FORMULA f) BOOL: (f | (REF VAR): TRUE | FALSE); PROC is const = (FORMULA f) BOOL: (f | (REF CONST): TRUE | FALSE); PROC const value = (FORMULA f) NUMBER: (f | (REF CONST v): VALUE v); PROC var name = (FORMULA f) STRING: (f | (REF VAR v): NAME v); INT plus = 1, minus = 2, times = 3, divide = 4, up = 5; OP COPY = (FORMULA u) FORMULA: CASE u IN (REF CONST v): make const (VALUE v), (REF VAR v): make var (NAME v, VALUE v), (REF DYADIC v): make dyadic (COPY LHS v, OPERATOR v, COPY RHS v), (REF MONADIC v): make monadic (OPERATOR v, COPY RHS v), (REF CALL v): make call (NAME v, PARAMETER v) ESAC; OP = = (REF FUNCTION u, v) BOOL: BOUND u = BOUND v AND BODY u = BODY v; OP = = (FORMULA a, b) BOOL: CASE a IN (REF CONST u): (b | (REF CONST v): VALUE u = VALUE v | FALSE), (REF VAR u): (b | (REF VAR v): NAME u = NAME v | FALSE), (REF DYADIC u): (b | (REF DYADIC v): LHS u = LHS v AND RHS u = RHS v AND OPERATOR u = OPERATOR v | FALSE), (REF MONADIC u): (b | (REF MONADIC v): RHS u = RHS v AND OPERATOR u = OPERATOR v | FALSE), (REF CALL u): (b | (REF CALL v): NAME u = NAME v AND PARAMETER u = PARAMETER v | FALSE) OUT FALSE ESAC; OP /= = (FORMULA a, b) BOOL: NOT (a = b); # Basic math # OP + = (FORMULA a) FORMULA: a; OP - = (FORMULA a) FORMULA: (a = zero | a | make monadic (minus, a)); OP + = (FORMULA a, b) FORMULA: (a = zero | b |: b = zero | a | make dyadic (a, plus, b)); OP - = (FORMULA a, b) FORMULA: (b = zero | a | make dyadic (a, minus, b)); OP * = (FORMULA a, b) FORMULA: IF a = zero OR b = zero THEN zero ELSE (a = one | b |: b = one | a | make dyadic (a, times, b)) FI; OP / = (FORMULA a, b) FORMULA: IF a = zero AND NOT (b = zero) THEN zero ELSE (b = one | a | make dyadic (a, divide, b)) FI; OP ^ = (FORMULA a, REF CONST b) FORMULA: IF a = one OR (b IS zero) THEN one ELSE (b IS one | a | make dyadic (a, up, b)) FI; # Applications of above definitions: derivative, evaluation, simplification # PROC derivative = (FORMULA e, # with respect to # REF VAR x) FORMULA: # derivative a formula # CASE e IN (REF CONST): zero, (REF VAR v): (v = x | one | zero), (REF DYADIC f): CASE FORMULA u = LHS f, v = RHS f; FORMULA deriv u = derivative (u, x), deriv v = derivative (v, x); OPERATOR f IN deriv u + deriv v, deriv u - deriv v, u * deriv v + deriv u * v, (deriv u - f * deriv v) / v, (v | (REF CONST c): v * u ^ make const (VALUE c - 1) * deriv u) ESAC, (REF MONADIC f): CASE FORMULA v = RHS f; FORMULA deriv v = derivative (v, x); OPERATOR f IN + deriv v, - deriv v ESAC, (REF CALL c): BEGIN REF FUNCTION f = NAME c; FORMULA g = PARAMETER c; REF VAR y = BOUND f; REF FUNCTION deriv f = make function (y, derivative (BODY f, y)); (make call (deriv f, g)) * derivative (g, x) END ESAC; PROC evaluate = (FORMULA e) NUMBER: # Value of a formula # CASE e IN (REF CONST c): VALUE c, (REF VAR v): VALUE v, (REF DYADIC f): CASE NUMBER u = evaluate (LHS f), v = evaluate (RHS f); OPERATOR f IN u + v, u - v, u * v, u / v, u ^ SHORTEN SHORTEN ROUND v ESAC, (REF MONADIC f): CASE NUMBER v = evaluate (RHS f); OPERATOR f IN v, - v ESAC, (REF CALL c): BEGIN REF FUNCTION f = NAME c; VALUE BOUND f := evaluate (PARAMETER c); evaluate (BODY f) END ESAC; OP SIMPLIFY = (FORMULA u) FORMULA: # Example simplifications - extend as you see fit # CASE u IN (REF CONST v): make const (VALUE v), (REF VAR v): make var (NAME v, VALUE v), (REF DYADIC v): IF FORMULA f = SIMPLIFY LHS v, g = SIMPLIFY RHS v; is const (f) THEF is const (g) THEN make const (evaluate (make dyadic (f, OPERATOR v, g))) ELIF OPERATOR v = plus THEN (f = g | make dyadic (two, times, f) | make dyadic (f, plus, g)) ELIF OPERATOR v = minus THEN IF is const (f) THEF const value (f) = 0 THEN make monadic (minus, g) ELSE (f = g | zero | make dyadic (f, minus, g)) FI ELIF OPERATOR v = times THEN (is const (g) | make dyadic (g, times, f) |: f = g | make dyadic (f, up, two) | make dyadic (f, times, g)) ELSE make dyadic (f, OPERATOR v, g) FI, (REF MONADIC v): IF FORMULA g = SIMPLIFY RHS v; is const (g) THEN make const (evaluate (make monadic (OPERATOR v, g))) ELSE make monadic (OPERATOR v, g) FI, (REF CALL v): make call (NAME v, PARAMETER v) ESAC; # A small demonstration # OP FMT = (NUMBER x) STRING: (x = ENTIER x | whole (x, 0) | fixed (x, 0, 4)); PROC write = (FORMULA e) VOID: CASE e IN (REF CONST c): print (FMT VALUE c), (REF VAR v): print (NAME v), (REF DYADIC f): BEGIN print ("("); write (LHS f); print ((OPERATOR f | " + ", " - ", " * ", " / ", " ^ ")); write (RHS f); print (")") END, (REF MONADIC f): BEGIN print (("(", (OPERATOR f | "+ ", "- "))); write (RHS f); print (")") END ESAC; PROC print and simplify = (FORMULA f) VOID: IF write (f); FORMULA g = SIMPLIFY f; f /= g THEN print (" = "); print and simplify (g) ELIF ~ is const (f) THEN print (" = "); print (FMT evaluate (f)) FI; PROC demo = (FORMULA f, REF VAR z) VOID: BEGIN print ((new line, "f(x, y) = ")); print and simplify (f); FORMULA df := derivative (f, z); print ((new line, " df/d", NAME z, " = ")); print and simplify (df) END; REF VAR x = make var ("x", -1), y = make var ("y", 1); printf (($"x = ", g, ", y = ", g$, FMT VALUE x, FMT VALUE y)); demo (one + two * three, y); demo (x + x + zero * y, x); demo (x * two, x); demo (x * x * x + y * y, x); demo (x * x + two * x * y + y * y, x); demo (x + y / x, x); demo (x + y / x, y); new line (standout) algol68g-3.1.2/doc/0000755000175000017500000000000014361065617010717 500000000000000algol68g-3.1.2/doc/a68g.10000644000175000017500000001562214361065522011467 00000000000000.Dd January 15, 2023 .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 https://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-3.1.2/src/0000755000175000017500000000000014361065617010741 500000000000000algol68g-3.1.2/src/include/0000755000175000017500000000000014361065617012364 500000000000000algol68g-3.1.2/src/include/a68g-nil.h0000644000175000017500000000506114361065320013773 00000000000000//! @file a68g-nil.h //! @author J. Marcel van der Veer // //! @section Copyright // // This file is part of Algol68G - an Algol 68 compiler-interpreter. // Copyright 2001-2023 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 (__A68G_NIL_H__) #define __A68G_NIL_H__ // Various forms of NIL. #define NO_A68_REF ((A68_REF *) NULL) #define NO_ARRAY ((A68_ARRAY *) NULL) #define NO_BOOK ((BOOK_T *) NULL) #define NO_BOOL ((BOOL_T *) NULL) #define NO_BYTE ((BYTE_T *) NULL) #define NO_CONSTANT ((void *) NULL) #define NO_DEC ((DEC_T *) NULL) #define NO_DIAGNOSTIC ((DIAGNOSTIC_T *) NULL) #define NO_EDLIN ((EDLIN_T *) NULL) #define NO_FILE ((FILE *) NULL) #define NO_FORMAT ((A68_FORMAT *) NULL) #define NO_GINFO ((GINFO_T *) NULL) #define NO_GPROC ((void (*) (NODE_T *)) NULL) #define NO_HANDLE ((A68_HANDLE *) NULL) #define NO_INT ((int *) NULL) #define NO_JMP_BUF ((jmp_buf *) NULL) #define NO_KEYWORD ((KEYWORD_T *) NULL) #define NO_NINFO ((NODE_INFO_T *) NULL) #define NO_NOTE ((void (*) (NODE_T *)) NULL) #define NO_OPTION_LIST ((OPTION_LIST_T *) NULL) #define NO_PACK ((PACK_T *) NULL) #define NO_POSTULATE ((POSTULATE_T *) NULL) #define NO_PPROC ((PROP_T (*) (NODE_T *)) NULL) #define NO_PROCEDURE ((A68_PROCEDURE *) NULL) #define NO_REAL ((REAL_T *) NULL) #define NO_REFINEMENT ((REFINEMENT_T *) NULL) #define NO_REGMATCH ((regmatch_t *) NULL) #define NO_SCOPE ((SCOPE_T *) NULL) #define NO_SOID ((SOID_T *) NULL) #define NO_SOUND ((A68_SOUND *) NULL) #define NO_STREAM NO_FILE #define NO_TEXT ((char *) NULL) #define NO_TICK ((BOOL_T *) NULL) #define NO_TOKEN ((TOKEN_T *) NULL) #define NO_TUPLE ((A68_TUPLE *) NULL) #define NO_VAR (NULL) static const A68_FORMAT nil_format = { INIT_MASK, NULL, 0 }; static const A68_HANDLE nil_handle = { INIT_MASK, NO_BYTE, 0, NO_MOID, NO_HANDLE, NO_HANDLE }; static const A68_REF nil_ref = { (STATUS_MASK_T) (INIT_MASK | NIL_MASK), 0, 0, NO_HANDLE }; #endif algol68g-3.1.2/src/include/a68g-compiler.h0000644000175000017500000001775614361065320015041 00000000000000//! @file a68g-compiler.h //! @author J. Marcel van der Veer // //! @section Copyright // // This file is part of Algol68G - an Algol 68 compiler-interpreter. // Copyright 2001-2023 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 (__A68G_COMPILER_H__) #define __A68G_COMPILER_H__ typedef union UFU UFU; union UFU { UNSIGNED_T u; REAL_T f; }; #define BASIC(p, n) (basic_unit (stems_from ((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 WIDEN_TO(p, a, b) (MOID (p) == MODE (b) && MOID (SUB (p)) == MODE (a)) #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 (A68 (edit_line), SNPRINTF_SIZE, "EXECUTE_UNIT_TRACE (_NODE_ (%d));", NUMBER (p)));\ } #define NAME_SIZE 200 extern BOOK_T *signed_in (int, int, char *); extern BOOL_T basic_argument (NODE_T *); extern BOOL_T basic_call (NODE_T *); extern BOOL_T basic_collateral (NODE_T *); extern BOOL_T basic_conditional (NODE_T *); extern BOOL_T basic_formula (NODE_T *); extern BOOL_T basic_indexer (NODE_T *); extern BOOL_T basic_mode (MOID_T *); extern BOOL_T basic_mode_non_row (MOID_T *); extern BOOL_T basic_monadic_formula (NODE_T *); extern BOOL_T basic_serial (NODE_T *, int); extern BOOL_T basic_slice (NODE_T *); extern BOOL_T basic_unit (NODE_T *); extern BOOL_T basic_unit (NODE_T *); extern BOOL_T need_initialise_frame (NODE_T *); extern BOOL_T primitive_mode (MOID_T *); extern BOOL_T same_tree (NODE_T *, NODE_T *); extern char *compile_call (NODE_T *, FILE_T); extern char *compile_cast (NODE_T *, FILE_T); extern char *compile_denotation (NODE_T *, FILE_T); extern char *compile_dereference_identifier (NODE_T *, FILE_T); extern char *compile_formula (NODE_T *, FILE_T); extern char *compile_identifier (NODE_T *, FILE_T); extern char *gen_basic_conditional (NODE_T *, FILE_T, int); extern char *gen_basic (NODE_T *, FILE_T); extern char *gen_call (NODE_T *, FILE_T, int); extern char *gen_cast (NODE_T *, FILE_T, int); extern char *gen_closed_clause (NODE_T *, FILE_T, int); extern char *gen_code_clause (NODE_T *, FILE_T, int); extern char *gen_collateral_clause (NODE_T *, FILE_T, int); extern char *gen_conditional_clause (NODE_T *, FILE_T, int); extern char *gen_denotation (NODE_T *, FILE_T, int); extern char *gen_deproceduring (NODE_T *, FILE_T, int); extern char *gen_dereference_identifier (NODE_T *, FILE_T, int); extern char *gen_dereference_selection (NODE_T *, FILE_T, int); extern char *gen_dereference_slice (NODE_T *, FILE_T, int); extern char *gen_formula (NODE_T *, FILE_T, int); extern char *gen_identifier (NODE_T *, FILE_T, int); extern char *gen_identity_relation (NODE_T *, FILE_T, int); extern char *gen_int_case_clause (NODE_T *, FILE_T, int); extern char *gen_loop_clause (NODE_T *, FILE_T, int); extern char *gen_selection (NODE_T *, FILE_T, int); extern char *gen_slice (NODE_T *, FILE_T, int); extern char *gen_uniting (NODE_T *, FILE_T, int); extern char *gen_unit (NODE_T *, FILE_T, BOOL_T); extern char *gen_voiding_assignation_identifier (NODE_T *, FILE_T, int); extern char *gen_voiding_assignation_selection (NODE_T *, FILE_T, int); extern char *gen_voiding_assignation_slice (NODE_T *, FILE_T, int); extern char *gen_voiding_call (NODE_T *, FILE_T, int); extern char *gen_voiding_deproceduring (NODE_T *, FILE_T, int); extern char *gen_voiding_formula (NODE_T *, FILE_T, int); extern char *inline_mode (MOID_T *); extern char *internal_mode (MOID_T *); extern char *make_name (char *, char *, char *, int); extern char *make_unic_name (char *, char *, char *, char *); extern char *moid_with_name (char *, MOID_T *, char *); extern DEC_T *add_declaration (DEC_T **, char *, int, char *); extern DEC_T *add_identifier (DEC_T **, int, char *); extern NODE_T *stems_from (NODE_T *, int); extern void comment_source (NODE_T *, FILE_T); extern void constant_folder (NODE_T *, FILE_T, int); extern void gen_assign (NODE_T *, FILE_T, char *); extern void gen_basics (NODE_T *, FILE_T); extern void gen_check_init (NODE_T *, FILE_T, char *); extern void gen_declaration_list (NODE_T *, FILE_T, int *, char *); extern void gen_push (NODE_T *, FILE_T); extern void gen_serial_clause (NODE_T *, FILE_T, NODE_T **, int *, int *, char *, int); extern void gen_units (NODE_T *, FILE_T); extern void get_stack (NODE_T *, FILE_T, char *, char *); extern void indentf (FILE_T, int); extern void indentf (FILE_T, int); extern void indent (FILE_T, char *); extern void indent (FILE_T, char *); extern void init_static_frame (FILE_T, NODE_T *); extern void inline_arguments (NODE_T *, FILE_T, int, int *); extern void inline_call (NODE_T *, FILE_T, int); extern void inline_closed (NODE_T *, FILE_T, int); extern void inline_collateral (NODE_T *, FILE_T, int); extern void inline_collateral_units (NODE_T *, FILE_T, int); extern void inline_comment_source (NODE_T *, FILE_T); extern void inline_conditional (NODE_T *, FILE_T, int); extern void inline_denotation (NODE_T *, FILE_T, int); extern void inline_dereference_identifier (NODE_T *, FILE_T, int); extern void inline_dereference_selection (NODE_T *, FILE_T, int); extern void inline_dereference_slice (NODE_T *, FILE_T, int); extern void inline_formula (NODE_T *, FILE_T, int); extern void inline_identifier (NODE_T *, FILE_T, int); extern void inline_identity_relation (NODE_T *, FILE_T, int); extern void inline_indexer (NODE_T *, FILE_T, int, INT_T *, char *); extern void inline_monadic_formula (NODE_T *, FILE_T, int); extern void inline_ref_identifier (NODE_T *, FILE_T, int); extern void inline_selection (NODE_T *, FILE_T, int); extern void inline_selection_ref_to_ref (NODE_T *, FILE_T, int); extern void inline_single_argument (NODE_T *, FILE_T, int); extern void inline_slice (NODE_T *, FILE_T, int); extern void inline_slice_ref_to_ref (NODE_T *, FILE_T, int); extern void inline_unit (NODE_T *, FILE_T, int); extern void inline_unit (NODE_T *, FILE_T, int); extern void inline_widening (NODE_T *, FILE_T, int); extern void print_declarations (FILE_T, DEC_T *); extern void sign_in (int, int, char *, void *, int); extern void sign_in_name (char *, int *); extern void undentf (FILE_T, int); extern void undent (FILE_T, char *); extern void write_fun_postlude (NODE_T *, FILE_T, char *); extern void write_fun_prelude (NODE_T *, FILE_T, char *); extern void write_prelude (FILE_T); // The phases we go through. enum { L_NONE = 0, L_DECLARE = 1, L_INITIALISE, L_EXECUTE, L_EXECUTE_2, L_YIELD, L_PUSH }; #define UNIC_NAME(k) (A68_OPT (unic_functions)[k].fun) enum { UNIC_EXISTS, UNIC_MAKE_NEW, UNIC_MAKE_ALT }; // 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; extern TRANSLATION *monadics, *dyadics, *functions; extern TRANSLATION monadics_nocheck[]; extern TRANSLATION monadics_check[]; extern TRANSLATION dyadics_nocheck[]; extern TRANSLATION dyadics_check[]; extern TRANSLATION functions_nocheck[]; extern TRANSLATION functions_check[]; extern TRANSLATION constants[]; #endif algol68g-3.1.2/src/include/a68g-includes.h0000644000175000017500000001247214361065320015023 00000000000000//! @file a68g-includes.h //! @author J. Marcel van der Veer // //! @section Copyright // // This file is part of Algol68G - an Algol 68 compiler-interpreter. // Copyright 2001-2023 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 (__A68G_INCLUDES_H__) #define __A68G_INCLUDES_H__ // 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) # if ! defined (A68_OPTIMISE) # include # endif #endif #if defined (HAVE_MATH_H) #include #endif #if defined (HAVE_COMPLEX_H) #include #undef I #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_QUADMATH_H) // #include // #endif #if defined (HAVE_PTHREAD_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_STDINT_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_GNU_MPFR) #if defined (HAVE_GNU_MPFR) #define MPFR_WANT_FLOAT128 #endif #include #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 #if defined (HAVE_GSL_GSL_VERSION_H) #include #endif #if defined (HAVE_REGEX_H) # if defined (BUILD_WIN32) # include "a68g-regex.h" # else # include # endif #endif #endif algol68g-3.1.2/src/include/a68g-masks.h0000644000175000017500000000637114361065320014334 00000000000000//! @file a68g-masks.h //! @author J. Marcel van der Veer // //! @section Copyright // // This file is part of Algol68G - an Algol 68 compiler-interpreter. // Copyright 2001-2023 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 (__A68G_MASKS_H__) #define __A68G_MASKS_H__ // Status Masks #define NULL_MASK ((STATUS_MASK_T) 0x00000000) #define IN_HEAP_MASK ((STATUS_MASK_T) 0x00000001) #define IN_FRAME_MASK ((STATUS_MASK_T) 0x00000002) #define IN_STACK_MASK ((STATUS_MASK_T) 0x00000004) #define IN_COMMON_MASK ((STATUS_MASK_T) 0x00000008) #define INIT_MASK ((STATUS_MASK_T) 0x00000010) #define PLUS_INF_MASK ((STATUS_MASK_T) 0x00000020) #define MINUS_INF_MASK ((STATUS_MASK_T) 0x00000040) #define CONSTANT_MASK ((STATUS_MASK_T) 0x00000080) #define BLOCK_GC_MASK ((STATUS_MASK_T) 0x00000100) #define COOKIE_MASK ((STATUS_MASK_T) 0x00000200) #define SCOPE_ERROR_MASK ((STATUS_MASK_T) 0x00000200) #define ALLOCATED_MASK ((STATUS_MASK_T) 0x00000400) #define STANDENV_PROC_MASK ((STATUS_MASK_T) 0x00000800) #define COLOUR_MASK ((STATUS_MASK_T) 0x00001000) #define MODULAR_MASK ((STATUS_MASK_T) 0x00002000) #define OPTIMAL_MASK ((STATUS_MASK_T) 0x00004000) #define SERIAL_MASK ((STATUS_MASK_T) 0x00008000) #define CROSS_REFERENCE_MASK ((STATUS_MASK_T) 0x00010000) #define TREE_MASK ((STATUS_MASK_T) 0x00020000) #define CODE_MASK ((STATUS_MASK_T) 0x00040000) #define NOT_NEEDED_MASK ((STATUS_MASK_T) 0x00080000) #define SOURCE_MASK ((STATUS_MASK_T) 0x00100000) #define ASSERT_MASK ((STATUS_MASK_T) 0x00200000) #define NIL_MASK ((STATUS_MASK_T) 0x00400000) #define SKIP_PROCEDURE_MASK ((STATUS_MASK_T) 0x00800000) #define SKIP_FORMAT_MASK ((STATUS_MASK_T) 0x00800000) #define SKIP_ROW_MASK ((STATUS_MASK_T) 0x00800000) #define INTERRUPTIBLE_MASK ((STATUS_MASK_T) 0x01000000) #define BREAKPOINT_MASK ((STATUS_MASK_T) 0x02000000) #define BREAKPOINT_TEMPORARY_MASK ((STATUS_MASK_T) 0x04000000) #define BREAKPOINT_INTERRUPT_MASK ((STATUS_MASK_T) 0x08000000) #define BREAKPOINT_WATCH_MASK ((STATUS_MASK_T) 0x10000000) #define BREAKPOINT_TRACE_MASK ((STATUS_MASK_T) 0x20000000) #define SEQUENCE_MASK ((STATUS_MASK_T) 0x40000000) #define BREAKPOINT_ERROR_MASK ((STATUS_MASK_T) 0xffffffff) // CODEX masks #define PROC_DECLARATION_MASK ((STATUS_MASK_T) 0x00000001) #endif algol68g-3.1.2/src/include/a68g-math.h0000644000175000017500000004004614361065320014144 00000000000000//! @file a68g-math.h //! @author J. Marcel van der Veer // //! @section Copyright // // This file is part of Algol68G - an Algol 68 compiler-interpreter. // Copyright 2001-2023 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 . static const REAL_T factable[A68_MAX_FAC + 1] = { /* 0 */ 1.000000000000000000000e0, /* 1 */ 1.000000000000000000000e0, /* 2 */ 2.000000000000000000000e0, /* 3 */ 6.000000000000000000000e0, /* 4 */ 2.400000000000000000000e1, /* 5 */ 1.200000000000000000000e2, /* 6 */ 7.200000000000000000000e2, /* 7 */ 5.040000000000000000000e3, /* 8 */ 4.032000000000000000000e4, /* 9 */ 3.628800000000000000000e5, /* 10 */ 3.628800000000000000000e6, /* 11 */ 3.991680000000000000000e7, /* 12 */ 4.790016000000000000000e8, /* 13 */ 6.227020800000000000000e9, /* 14 */ 8.717829120000000000000e10, /* 15 */ 1.307674368000000000000e12, /* 16 */ 2.092278988800000000000e13, /* 17 */ 3.556874280960000000000e14, /* 18 */ 6.402373705728000000000e15, /* 19 */ 1.216451004088320000000e17, /* 20 */ 2.432902008176640000000e18, /* 21 */ 5.109094217170944000000e19, /* 22 */ 1.124000727777607680000e21, /* 23 */ 2.585201673888497664000e22, /* 24 */ 6.204484017332394393600e23, /* 25 */ 1.551121004333098598400e25, /* 26 */ 4.032914611266056355840e26, /* 27 */ 1.088886945041835216077e28, /* 28 */ 3.048883446117138605015e29, /* 29 */ 8.841761993739701954544e30, /* 30 */ 2.652528598121910586363e32, /* 31 */ 8.222838654177922817726e33, /* 32 */ 2.631308369336935301672e35, /* 33 */ 8.683317618811886495518e36, /* 34 */ 2.952327990396041408476e38, /* 35 */ 1.033314796638614492967e40, /* 36 */ 3.719933267899012174680e41, /* 37 */ 1.376375309122634504632e43, /* 38 */ 5.230226174666011117600e44, /* 39 */ 2.039788208119744335864e46, /* 40 */ 8.159152832478977343456e47, /* 41 */ 3.345252661316380710817e49, /* 42 */ 1.405006117752879898543e51, /* 43 */ 6.041526306337383563736e52, /* 44 */ 2.658271574788448768044e54, /* 45 */ 1.196222208654801945620e56, /* 46 */ 5.502622159812088949850e57, /* 47 */ 2.586232415111681806430e59, /* 48 */ 1.241391559253607267086e61, /* 49 */ 6.082818640342675608723e62, /* 50 */ 3.041409320171337804361e64, /* 51 */ 1.551118753287382280224e66, /* 52 */ 8.065817517094387857166e67, /* 53 */ 4.274883284060025564298e69, /* 54 */ 2.308436973392413804721e71, /* 55 */ 1.269640335365827592597e73, /* 56 */ 7.109985878048634518540e74, /* 57 */ 4.052691950487721675568e76, /* 58 */ 2.350561331282878571829e78, /* 59 */ 1.386831185456898357379e80, /* 60 */ 8.320987112741390144276e81, /* 61 */ 5.075802138772247988009e83, /* 62 */ 3.146997326038793752565e85, /* 63 */ 1.982608315404440064116e87, /* 64 */ 1.268869321858841641034e89, /* 65 */ 8.247650592082470666723e90, /* 66 */ 5.443449390774430640037e92, /* 67 */ 3.647111091818868528825e94, /* 68 */ 2.480035542436830599601e96, /* 69 */ 1.711224524281413113725e98, /* 70 */ 1.197857166996989179607e100, /* 71 */ 8.504785885678623175212e101, /* 72 */ 6.123445837688608686152e103, /* 73 */ 4.470115461512684340891e105, /* 74 */ 3.307885441519386412260e107, /* 75 */ 2.480914081139539809195e109, /* 76 */ 1.885494701666050254988e111, /* 77 */ 1.451830920282858696341e113, /* 78 */ 1.132428117820629783146e115, /* 79 */ 8.946182130782975286851e116, /* 80 */ 7.156945704626380229481e118, /* 81 */ 5.797126020747367985880e120, /* 82 */ 4.753643337012841748421e122, /* 83 */ 3.945523969720658651190e124, /* 84 */ 3.314240134565353266999e126, /* 85 */ 2.817104114380550276949e128, /* 86 */ 2.422709538367273238177e130, /* 87 */ 2.107757298379527717214e132, /* 88 */ 1.854826422573984391148e134, /* 89 */ 1.650795516090846108122e136, /* 90 */ 1.485715964481761497310e138, /* 91 */ 1.352001527678402962552e140, /* 92 */ 1.243841405464130725548e142, /* 93 */ 1.156772507081641574759e144, /* 94 */ 1.087366156656743080274e146, /* 95 */ 1.032997848823905926260e148, /* 96 */ 9.916779348709496892096e149, /* 97 */ 9.619275968248211985333e151, /* 98 */ 9.426890448883247745626e153, /* 99 */ 9.332621544394415268170e155, /* 100 */ 9.332621544394415268170e157, /* 101 */ 9.425947759838359420852e159, /* 102 */ 9.614466715035126609269e161, /* 103 */ 9.902900716486180407547e163, /* 104 */ 1.029901674514562762385e166, /* 105 */ 1.081396758240290900504e168, /* 106 */ 1.146280563734708354534e170, /* 107 */ 1.226520203196137939352e172, /* 108 */ 1.324641819451828974500e174, /* 109 */ 1.443859583202493582205e176, /* 110 */ 1.588245541522742940425e178, /* 111 */ 1.762952551090244663872e180, /* 112 */ 1.974506857221074023537e182, /* 113 */ 2.231192748659813646597e184, /* 114 */ 2.543559733472187557120e186, /* 115 */ 2.925093693493015690688e188, /* 116 */ 3.393108684451898201198e190, /* 117 */ 3.969937160808720895402e192, /* 118 */ 4.684525849754290656574e194, /* 119 */ 5.574585761207605881323e196, /* 120 */ 6.689502913449127057588e198, /* 121 */ 8.094298525273443739682e200, /* 122 */ 9.875044200833601362412e202, /* 123 */ 1.214630436702532967577e205, /* 124 */ 1.506141741511140879795e207, /* 125 */ 1.882677176888926099744e209, /* 126 */ 2.372173242880046885677e211, /* 127 */ 3.012660018457659544810e213, /* 128 */ 3.856204823625804217357e215, /* 129 */ 4.974504222477287440390e217, /* 130 */ 6.466855489220473672507e219, /* 131 */ 8.471580690878820510985e221, /* 132 */ 1.118248651196004307450e224, /* 133 */ 1.487270706090685728908e226, /* 134 */ 1.992942746161518876737e228, /* 135 */ 2.690472707318050483595e230, /* 136 */ 3.659042881952548657690e232, /* 137 */ 5.012888748274991661035e234, /* 138 */ 6.917786472619488492228e236, /* 139 */ 9.615723196941089004197e238, /* 140 */ 1.346201247571752460588e241, /* 141 */ 1.898143759076170969429e243, /* 142 */ 2.695364137888162776589e245, /* 143 */ 3.854370717180072770522e247, /* 144 */ 5.550293832739304789551e249, /* 145 */ 8.047926057471991944849e251, /* 146 */ 1.174997204390910823948e254, /* 147 */ 1.727245890454638911203e256, /* 148 */ 2.556323917872865588581e258, /* 149 */ 3.808922637630569726986e260, /* 150 */ 5.713383956445854590479e262, /* 151 */ 8.627209774233240431623e264, /* 152 */ 1.311335885683452545607e267, /* 153 */ 2.006343905095682394778e269, /* 154 */ 3.089769613847350887959e271, /* 155 */ 4.789142901463393876336e273, /* 156 */ 7.471062926282894447084e275, /* 157 */ 1.172956879426414428192e278, /* 158 */ 1.853271869493734796544e280, /* 159 */ 2.946702272495038326504e282, /* 160 */ 4.714723635992061322407e284, /* 161 */ 7.590705053947218729075e286, /* 162 */ 1.229694218739449434110e289, /* 163 */ 2.004401576545302577600e291, /* 164 */ 3.287218585534296227263e293, /* 165 */ 5.423910666131588774984e295, /* 166 */ 9.003691705778437366474e297, /* 167 */ 1.503616514864999040201e300, /* 168 */ 2.526075744973198387538e302, /* 169 */ 4.269068009004705274939e304, /* 170 */ 7.257415615307998967397e306 }; static const REAL_T ln_factable[A68_MAX_FAC + 1] = { /* 0 */ 0.000000000000000000000e0, /* 1 */ 0.000000000000000000000e0, /* 2 */ 6.931471805599453094172e-1, /* 3 */ 1.791759469228055000812e0, /* 4 */ 3.178053830347945619647e0, /* 5 */ 4.787491742782045994248e0, /* 6 */ 6.579251212010100995060e0, /* 7 */ 8.525161361065414300166e0, /* 8 */ 1.060460290274525022842e1, /* 9 */ 1.280182748008146961121e1, /* 10 */ 1.510441257307551529523e1, /* 11 */ 1.750230784587388583929e1, /* 12 */ 1.998721449566188614952e1, /* 13 */ 2.255216385312342288557e1, /* 14 */ 2.519122118273868150009e1, /* 15 */ 2.789927138384089156609e1, /* 16 */ 3.067186010608067280376e1, /* 17 */ 3.350507345013688888401e1, /* 18 */ 3.639544520803305357622e1, /* 19 */ 3.933988418719949403622e1, /* 20 */ 4.233561646075348502966e1, /* 21 */ 4.538013889847690802616e1, /* 22 */ 4.847118135183522387964e1, /* 23 */ 5.160667556776437357045e1, /* 24 */ 5.478472939811231919009e1, /* 25 */ 5.800360522298051993929e1, /* 26 */ 6.126170176100200198477e1, /* 27 */ 6.455753862700633105895e1, /* 28 */ 6.788974313718153498289e1, /* 29 */ 7.125703896716800901007e1, /* 30 */ 7.465823634883016438549e1, /* 31 */ 7.809222355331531063142e1, /* 32 */ 8.155795945611503717850e1, /* 33 */ 8.505446701758151741396e1, /* 34 */ 8.858082754219767880363e1, /* 35 */ 9.213617560368709248333e1, /* 36 */ 9.571969454214320248496e1, /* 37 */ 9.933061245478742692933e1, /* 38 */ 1.029681986145138126988e2, /* 39 */ 1.066317602606434591262e2, /* 40 */ 1.103206397147573954291e2, /* 41 */ 1.140342117814617032329e2, /* 42 */ 1.177718813997450715388e2, /* 43 */ 1.215330815154386339623e2, /* 44 */ 1.253172711493568951252e2, /* 45 */ 1.291239336391272148826e2, /* 46 */ 1.329525750356163098828e2, /* 47 */ 1.368027226373263684696e2, /* 48 */ 1.406739236482342593987e2, /* 49 */ 1.445657439463448860089e2, /* 50 */ 1.484777669517730320675e2, /* 51 */ 1.524095925844973578392e2, /* 52 */ 1.563608363030787851941e2, /* 53 */ 1.603311282166309070282e2, /* 54 */ 1.643201122631951814118e2, /* 55 */ 1.683274454484276523305e2, /* 56 */ 1.723527971391628015638e2, /* 57 */ 1.763958484069973517152e2, /* 58 */ 1.804562914175437710518e2, /* 59 */ 1.845338288614494905025e2, /* 60 */ 1.886281734236715911873e2, /* 61 */ 1.927390472878449024360e2, /* 62 */ 1.968661816728899939914e2, /* 63 */ 2.010093163992815266793e2, /* 64 */ 2.051681994826411985358e2, /* 65 */ 2.093425867525368356464e2, /* 66 */ 2.135322414945632611913e2, /* 67 */ 2.177369341139542272510e2, /* 68 */ 2.219564418191303339501e2, /* 69 */ 2.261905483237275933323e2, /* 70 */ 2.304390435657769523214e2, /* 71 */ 2.347017234428182677427e2, /* 72 */ 2.389783895618343230538e2, /* 73 */ 2.432688490029827141829e2, /* 74 */ 2.475729140961868839366e2, /* 75 */ 2.518904022097231943772e2, /* 76 */ 2.562211355500095254561e2, /* 77 */ 2.605649409718632093053e2, /* 78 */ 2.649216497985528010421e2, /* 79 */ 2.692910976510198225363e2, /* 80 */ 2.736731242856937041486e2, /* 81 */ 2.780675734403661429141e2, /* 82 */ 2.824742926876303960274e2, /* 83 */ 2.868931332954269939509e2, /* 84 */ 2.913239500942703075662e2, /* 85 */ 2.957666013507606240211e2, /* 86 */ 3.002209486470141317540e2, /* 87 */ 3.046868567656687154726e2, /* 88 */ 3.091641935801469219449e2, /* 89 */ 3.136528299498790617832e2, /* 90 */ 3.181526396202093268500e2, /* 91 */ 3.226634991267261768912e2, /* 92 */ 3.271852877037752172008e2, /* 93 */ 3.317178871969284731381e2, /* 94 */ 3.362611819791984770344e2, /* 95 */ 3.408150588707990178690e2, /* 96 */ 3.453794070622668541074e2, /* 97 */ 3.499541180407702369296e2, /* 98 */ 3.545390855194408088492e2, /* 99 */ 3.591342053695753987760e2, /* 100 */ 3.637393755555634901441e2, /* 101 */ 3.683544960724047495950e2, /* 102 */ 3.729794688856890206760e2, /* 103 */ 3.776141978739186564468e2, /* 104 */ 3.822585887730600291111e2, /* 105 */ 3.869125491232175524822e2, /* 106 */ 3.915759882173296196258e2, /* 107 */ 3.962488170517915257991e2, /* 108 */ 4.009309482789157454921e2, /* 109 */ 4.056222961611448891925e2, /* 110 */ 4.103227765269373054205e2, /* 111 */ 4.150323067282496395563e2, /* 112 */ 4.197508055995447340991e2, /* 113 */ 4.244781934182570746677e2, /* 114 */ 4.292143918666515701285e2, /* 115 */ 4.339593239950148201939e2, /* 116 */ 4.387129141861211848399e2, /* 117 */ 4.434750881209189409588e2, /* 118 */ 4.482457727453846057188e2, /* 119 */ 4.530248962384961351041e2, /* 120 */ 4.578123879812781810984e2, /* 121 */ 4.626081785268749221865e2, /* 122 */ 4.674121995716081787447e2, /* 123 */ 4.722243839269805962399e2, /* 124 */ 4.770446654925856331047e2, /* 125 */ 4.818729792298879342285e2, /* 126 */ 4.867092611368394122258e2, /* 127 */ 4.915534482232980034989e2, /* 128 */ 4.964054784872176206648e2, /* 129 */ 5.012652908915792927797e2, /* 130 */ 5.061328253420348751997e2, /* 131 */ 5.110080226652360267439e2, /* 132 */ 5.158908245878223975982e2, /* 133 */ 5.207811737160441513633e2, /* 134 */ 5.256790135159950627324e2, /* 135 */ 5.305842882944334921812e2, /* 136 */ 5.354969431801695441897e2, /* 137 */ 5.404169241059976691050e2, /* 138 */ 5.453441777911548737966e2, /* 139 */ 5.502786517242855655538e2, /* 140 */ 5.552202941468948698523e2, /* 141 */ 5.601690540372730381305e2, /* 142 */ 5.651248810948742988613e2, /* 143 */ 5.700877257251342061414e2, /* 144 */ 5.750575390247102067619e2, /* 145 */ 5.800342727671307811636e2, /* 146 */ 5.850178793888391176022e2, /* 147 */ 5.900083119756178539038e2, /* 148 */ 5.950055242493819689670e2, /* 149 */ 6.000094705553274281080e2, /* 150 */ 6.050201058494236838580e2, /* 151 */ 6.100373856862386081868e2, /* 152 */ 6.150612662070848845750e2, /* 153 */ 6.200917041284773200381e2, /* 154 */ 6.251286567308909491967e2, /* 155 */ 6.301720818478101958172e2, /* 156 */ 6.352219378550597328635e2, /* 157 */ 6.402781836604080409209e2, /* 158 */ 6.453407786934350077245e2, /* 159 */ 6.504096828956552392500e2, /* 160 */ 6.554848567108890661717e2, /* 161 */ 6.605662610758735291676e2, /* 162 */ 6.656538574111059132426e2, /* 163 */ 6.707476076119126755767e2, /* 164 */ 6.758474740397368739994e2, /* 165 */ 6.809534195136374546094e2, /* 166 */ 6.860654073019939978423e2, /* 167 */ 6.911834011144107529496e2, /* 168 */ 6.963073650938140118743e2, /* 169 */ 7.014372638087370853465e2, /* 170 */ 7.065730622457873471107e2 }; #define N_c_inverfc 34 static const REAL_T c_inverfc[N_c_inverfc] = { 0.91646139826896400000, 0.48882664027310800000, 0.23172920032340500000, 0.12461045461371200000, -0.07288467655856750000, 0.26999930867002900000, 0.15068904736022300000, 0.11606502534161400000, 0.49999930343979000000, 3.97886080735226000000, 0.00112648096188977922, 1.05739299623423047e-4, 0.00351287146129100025, 7.71708358954120939e-4, 0.00685649426074558612, 0.00339721910367775861, 0.01127491693325048700, 0.01185981170477711040, 0.01429619886978980180, 0.03464942077890999220, 0.00220995927012179067, 0.07434243572417848610, 0.10587217794159548800, 0.01472979383314851210, 0.31684763852013594400, 0.71365763586873036400, 1.05375024970847138000, 1.21448730779995237000, 1.16374581931560831000, 0.95646497474479900600, 0.68626594827409781600, 0.43439749233143011500, 0.24404451059319093500, 0.12078223763524522200 }; #define N_ln1p 21 static const REAL_T c_ln1p[N_ln1p + 1] = { N_ln1p, 1.8657327910677296608121390705e-18, -1.3492637457521938883731579510e-17, 9.7089758328248469219003866867e-17, -7.0722150011433276578323272272e-16, 5.1107345870861673561462339876e-15, -3.7581977830387938294437434651e-14, 2.7291231220549214896095654769e-13, -2.0328515972462118942821556033e-12, 1.4844576692270934446023686322e-11, -1.1260499376492049411710290413e-10, 8.2751976628812389601561347296e-10, -6.4501969776090319441714445454e-09, 4.7743678729400456026672697926e-08, -3.8873813517057343800270917900e-07, 2.9004512660400621301999384544e-06, -0.00002553258886105542567601400, 0.00019211375164056698287947962, -0.00200215904941415466274422081, 0.01517767255690553732382488171, -0.28565398551049742084877469679, 2.16647910664395270521272590407 }; algol68g-3.1.2/src/include/a68g-parser.h0000644000175000017500000001645014361065320014511 00000000000000//! @file a68g-parser.h //! @author J. Marcel van der Veer // //! @section Copyright // // This file is part of Algol68G - an Algol 68 compiler-interpreter. // Copyright 2001-2023 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 (__A68G_PARSER_H__) #define __A68G_PARSER_H__ #define STOP_CHAR 127 extern BOOL_T dont_mark_here (NODE_T *); extern BOOL_T is_coercion (NODE_T *); extern BOOL_T is_firm (MOID_T *, MOID_T *); extern BOOL_T is_firm (MOID_T *, MOID_T *); extern BOOL_T is_formal_bounds (NODE_T *); extern BOOL_T is_loop_keyword (NODE_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_ref_refety_flex (MOID_T *); extern BOOL_T is_semicolon_less (NODE_T *); extern BOOL_T is_subset (MOID_T *, MOID_T *, int); extern BOOL_T is_unitable (MOID_T *, MOID_T *, int); extern BOOL_T is_unit_terminator (NODE_T *); extern BOOL_T lexical_analyser (void); extern BOOL_T match_string (char *, char *, char); extern BOOL_T prove_moid_equivalence (MOID_T *, MOID_T *); extern BOOL_T whether (NODE_T * p, ...); extern char *phrase_to_text (NODE_T *, NODE_T **); extern GINFO_T *new_genie_info (void); extern int count_formal_bounds (NODE_T *); extern int count_operands (NODE_T *); extern int count_pack_members (PACK_T *); extern int first_tag_global (TABLE_T *, char *); extern int get_good_attribute (NODE_T *); extern int is_identifier_or_label_global (TABLE_T *, char *); extern KEYWORD_T *find_keyword_from_attribute (KEYWORD_T *, int); extern KEYWORD_T *find_keyword (KEYWORD_T *, char *); extern LINE_T *new_source_line (void); 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 *get_mode_from_declarer (NODE_T *); extern MOID_T *new_moid (void); extern MOID_T *register_extra_mode (MOID_T **, MOID_T *); 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 *new_node (void); extern NODE_T *reduce_dyadic (NODE_T *, int u); extern NODE_T *some_node (char *); extern NODE_T *top_down_loop (NODE_T *); extern NODE_T *top_down_skip_unit (NODE_T *); extern PACK_T *absorb_union_pack (PACK_T *); extern PACK_T *new_pack (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 void a68_parser (void); extern void add_mode_to_pack_end (PACK_T **, MOID_T *, char *, NODE_T *); extern void add_mode_to_pack (PACK_T **, MOID_T *, char *, NODE_T *); extern void append_source_line (char *, LINE_T **, int *, 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 check_parenthesis (NODE_T *); extern void coercion_inserter (NODE_T *); extern void coercion_inserter (NODE_T *); extern void collect_taxes (NODE_T *); extern void contract_union (MOID_T *); extern void count_pictures (NODE_T *, int *); extern void elaborate_bold_tags (NODE_T *); extern void extract_declarations (NODE_T *); extern void extract_declarations (NODE_T *); extern void extract_identities (NODE_T *); extern void extract_indicants (NODE_T *); extern void extract_labels (NODE_T *, int); extern void extract_operators (NODE_T *); extern void extract_priorities (NODE_T *); extern void extract_proc_identities (NODE_T *); extern void extract_proc_variables (NODE_T *); extern void extract_variables (NODE_T *); extern void fill_symbol_table_outer (NODE_T *, TABLE_T *); extern void finalise_symbol_table_setup (NODE_T *, int); extern void free_genie_heap (NODE_T *); extern void get_max_simplout_size (NODE_T *); extern void get_refinements (void); extern void ignore_superfluous_semicolons (NODE_T *); extern void init_before_tokeniser (void); extern void init_parser (void); extern void jumps_from_procs (NODE_T * p); extern void make_moid_list (MODULE_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 mark_auxilliary (NODE_T *); extern void mark_jump_in_par (NODE_T *, BOOL_T); extern void mark_moids (NODE_T *); extern void mode_checker (NODE_T *); extern void mode_checker (NODE_T *); extern void portcheck (NODE_T *); extern void preliminary_symbol_table_setup (NODE_T *); extern void prune_echoes (OPTION_LIST_T *); extern void put_refinements (void); extern void rearrange_goto_less_jumps (NODE_T *); extern void recover_from_error (NODE_T *, int, BOOL_T); extern void reduce_arguments (NODE_T *); extern void reduce_basic_declarations (NODE_T *); extern void reduce_bounds (NODE_T *); extern void reduce_branch (NODE_T *, int); extern void reduce_collateral_clauses (NODE_T *); extern void reduce_declaration_lists (NODE_T *); extern void reduce_declarers (NODE_T *, int); extern void reduce_enclosed_clauses (NODE_T *, int); extern void reduce_enquiry_clauses (NODE_T *); extern void reduce_erroneous_units (NODE_T *); extern void reduce_format_texts (NODE_T *); extern void reduce_formulae (NODE_T *); extern void reduce_generic_arguments (NODE_T *); extern void reduce (NODE_T *, void (*)(NODE_T *), BOOL_T *, ...); extern void reduce_primaries (NODE_T *, int); extern void reduce_primary_parts (NODE_T *, int); extern void reduce_right_to_left_constructs (NODE_T * q); extern void reduce_secondaries (NODE_T *); extern void reduce_serial_clauses (NODE_T *); extern void reduce_tertiaries (NODE_T *); extern void reduce_units (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 scope_checker (NODE_T *); extern void scope_checker (NODE_T *); extern void set_moid_sizes (MOID_T *); extern void set_nest (NODE_T *, NODE_T *); extern void set_proc_level (NODE_T *, int); extern void set_up_tables (void); 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 verbosity (void); extern void victal_checker (NODE_T *); extern void warn_for_unused_tags (NODE_T *); extern void widen_denotation (NODE_T *); #endif algol68g-3.1.2/src/include/a68g-platform.h0000644000175000017500000000322514361065320015035 00000000000000//! @file a68g-platform.h //! @author J. Marcel van der Veer // //! @section Copyright // // This file is part of Algol68G - an Algol 68 compiler-interpreter. // Copyright 2001-2023 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 (__A68G_PLATFORM_H__) #define __A68G_PLATFORM_H__ #if defined (BUILD_WIN32) #include "a68g-config.win32.h" #else #include "a68g-config.h" #endif // Decide on A68G "LEVEL". // // LEVEL 3 uses INT*8, REAL*10 and REAL*16 data types, when available in hardware. // LEVEL 2 builds generic A68G with INT*4 and REAL*8 data types. // LEVEL 1 is reserved for (possible) restrictive builds. #if defined (BUILD_WIN32) && defined (HAVE_QUADMATH) # define A68_LEVEL 3 #elif defined (HAVE_LONG_TYPES) && defined (HAVE_QUADMATH) # define A68_LEVEL 3 #else # define A68_LEVEL 2 # undef HAVE_MATHLIB #endif // R mathlib #if defined (HAVE_MATHLIB) # if !defined (MATHLIB_STANDALONE) # define MATHLIB_STANDALONE # endif #endif // Imported libraries #undef __cplusplus #endif algol68g-3.1.2/src/include/a68g-genie.h0000644000175000017500000003475014361065320014307 00000000000000//! @file a68g-genie.h //! @author J. Marcel van der Veer // //! @section Copyright // // This file is part of Algol68G - an Algol 68 compiler-interpreter. // Copyright 2001-2023 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 (__A68G_GENIE_H__) #define __A68G_GENIE_H__ //! @brief PROC VOID gc heap // Prelude errors can also occur in the constant folder #define CHECK_INT_SHORTEN(p, i)\ PRELUDE_ERROR (((i) > INT_MAX || (i) < -INT_MAX), p, ERROR_MATH, M_INT) #define CHECK_INT_ADDITION(p, i, j)\ PRELUDE_ERROR (\ ((j) > 0 && (i) > (A68_MAX_INT - (j))) || ((j) < 0 && (i) < (-A68_MAX_INT - (j))),\ p, "M overflow", M_INT) #define CHECK_INT_MULTIPLICATION(p, i, j)\ PRELUDE_ERROR (\ (j) != 0 && ABS (i) > A68_MAX_INT / ABS (j),\ p, "M overflow", M_INT) #define CHECK_BITS_ADDITION(p, i, j)\ if (!MODULAR_MATH (p)) {\ PRELUDE_ERROR (((i) > (A68_MAX_BITS - (j))), p, ERROR_MATH, M_BITS);\ } #define CHECK_BITS_SUBTRACTION(p, i, j)\ if (!MODULAR_MATH (p)) {\ PRELUDE_ERROR (((j) > (i)), p, ERROR_MATH, M_BITS);\ } #define CHECK_BITS_MULTIPLICATION(p, i, j)\ if (!MODULAR_MATH (p)) {\ PRELUDE_ERROR ((j) != 0 && (i) > A68_MAX_BITS / (j), p, ERROR_MATH, M_BITS);\ } #define CHECK_INT_DIVISION(p, i, j)\ PRELUDE_ERROR ((j) == 0, p, ERROR_DIVISION_BY_ZERO, M_INT) #define PRELUDE_ERROR(cond, p, txt, add)\ if (cond) {\ if (A68 (in_execution)) {\ diagnostic (A68_RUNTIME_ERROR, p, txt, add);\ exit_genie (p, A68_RUNTIME_ERROR);\ } else {\ diagnostic (A68_MATH_ERROR, p, txt, add);\ }} // Check on a NIL name #define CHECK_REF(p, z, m)\ if (! INITIALISED (&z)) {\ diagnostic (A68_RUNTIME_ERROR, (p), ERROR_EMPTY_VALUE_FROM, (m));\ exit_genie ((p), A68_RUNTIME_ERROR);\ } else if (IS_NIL (z)) {\ diagnostic (A68_RUNTIME_ERROR, (p), ERROR_ACCESSING_NIL, (m));\ exit_genie ((p), A68_RUNTIME_ERROR);\ } // Macros for row-handling #define DESCRIPTOR_SIZE(n) (SIZE_ALIGNED (A68_ARRAY) + (n) * SIZE_ALIGNED (A68_TUPLE)) #define NEW_ROW_1D(des, row, arr, tup, row_m, mod, upb)\ (des) = heap_generator (p, (row_m), DESCRIPTOR_SIZE (1));\ (row) = heap_generator (p, (row_m), (upb) * SIZE (mod));\ DIM (&(arr)) = 1;\ MOID (&(arr)) = (mod);\ ELEM_SIZE (&(arr)) = SIZE (mod);\ SLICE_OFFSET (&(arr)) = 0;\ FIELD_OFFSET (&(arr)) = 0;\ ARRAY (&(arr)) = (row);\ LWB (&(tup)) = 1;\ UPB (&(tup)) = (upb);\ SHIFT (&(tup)) = LWB (&(tup));\ SPAN (&(tup)) = 1;\ K (&(tup)) = 0;\ PUT_DESCRIPTOR ((arr), (tup), &(des)); #define GET_DESCRIPTOR(a, t, p)\ a = (A68_ARRAY *) ARRAY_ADDRESS (p);\ t = (A68_TUPLE *) & (((BYTE_T *) (a)) [SIZE_ALIGNED (A68_ARRAY)]); #define GET_DESCRIPTOR2(a, t1, t2, p)\ a = (A68_ARRAY *) ARRAY_ADDRESS (p);\ t1 = (A68_TUPLE *) & (((BYTE_T *) (a)) [SIZE_ALIGNED (A68_ARRAY)]);\ t2 = (A68_TUPLE *) & (((BYTE_T *) (a)) [SIZE_ALIGNED (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_ALIGNED (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_ALIGNED (A68_ARRAY)]) = (t1);\ *(A68_TUPLE *) &(((BYTE_T *) (a_p)) [SIZE_ALIGNED (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))) #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)) // Execution #define EXECUTE_UNIT_2(p, dest) {\ PROP_T *_prop_ = &GPROP (p);\ A68 (f_entry) = p;\ dest = (*(UNIT (_prop_))) (SOURCE (_prop_));} #define EXECUTE_UNIT(p) {\ PROP_T *_prop_ = &GPROP (p);\ A68 (f_entry) = 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 DEFAULT_PREEMPTIVE 0.8 // 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_INDEX(p, k, t) {\ if (VALUE (k) < LWB (t) || VALUE (k) > UPB (t)) {\ diagnostic (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 CHECK_REAL(p, u) PRELUDE_ERROR (!finite (u), p, ERROR_INFINITE, M_REAL) #define CHECK_COMPLEX(p, u, v) PRELUDE_ERROR (!finite (u) || !finite (v), p, ERROR_INFINITE, M_COMPLEX) #else #define CHECK_REAL(p, u) {;} #define CHECK_COMPLEX(p, u, v) {;} #endif #define MATH_RTE(p, z, m, t) PRELUDE_ERROR (z, (p), (t == NO_TEXT ? ERROR_MATH : t), (m)) // Macros. #define C_FUNCTION(p, f)\ A68 (f_entry) = p;\ A68_REAL *x;\ POP_OPERAND_ADDRESS (p, x, A68_REAL);\ errno = 0;\ VALUE (x) = f (VALUE (x));\ MATH_RTE (p, errno != 0, M_REAL, NO_TEXT); #define OWN_FUNCTION(p, f)\ A68 (f_entry) = p;\ A68_REAL *x;\ POP_OPERAND_ADDRESS (p, x, A68_REAL);\ errno = 0;\ VALUE (x) = f (p, VALUE (x));\ MATH_RTE (p, errno != 0, M_REAL, NO_TEXT); // 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);} // Macros for the evaluation stack #define INCREMENT_STACK_POINTER(err, i)\ {A68_SP += (ADDR_T) A68_ALIGN (i); (void) (err);} #define DECREMENT_STACK_POINTER(err, i)\ {A68_SP -= 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_ALIGNED (type));\ (addr) = (type *) STACK_TOP;\ } #define POP_OPERAND_ADDRESS(p, i, type) {\ (void) (p);\ (i) = (type *) (STACK_OFFSET (-SIZE_ALIGNED (type)));\ } #define POP_OPERAND_ADDRESSES(p, i, j, type) {\ DECREMENT_STACK_POINTER ((p), (int) SIZE_ALIGNED (type));\ (j) = (type *) STACK_TOP;\ (i) = (type *) (STACK_OFFSET (-SIZE_ALIGNED (type)));\ } #define POP_3_OPERAND_ADDRESSES(p, i, j, k, type) {\ DECREMENT_STACK_POINTER ((p), (int) (2 * SIZE_ALIGNED (type)));\ (k) = (type *) (STACK_OFFSET (SIZE_ALIGNED (type)));\ (j) = (type *) STACK_TOP;\ (i) = (type *) (STACK_OFFSET (-SIZE_ALIGNED (type)));\ } #define PUSH_VALUE(p, z, mode) {\ mode *_x_ = (mode *) STACK_TOP;\ STATUS (_x_) = INIT_MASK;\ VALUE (_x_) = (z);\ INCREMENT_STACK_POINTER ((p), SIZE_ALIGNED (mode));\ } #define PUSH_PRIMAL(p, z, m) {\ A68_##m *_x_ = (A68_##m *) STACK_TOP;\ int _size_ = SIZE_ALIGNED (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_ALIGNED (mode));\ } #define POP_OBJECT(p, z, mode) {\ DECREMENT_STACK_POINTER((p), SIZE_ALIGNED (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;\ a68_memmove (VALUE (_z_), k, BYTES_WIDTH);\ INCREMENT_STACK_POINTER((p), SIZE_ALIGNED (A68_BYTES));\ } #define PUSH_LONG_BYTES(p, k) {\ A68_LONG_BYTES *_z_ = (A68_LONG_BYTES *) STACK_TOP;\ STATUS (_z_) = INIT_MASK;\ a68_memmove (VALUE (_z_), k, LONG_BYTES_WIDTH);\ INCREMENT_STACK_POINTER((p), SIZE_ALIGNED (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_ALIGNED (A68_UNION));\ } // Interpreter macros #define INITIALISED(z) ((BOOL_T) (STATUS (z) & INIT_MASK)) #define MODULAR_MATH(z) ((BOOL_T) (STATUS (z) & MODULAR_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)) // Macros for check on initialisation of values #define CHECK_INIT(p, c, q)\ if (!(c)) {\ diagnostic (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 (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) < A68_GLOBALS ? A68_GLOBALS : (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));\ } // Genie routines. extern PROP_T genie_column_function (NODE_T *); extern PROP_T genie_diagonal_function (NODE_T *); extern PROP_T genie_row_function (NODE_T *); extern PROP_T genie_transpose_function (NODE_T *); extern PROP_T genie_and_function (NODE_T *); extern PROP_T genie_assertion (NODE_T *); extern PROP_T genie_assignation_constant (NODE_T *); extern PROP_T genie_assignation (NODE_T *); extern PROP_T genie_assignation_quick (NODE_T * p); extern PROP_T genie_call (NODE_T *); extern PROP_T genie_cast (NODE_T *); extern PROP_T genie_closed (volatile NODE_T *); extern PROP_T genie_coercion (NODE_T *); extern PROP_T genie_collateral (NODE_T *); extern PROP_T genie_conditional (volatile NODE_T *); extern PROP_T genie_constant (NODE_T *); extern PROP_T genie_denotation (NODE_T *); extern PROP_T genie_deproceduring (NODE_T *); extern PROP_T genie_dereference_frame_identifier (NODE_T *); extern PROP_T genie_dereference_generic_identifier (NODE_T *); extern PROP_T genie_dereference_selection_name_quick (NODE_T *); extern PROP_T genie_dereference_slice_name_quick (NODE_T *); extern PROP_T genie_dereferencing (NODE_T *); extern PROP_T genie_dereferencing_quick (NODE_T *); extern PROP_T genie_dyadic (NODE_T *); extern PROP_T genie_dyadic_quick (NODE_T *); extern PROP_T genie_enclosed (volatile NODE_T *); extern PROP_T genie_field_selection (NODE_T *); extern PROP_T genie_format_text (NODE_T *); extern PROP_T genie_formula (NODE_T *); extern PROP_T genie_frame_identifier (NODE_T *); extern PROP_T genie_identifier (NODE_T *); extern PROP_T genie_identifier_standenv (NODE_T *); extern PROP_T genie_identifier_standenv_proc (NODE_T *); extern PROP_T genie_identity_relation (NODE_T *); extern PROP_T genie_int_case (volatile NODE_T *); extern PROP_T genie_loop (volatile NODE_T *); extern PROP_T genie_loop (volatile NODE_T *); extern PROP_T genie_monadic (NODE_T *); extern PROP_T genie_nihil (NODE_T *); extern PROP_T genie_or_function (NODE_T *); extern PROP_T genie_routine_text (NODE_T *); extern PROP_T genie_rowing (NODE_T *); extern PROP_T genie_rowing_ref_row_of_row (NODE_T *); extern PROP_T genie_rowing_ref_row_row (NODE_T *); extern PROP_T genie_rowing_row_of_row (NODE_T *); extern PROP_T genie_rowing_row_row (NODE_T *); extern PROP_T genie_selection_name_quick (NODE_T *); extern PROP_T genie_selection (NODE_T *); extern PROP_T genie_selection_value_quick (NODE_T *); extern PROP_T genie_skip (NODE_T *); extern PROP_T genie_slice_name_quick (NODE_T *); extern PROP_T genie_slice (NODE_T *); extern PROP_T genie_united_case (volatile NODE_T *); extern PROP_T genie_uniting (NODE_T *); extern PROP_T genie_unit (NODE_T *); extern PROP_T genie_voiding_assignation_constant (NODE_T *); extern PROP_T genie_voiding_assignation (NODE_T *); extern PROP_T genie_voiding (NODE_T *); extern PROP_T genie_widen_int_to_real (NODE_T *); extern PROP_T genie_widen (NODE_T *); extern A68_REF genie_clone (NODE_T *, MOID_T *, A68_REF *, A68_REF *); extern A68_REF genie_make_ref_row_of_row (NODE_T *, MOID_T *, MOID_T *, ADDR_T); extern A68_REF genie_make_ref_row_row (NODE_T *, MOID_T *, MOID_T *, ADDR_T); extern A68_REF genie_make_rowrow (NODE_T *, MOID_T *, int, ADDR_T); extern void genie_clone_stack (NODE_T *, MOID_T *, A68_REF *, A68_REF *); extern void genie_serial_units_no_label (NODE_T *, ADDR_T, NODE_T **); #endif algol68g-3.1.2/src/include/a68g-diagnostics.h0000644000175000017500000003246014361065320015523 00000000000000//! @file a68g-diagnostics.h //! @author J. Marcel van der Veer // //! @section Copyright // // This file is part of Algol68G - an Algol 68 compiler-interpreter. // Copyright 2001-2023 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 (A68G_DIAGNOSTICS_H) #define A68G_DIAGNOSTICS_H extern char *error_specification (void); extern void diagnostic (STATUS_MASK_T, NODE_T *, char *, ...); extern void diagnostics_to_terminal (LINE_T *, int); extern void scan_error (LINE_T *, char *, char *); extern void scan_warning (LINE_T *, char *, char *); extern void write_source_line (FILE_T, LINE_T *, NODE_T *, int); // Error codes #define A68_NO_DIAGNOSTICS ((STATUS_MASK_T) 0x0) #define A68_ERROR ((STATUS_MASK_T) 0x1) #define A68_SYNTAX_ERROR ((STATUS_MASK_T) 0x2) #define A68_MATH_ERROR ((STATUS_MASK_T) 0x4) #define A68_MATH_WARNING ((STATUS_MASK_T) 0x8) #define A68_WARNING ((STATUS_MASK_T) 0x10) #define A68_RUNTIME_ERROR ((STATUS_MASK_T) 0x20) #define A68_SUPPRESS_SEVERITY ((STATUS_MASK_T) 0x40) #define A68_ALL_DIAGNOSTICS ((STATUS_MASK_T) 0x80) #define A68_RERUN ((STATUS_MASK_T) 0x100) #define A68_FORCE_DIAGNOSTICS ((STATUS_MASK_T) 0x200) #define A68_FORCE_QUIT ((STATUS_MASK_T) 0x400) #define A68_NO_SYNTHESIS ((STATUS_MASK_T) 0x800) // Diagnostic texts #define ERROR_ACCESSING_NIL "attempt to access N" #define ERROR_ACTION "action failed" #define ERROR_ALIGNMENT "alignment error" #define ERROR_ALLOCATION "allocation error" #define ERROR_ARGUMENT_NUMBER "incorrect number of arguments for M" #define ERROR_ASSERTION "assertion failure" #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; Y; Y" #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_INFINITE "infinite M value" #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 "Y is not a valid A" #define ERROR_INVALID_SIZE "object of invalid size" #define ERROR_INVALID_VALUE "invalid value" #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_LAPLACE "laplace transform error; Y; Y" #define ERROR_LONG_STRING "string exceeds end of line" #define ERROR_MATH "M math error" #define ERROR_MATH_CHEBYSHEV "error while evaluating Chebyshev series" #define ERROR_MATH_CONVERGENCE "no convergence" #define ERROR_MATH_EXCEPTION "math exception" #define ERROR_MATH_EXP "exp argument out of range" #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_IS_DIRECTORY "source file cannot be a directory" #define ERROR_NO_REGULAR_FILE "source is not a regular file" #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_DEPRECATED "M in this construct is deprecated in V" #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 a 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_OUT_OF_CORE_2G "insufficient memory - requesting over 2GB" #define ERROR_OVER_2G "requesting over 2GB" #define ERROR_PAGE_SIZE "error in page size" #define ERROR_PARALLEL_JUMP "jump into different thread" #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 (Y)" #define ERROR_PARENTHESIS "incorrect nesting, check for Y" #define ERROR_PARENTHESIS_2 "encountered X L but expected X, check for Y" #define ERROR_PRAGMENT "error in pragment" #define ERROR_HIGH_PRECISION "unsupported precision" #define ERROR_QUOTED_BOLD_TAG "error in quoted bold tag" #define ERROR_REDEFINED_KEYWORD "attempt to redefine keyword Y 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_RESOLVE "cannot resolve symbol" #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_EMPTY "source file contains no program" #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; Y; Y" #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_VACUUM "this vacuum cannot have row elements (use a Y 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_HIP "@ should not be in C context" #define WARNING_MATH_ACCURACY "accuracy loss due to choice of parameters" #define WARNING_MATH_PRECISION "M A precision limited due to choice of parameters" #define WARNING_OPTIMISATION "optimisation has no effect on this platform" #define WARNING_OVERFLOW "M constant overflow" #define WARNING_PRECISION "D digits precision impacts performance" #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 algol68g-3.1.2/src/include/a68g-transput.h0000644000175000017500000000755214361065320015100 00000000000000//! @file a68g-transput.h //! @author J. Marcel van der Veer // //! @section Copyright // // This file is part of Algol68G - an Algol 68 compiler-interpreter. // Copyright 2001-2023 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 (__A68G_TRANSPUT_H__) #define __A68G_TRANSPUT_H__ #if (A68_LEVEL >= 3) extern char *long_sub_whole_double (NODE_T *, QUAD_WORD_T, int); #endif extern BOOL_T convert_radix_mp (NODE_T *, MP_T *, int, int, MOID_T *, MP_T *, MP_T *); extern BOOL_T convert_radix (NODE_T *, UNSIGNED_T, int, int); extern BOOL_T genie_string_to_value_internal (NODE_T *, MOID_T *, char *, BYTE_T *); extern char digchar (int); extern char *error_chars (char *, int); extern char *fixed (NODE_T * p); extern char *get_transput_buffer (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 char pop_char_transput_buffer (int); extern char *real (NODE_T *); extern char *sub_fixed_double (NODE_T *, DOUBLE_T, int, int, int); extern char *sub_fixed (NODE_T *, REAL_T, int, int); extern char *sub_whole (NODE_T *, INT_T, int); extern char *whole (NODE_T * p); extern FILE *a68_fopen (char *, char *, char *); extern FILE_T open_physical_file (NODE_T *, A68_REF, int, mode_t); extern GPROC genie_fixed; extern GPROC genie_float; extern GPROC genie_real; extern GPROC genie_whole; extern int char_scanner (A68_FILE *); extern int end_of_format (NODE_T *, A68_REF); extern int get_replicator_value (NODE_T *, BOOL_T); extern int get_transput_buffer_index (int); extern int get_transput_buffer_size (int); extern int get_unblocked_transput_buffer (NODE_T *); extern int store_file_entry (NODE_T *, FILE_T, char *, BOOL_T); extern void add_a_string_transput_buffer (NODE_T *, int, BYTE_T *); extern void add_chars_transput_buffer (NODE_T *, int, int, char *); extern void add_string_from_stack_transput_buffer (NODE_T *, int); extern void add_string_transput_buffer (NODE_T *, int, char *); extern void end_of_file_error (NODE_T * p, A68_REF ref_file); extern void enlarge_transput_buffer (NODE_T *, int, int); extern void format_error (NODE_T *, A68_REF, char *); extern void long_standardise (NODE_T *, MP_T *, int, int, int, int *); extern void on_event_handler (NODE_T *, A68_PROCEDURE, A68_REF); extern void open_error (NODE_T *, A68_REF, char *); extern void pattern_error (NODE_T *, MOID_T *, int); extern void plusab_transput_buffer (NODE_T *, int, char); extern void plusto_transput_buffer (NODE_T *, char, int); extern void read_insertion (NODE_T *, A68_REF); extern void read_sound (NODE_T *, A68_REF, A68_SOUND *); extern void reset_transput_buffer (int); extern void set_default_event_procedure (A68_PROCEDURE *); extern void set_default_event_procedures (A68_FILE *); extern void set_transput_buffer_index (int, int); extern void set_transput_buffer_size (int, int); extern void standardise (REAL_T *, int, int, int *); extern void transput_error (NODE_T *, A68_REF, MOID_T *); extern void unchar_scanner (NODE_T *, A68_FILE *, char); extern void value_error (NODE_T *, MOID_T *, A68_REF); extern void write_insertion (NODE_T *, A68_REF, MOOD_T); extern void write_purge_buffer (NODE_T *, A68_REF, int); extern void write_sound (NODE_T *, A68_REF, A68_SOUND *); #endif algol68g-3.1.2/src/include/a68g-postulates.h0000644000175000017500000000240014361065320015406 00000000000000//! @file a68g-postulates.h //! @author J. Marcel van der Veer // //! @section Copyright // // This file is part of Algol68G - an Algol 68 compiler-interpreter. // Copyright 2001-2023 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 (__A68G_POSTULATES_H__) #define __A68G_POSTULATES_H__ extern void init_postulates (void); extern void free_postulate_list (POSTULATE_T *, POSTULATE_T *); extern void make_postulate (POSTULATE_T **, MOID_T *, MOID_T *); extern POSTULATE_T *is_postulated (POSTULATE_T *, MOID_T *); extern POSTULATE_T *is_postulated_pair (POSTULATE_T *, MOID_T *, MOID_T *); #endif algol68g-3.1.2/src/include/a68g-prelude-mathlib.h0000644000175000017500000001061414361065320016267 00000000000000//! @file a68g-prelude-mathlib.h //! @author J. Marcel van der Veer // //! @section Copyright // // This file is part of Algol68G - an Algol 68 compiler-interpreter. // Copyright 2001-2023 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 (__A68G_PRELUDE_MATHLIB_H__) #define __A68G_PRELUDE_MATHLIB_H__ #if defined (HAVE_MATHLIB) extern void stand_mathlib (void); extern void GetRNGstate (void); extern void PutRNGstate (void); extern GPROC genie_R_digamma_real; extern GPROC genie_R_trigamma_real; extern GPROC genie_R_tetragamma_real; extern GPROC genie_R_pentagamma_real; extern GPROC genie_R_psigamma_real; extern GPROC genie_R_ptukey_real; extern GPROC genie_R_qtukey_real; extern GPROC genie_R_dnorm_real; extern GPROC genie_R_pnorm_real; extern GPROC genie_R_qnorm_real; extern GPROC genie_R_rnorm_real; extern GPROC genie_R_rnorm_real; extern GPROC genie_R_dbeta_real; extern GPROC genie_R_pbeta_real; extern GPROC genie_R_qbeta_real; extern GPROC genie_R_rbeta_real; extern GPROC genie_R_dnbeta_real; extern GPROC genie_R_pnbeta_real; extern GPROC genie_R_qnbeta_real; extern GPROC genie_R_rnbeta_real; extern GPROC genie_R_dbinom_real; extern GPROC genie_R_pbinom_real; extern GPROC genie_R_qbinom_real; extern GPROC genie_R_rbinom_real; extern GPROC genie_R_dcauchy_real; extern GPROC genie_R_pcauchy_real; extern GPROC genie_R_qcauchy_real; extern GPROC genie_R_rcauchy_real; extern GPROC genie_R_dchisq_real; extern GPROC genie_R_pchisq_real; extern GPROC genie_R_qchisq_real; extern GPROC genie_R_rchisq_real; extern GPROC genie_R_dnchisq_real; extern GPROC genie_R_pnchisq_real; extern GPROC genie_R_qnchisq_real; extern GPROC genie_R_rnchisq_real; extern GPROC genie_R_dexp_real; extern GPROC genie_R_pexp_real; extern GPROC genie_R_qexp_real; extern GPROC genie_R_rexp_real; extern GPROC genie_R_df_real; extern GPROC genie_R_pf_real; extern GPROC genie_R_qf_real; extern GPROC genie_R_rf_real; extern GPROC genie_R_dnf_real; extern GPROC genie_R_pnf_real; extern GPROC genie_R_qnf_real; extern GPROC genie_R_rnf_real; extern GPROC genie_R_dgamma_real; extern GPROC genie_R_pgamma_real; extern GPROC genie_R_qgamma_real; extern GPROC genie_R_rgamma_real; extern GPROC genie_R_dgeom_real; extern GPROC genie_R_pgeom_real; extern GPROC genie_R_qgeom_real; extern GPROC genie_R_rgeom_real; extern GPROC genie_R_dhyper_real; extern GPROC genie_R_phyper_real; extern GPROC genie_R_qhyper_real; extern GPROC genie_R_rhyper_real; extern GPROC genie_R_dlogis_real; extern GPROC genie_R_plogis_real; extern GPROC genie_R_qlogis_real; extern GPROC genie_R_rlogis_real; extern GPROC genie_R_dlnorm_real; extern GPROC genie_R_plnorm_real; extern GPROC genie_R_qlnorm_real; extern GPROC genie_R_rlnorm_real; extern GPROC genie_R_dnbinom_real; extern GPROC genie_R_pnbinom_real; extern GPROC genie_R_qnbinom_real; extern GPROC genie_R_rnbinom_real; extern GPROC genie_R_dpois_real; extern GPROC genie_R_ppois_real; extern GPROC genie_R_qpois_real; extern GPROC genie_R_rpois_real; extern GPROC genie_R_dt_real; extern GPROC genie_R_pt_real; extern GPROC genie_R_qt_real; extern GPROC genie_R_rt_real; extern GPROC genie_R_dnt_real; extern GPROC genie_R_pnt_real; extern GPROC genie_R_qnt_real; extern GPROC genie_R_rnt_real; extern GPROC genie_R_dunif_real; extern GPROC genie_R_punif_real; extern GPROC genie_R_qunif_real; extern GPROC genie_R_runif_real; extern GPROC genie_R_dweibull_real; extern GPROC genie_R_pweibull_real; extern GPROC genie_R_qweibull_real; extern GPROC genie_R_rweibull_real; extern GPROC genie_R_dwilcox_real; extern GPROC genie_R_pwilcox_real; extern GPROC genie_R_qwilcox_real; extern GPROC genie_R_rwilcox_real; extern GPROC genie_R_dsignrank_real; extern GPROC genie_R_psignrank_real; extern GPROC genie_R_qsignrank_real; extern GPROC genie_R_rsignrank_real; #endif #endif algol68g-3.1.2/src/include/a68g-environ.h0000644000175000017500000000305614361065320014673 00000000000000//! @file a68g-environ.h //! @author J. Marcel van der Veer // //! @section Copyright // // This file is part of Algol68G - an Algol 68 compiler-interpreter. // Copyright 2001-2023 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 (__A68G_ENVIRON_H__) #define __A68G_ENVIRON_H__ // 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';", " START: COMMENCE:", " 'BEGIN'", NO_TEXT }; static char *quote_postlude[] = { " 'END';", " STOP: ABORT: HALT: 'SKIP'", "'END'", NO_TEXT }; #endif algol68g-3.1.2/src/include/a68g-types.h0000644000175000017500000003654514361065320014370 00000000000000//! @file a68g-types.h //! @author J. Marcel van der Veer // //! @section Copyright // // This file is part of Algol68G - an Algol 68 compiler-interpreter. // Copyright 2001-2023 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 (__A68G_TYPES_H__) #define __A68G_TYPES_H__ // Type definitions #define COMPLEX_T double complex typedef int LEAP_T; typedef struct A68_ARRAY A68_ARRAY; typedef struct A68_BITS A68_BITS; typedef struct A68_BOOL A68_BOOL; typedef struct A68_BYTES A68_BYTES; typedef struct A68_CHANNEL A68_CHANNEL; typedef struct A68_CHAR A68_CHAR; typedef struct A68_COLLITEM A68_COLLITEM; typedef struct A68_FILE A68_FILE; typedef struct A68_FORMAT A68_FORMAT; typedef struct A68_HANDLE A68_HANDLE; typedef struct A68_INT A68_INT; typedef struct A68_LONG_BYTES A68_LONG_BYTES; typedef struct A68_PROCEDURE A68_PROCEDURE; typedef struct A68_REF A68_REF, A68_ROW; typedef struct A68_SOUND A68_SOUND; typedef struct A68_STREAM A68_STREAM; typedef struct A68_TUPLE A68_TUPLE; typedef struct A68_UNION A68_UNION; typedef struct ACTIVATION_RECORD ACTIVATION_RECORD; typedef struct DEC_T DEC_T; typedef struct DIAGNOSTIC_T DIAGNOSTIC_T; typedef struct FILES_T FILES_T; typedef struct GINFO_T GINFO_T; typedef struct KEYWORD_T KEYWORD_T; typedef struct LINE_T LINE_T; typedef struct MODES_T MODES_T; typedef struct MOID_T MOID_T; typedef struct NODE_INFO_T NODE_INFO_T; typedef struct OPTION_LIST_T OPTION_LIST_T; typedef struct OPTIONS_T OPTIONS_T; typedef struct PACK_T PACK_T; typedef struct POSTULATE_T POSTULATE_T; typedef struct PROP_T PROP_T; typedef struct REFINEMENT_T REFINEMENT_T; typedef struct SOID_T SOID_T; typedef struct TABLE_T TABLE_T; typedef struct TAG_T TAG_T; typedef struct TOKEN_T TOKEN_T; typedef unt FILE_T, MOOD_T; typedef void GPROC (NODE_T *); typedef int CHAR_T; typedef PROP_T PROP_PROC (NODE_T *); typedef struct A68_REAL A68_REAL; typedef MP_T A68_LONG[DEFAULT_DOUBLE_DIGITS + 2]; typedef unt char BYTE_T; typedef BYTE_T *A68_STRUCT; struct A68_REAL { STATUS_MASK_T status; REAL_T value; } ALIGNED; struct DEC_T { char *text; int level; DEC_T *sub, *less, *more; }; struct ACTIVATION_RECORD { ADDR_T static_link, dynamic_link, dynamic_scope, parameters; NODE_T *node; jmp_buf *jump_stat; BOOL_T proc_frame; int frame_no, frame_level, parameter_level; #if defined (BUILD_PARALLEL_CLAUSE) pthread_t thread_id; #endif }; struct PROP_T { PROP_PROC *unit; NODE_T *source; }; struct A68_STREAM { char *name; FILE_T fd; BOOL_T opened, writemood; } ALIGNED; struct DIAGNOSTIC_T { int attribute, number; NODE_T *where; LINE_T *line; char *text, *symbol; DIAGNOSTIC_T *next; }; struct FILES_T { char *path, *initial_name, *generic_name; struct A68_STREAM binary, diags, library, script, object, source, listing, pretty; }; struct KEYWORD_T { int attribute; char *text; KEYWORD_T *less, *more; }; struct MODES_T { MOID_T *BITS, *BOOL, *BYTES, *CHANNEL, *CHAR, *COLLITEM, *COMPL, *COMPLEX, *C_STRING, *ERROR, *FILE, *FORMAT, *HEX_NUMBER, *HIP, *INT, *LONG_BITS, *LONG_BYTES, *LONG_COMPL, *LONG_COMPLEX, *LONG_INT, *LONG_LONG_BITS, *LONG_LONG_COMPL, *LONG_LONG_COMPLEX, *LONG_LONG_INT, *LONG_LONG_REAL, *LONG_REAL, *NUMBER, *PIPE, *PROC_REAL_REAL, *PROC_LONG_REAL_LONG_REAL, *PROC_REF_FILE_BOOL, *PROC_REF_FILE_VOID, *PROC_ROW_CHAR, *PROC_STRING, *PROC_VOID, *REAL, *REF_BITS, *REF_BOOL, *REF_BYTES, *REF_CHAR, *REF_COMPL, *REF_COMPLEX, *REF_FILE, *REF_FORMAT, *REF_INT, *REF_LONG_BITS, *REF_LONG_BYTES, *REF_LONG_COMPL, *REF_LONG_COMPLEX, *REF_LONG_INT, *REF_LONG_LONG_BITS, *REF_LONG_LONG_COMPL, *REF_LONG_LONG_COMPLEX, *REF_LONG_LONG_INT, *REF_LONG_LONG_REAL, *REF_LONG_REAL, *REF_PIPE, *REF_REAL, *REF_REF_FILE, *REF_ROW_CHAR, *REF_ROW_COMPLEX, *REF_ROW_INT, *REF_ROW_REAL, *REF_ROW_ROW_COMPLEX, *REF_ROW_ROW_REAL, *REF_SOUND, *REF_STRING, *ROW_BITS, *ROW_BOOL, *ROW_CHAR, *ROW_COMPLEX, *ROW_INT, *ROW_LONG_BITS, *ROW_LONG_LONG_BITS, *ROW_REAL, *ROW_ROW_CHAR, *ROW_ROW_COMPLEX, *ROW_ROW_REAL, *ROWS, *ROW_SIMPLIN, *ROW_SIMPLOUT, *ROW_STRING, *SEMA, *SIMPLIN, *SIMPLOUT, *SOUND, *SOUND_DATA, *STRING, *FLEX_ROW_CHAR, *FLEX_ROW_BOOL, *UNDEFINED, *VACUUM, *VOID; }; struct OPTIONS_T { OPTION_LIST_T *list; BOOL_T backtrace, brackets, check_only, clock, cross_reference, debug, compile, compile_check, keep, fold, license, moid_listing, object_listing, portcheck, pragmat_sema, pretty, reductions, regression_test, run, rerun, run_script, source_listing, standard_prelude_listing, statistics_listing, strict, stropping, trace, tree_listing, unused, verbose, version, no_warnings, quiet; int time_limit, opt_level, indent; STATUS_MASK_T nodemask; }; struct MOID_T { int attribute, dim, number, short_id, size, digits, sizec, digitsc; BOOL_T has_rows, use, portable, derivate; NODE_T *node; PACK_T *pack; MOID_T *sub, *equivalent_mode, *slice, *deflexed_mode, *name, *multiple_mode, *next, *rowed, *trim; }; #define NO_MOID ((MOID_T *) NULL) struct NODE_T { GINFO_T *genie; int number, attribute, annotation; MOID_T *type; NODE_INFO_T *info; NODE_T *next, *previous, *sub, *sequence, *nest; PACK_T *pack; STATUS_MASK_T status, codex; TABLE_T *symbol_table, *non_local; TAG_T *tag; }; #define NO_NODE ((NODE_T *) NULL) struct NODE_INFO_T { int procedure_level, priority, pragment_type; char *char_in_line, *symbol, *pragment, *expr; LINE_T *line; }; struct GINFO_T { PROP_T propagator; BOOL_T is_coercion, is_new_lexical_level, need_dns; BYTE_T *offset; MOID_T *partial_proc, *partial_locale; NODE_T *parent; char *compile_name; int level, argsize, size, compile_node; void *constant; }; struct OPTION_LIST_T { char *str; int scan; BOOL_T processed; LINE_T *line; OPTION_LIST_T *next; }; struct PACK_T { MOID_T *type; char *text; NODE_T *node; PACK_T *next, *previous; int size; ADDR_T offset; }; struct POSTULATE_T { MOID_T *a, *b; POSTULATE_T *next; }; struct REFINEMENT_T { REFINEMENT_T *next; char *name; LINE_T *line_defined, *line_applied; int applications; NODE_T *node_defined, *begin, *end; }; struct SOID_T { int attribute, sort, cast; MOID_T *type; NODE_T *node; SOID_T *next; }; struct LINE_T { char marker[6], *string, *filename; DIAGNOSTIC_T *diagnostics; int number, print_status; BOOL_T list; LINE_T *next, *previous; }; #define NO_LINE ((LINE_T *) NULL) struct TABLE_T { int num, level, nest, attribute; BOOL_T initialise_frame, initialise_anon, proc_ops; ADDR_T ap_increment; TABLE_T *previous, *outer; TAG_T *identifiers, *operators, *priority, *indicants, *labels, *anonymous; NODE_T *jump_to, *sequence; }; #define NO_TABLE ((TABLE_T *) NULL) struct TAG_T { STATUS_MASK_T status, codex; TABLE_T *symbol_table; MOID_T *type; NODE_T *node, *unit; char *value; GPROC *procedure; BOOL_T scope_assigned, use, in_proc, a68_standenv_proc, loc_assigned, portable; int priority, heap, scope, size, youngest_environ, number; ADDR_T offset; TAG_T *next, *body; }; #define NO_TAG ((TAG_T *) NULL) struct TOKEN_T { char *text; TOKEN_T *less, *more; }; //! @struct A68_HANDLE //! @brief Handle for REF into the HEAP. //! @details //! A REF into the HEAP points at a HANDLE. //! The HANDLE points at the actual object in the HEAP. //! Garbage collection modifies HANDLEs, but not REFs. struct A68_HANDLE { STATUS_MASK_T status; BYTE_T *pointer; int size; MOID_T *type; A68_HANDLE *next, *previous; } ALIGNED; //! @struct A68_REF //! @brief Fat A68 pointer. struct A68_REF { STATUS_MASK_T status; ADDR_T offset; ADDR_T scope; // Dynamic scope. A68_HANDLE *handle; } ALIGNED; //! @struct A68_ARRAY //! @brief A68 array descriptor. //! @details //! A row is an A68_REF to an A68_ARRAY. //! //! An A68_ARRAY is followed by one A68_TUPLE per dimension. //! //! @verbatim //! 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! //! @endverbatim struct A68_ARRAY { MOID_T *type; int dim, elem_size; ADDR_T slice_offset, field_offset; A68_REF array; } ALIGNED; struct A68_BITS { STATUS_MASK_T status; UNSIGNED_T value; } ALIGNED; struct A68_BYTES { STATUS_MASK_T status; char value[BYTES_WIDTH + 1]; } ALIGNED; struct A68_CHANNEL { STATUS_MASK_T status; BOOL_T reset, set, get, put, bin, draw, compress; } ALIGNED; struct A68_BOOL { STATUS_MASK_T status; BOOL_T value; } ALIGNED; struct A68_CHAR { STATUS_MASK_T status; CHAR_T value; } ALIGNED; struct A68_COLLITEM { STATUS_MASK_T status; int count; }; struct A68_INT { STATUS_MASK_T status; INT_T value; } ALIGNED; //! @struct A68_FORMAT //! @brief A68 format descriptor. //! @details //! A format behaves very much like a procedure. struct A68_FORMAT { STATUS_MASK_T status; NODE_T *body; // Entry point in syntax tree. ADDR_T fp_environ; // Frame pointer to environ. } ALIGNED; struct A68_LONG_BYTES { STATUS_MASK_T status; char value[LONG_BYTES_WIDTH + 1]; } ALIGNED; //! @struct A68_PROCEDURE //! @brief A68 procedure descriptor. struct A68_PROCEDURE { STATUS_MASK_T 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 fp_environ; // Frame pointer to environ. } ALIGNED; typedef A68_REAL A68_COMPLEX[2]; //! @struct A68_TUPLE //! @brief A tuple containing bounds etcetera for one dimension. struct A68_TUPLE { INT_T upper_bound, lower_bound, shift, span, k; } ALIGNED; struct A68_UNION { STATUS_MASK_T status; void *value; } ALIGNED; struct A68_SOUND { STATUS_MASK_T status; unt num_channels, sample_rate, bits_per_sample, num_samples, data_size; A68_REF data; }; struct A68_FILE { STATUS_MASK_T 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; REAL_T x_coord, y_coord, red, green, blue; } device; #if defined (HAVE_POSTGRESQL) # if ! defined (A68_OPTIMISE) PGconn *connection; PGresult *result; # endif #endif }; #define M_BITS (MODE (BITS)) #define M_BOOL (MODE (BOOL)) #define M_BYTES (MODE (BYTES)) #define M_CHANNEL (MODE (CHANNEL)) #define M_CHAR (MODE (CHAR)) #define M_COLLITEM (MODE (COLLITEM)) #define M_COMPL (MODE (COMPL)) #define M_COMPLEX (MODE (COMPLEX)) #define M_C_STRING (MODE (C_STRING)) #define M_ERROR (MODE (ERROR)) #define M_FILE (MODE (FILE)) #define M_FLEX_ROW_BOOL (MODE (FLEX_ROW_BOOL)) #define M_FLEX_ROW_CHAR (MODE (FLEX_ROW_CHAR)) #define M_HEX_NUMBER (MODE (HEX_NUMBER)) #define M_HIP (MODE (HIP)) #define M_INT (MODE (INT)) #define M_LONG_BITS (MODE (LONG_BITS)) #define M_LONG_BYTES (MODE (LONG_BYTES)) #define M_LONG_COMPL (MODE (LONG_COMPL)) #define M_LONG_COMPLEX (MODE (LONG_COMPLEX)) #define M_LONG_INT (MODE (LONG_INT)) #define M_LONG_LONG_BITS (MODE (LONG_LONG_BITS)) #define M_LONG_LONG_COMPL (MODE (LONG_LONG_COMPL)) #define M_LONG_LONG_COMPLEX (MODE (LONG_LONG_COMPLEX)) #define M_LONG_LONG_INT (MODE (LONG_LONG_INT)) #define M_LONG_LONG_REAL (MODE (LONG_LONG_REAL)) #define M_LONG_REAL (MODE (LONG_REAL)) #define M_NIL (MODE (NIL)) #define M_NUMBER (MODE (NUMBER)) #define M_PIPE (MODE (PIPE)) #define M_PROC_REAL_REAL (MODE (PROC_REAL_REAL)) #define M_PROC_LONG_REAL_LONG_REAL (MODE (PROC_LONG_REAL_LONG_REAL)) #define M_PROC_REF_FILE_BOOL (MODE (PROC_REF_FILE_BOOL)) #define M_PROC_REF_FILE_VOID (MODE (PROC_REF_FILE_VOID)) #define M_PROC_ROW_CHAR (MODE (PROC_ROW_CHAR)) #define M_PROC_STRING (MODE (PROC_STRING)) #define M_PROC_VOID (MODE (PROC_VOID)) #define M_REAL (MODE (REAL)) #define M_REF_BITS (MODE (REF_BITS)) #define M_REF_BOOL (MODE (REF_BOOL)) #define M_REF_BYTES (MODE (REF_BYTES)) #define M_REF_CHAR (MODE (REF_CHAR)) #define M_REF_COMPL (MODE (REF_COMPL)) #define M_REF_COMPLEX (MODE (REF_COMPLEX)) #define M_REF_FILE (MODE (REF_FILE)) #define M_REF_FORMAT (MODE (REF_FORMAT)) #define M_REF_INT (MODE (REF_INT)) #define M_REF_LONG_BITS (MODE (REF_LONG_BITS)) #define M_REF_LONG_BYTES (MODE (REF_LONG_BYTES)) #define M_REF_LONG_COMPL (MODE (REF_LONG_COMPL)) #define M_REF_LONG_COMPLEX (MODE (REF_LONG_COMPLEX)) #define M_REF_LONG_INT (MODE (REF_LONG_INT)) #define M_REF_LONG_LONG_COMPL (MODE (REF_LONG_LONG_COMPL)) #define M_REF_LONG_LONG_COMPLEX (MODE (REF_LONG_LONG_COMPLEX)) #define M_REF_LONG_LONG_INT (MODE (REF_LONG_LONG_INT)) #define M_REF_LONG_LONG_REAL (MODE (REF_LONG_LONG_REAL)) #define M_REF_LONG_REAL (MODE (REF_LONG_REAL)) #define M_REF_PIPE (MODE (REF_PIPE)) #define M_REF_REAL (MODE (REF_REAL)) #define M_REF_REF_FILE (MODE (REF_REF_FILE)) #define M_REF_ROW_CHAR (MODE (REF_ROW_CHAR)) #define M_REF_ROW_COMPLEX (MODE (REF_ROW_COMPLEX)) #define M_REF_ROW_INT (MODE (REF_ROW_INT)) #define M_REF_ROW_REAL (MODE (REF_ROW_REAL)) #define M_REF_ROW_ROW_COMPLEX (MODE (REF_ROW_ROW_COMPLEX)) #define M_REF_ROW_ROW_REAL (MODE (REF_ROW_ROW_REAL)) #define M_REF_SOUND (MODE (REF_SOUND)) #define M_REF_STRING (MODE (REF_STRING)) #define M_ROW_BITS (MODE (ROW_BITS)) #define M_ROW_BOOL (MODE (ROW_BOOL)) #define M_ROW_CHAR (MODE (ROW_CHAR)) #define M_ROW_COMPLEX (MODE (ROW_COMPLEX)) #define M_ROW_INT (MODE (ROW_INT)) #define M_ROW_LONG_BITS (MODE (ROW_LONG_BITS)) #define M_ROW_LONG_LONG_BITS (MODE (ROW_LONG_LONG_BITS)) #define M_ROW_REAL (MODE (ROW_REAL)) #define M_ROW_ROW_CHAR (MODE (ROW_ROW_CHAR)) #define M_ROW_ROW_COMPLEX (MODE (ROW_ROW_COMPLEX)) #define M_ROW_ROW_REAL (MODE (ROW_ROW_REAL)) #define M_ROW_SIMPLIN (MODE (ROW_SIMPLIN)) #define M_ROW_SIMPLOUT (MODE (ROW_SIMPLOUT)) #define M_ROW_STRING (MODE (ROW_STRING)) #define M_SEMA (MODE (SEMA)) #define M_SIMPLIN (MODE (SIMPLIN)) #define M_SIMPLOUT (MODE (SIMPLOUT)) #define M_SOUND_DATA (MODE (SOUND_DATA)) #define M_STRING (MODE (STRING)) #define M_UNDEFINED (MODE (UNDEFINED)) #define M_VACUUM (MODE (VACUUM)) #define M_VOID (MODE (VOID)) #define M_FORMAT (MODE (FORMAT)) #define M_ROWS (MODE (ROWS)) #define M_SOUND (MODE (SOUND)) #endif algol68g-3.1.2/src/include/a68g-mp.h0000644000175000017500000004673614361065320013643 00000000000000//! @file a68g-mp.h //! @author J. Marcel van der Veer // //! @section Copyright // // This file is part of Algol68G - an Algol 68 compiler-interpreter. // Copyright 2001-2023 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 (__A68G_MP_H__) #define __A68G_MP_H__ // A68G's multiprecision algorithms are not suited for more than a few hundred // digits. This is however sufficient for most practical MP applications. #define MP_MAX_DECIMALS 250 #define MP_STATUS(z) ((z)[0]) #define MP_EXPONENT(z) ((z)[1]) #define MP_DIGIT(z, n) ((z)[(n) + 1]) #define MP_SIGN(z) (SIGN (MP_DIGIT (z, 1))) #define LEN_MP(digs) (2 + digs) #define SIZE_MP(digs) A68_ALIGN (LEN_MP (digs) * sizeof (MP_T)) #define IS_ZERO_MP(z) (MP_DIGIT (z, 1) == (MP_T) 0) #define PLUS_INF_MP(u) ((UNSIGNED_T) MP_STATUS (u) & PLUS_INF_MASK) #define MINUS_INF_MP(u) ((UNSIGNED_T) MP_STATUS (u) & MINUS_INF_MASK) #define INF_MP(u) (PLUS_INF_MP (u) || MINUS_INF_MP (u)) #define CHECK_LONG_REAL(p, u, moid) PRELUDE_ERROR (INF_MP (u), p, ERROR_INFINITE, moid) static inline MP_T *set_mp (MP_T * z, MP_T x, INT_T expo, int digs) { memset (z, 0, SIZE_MP (digs)); MP_STATUS (z) = (MP_T) INIT_MASK; MP_DIGIT (z, 1) = x; MP_EXPONENT (z) = (MP_T) expo; return z; } static inline MP_T *move_mp (MP_T *z, MP_T *x, int N) { MP_T *y = z; N += 2; while (N--) { *z++ = *x++; } return y; } static inline MP_T *move_mp_part (MP_T *z, MP_T *x, int N) { MP_T *y = z; while (N--) { *z++ = *x++; } return y; } static inline void check_mp_exp (NODE_T *p, MP_T *z) { MP_T expo = (MP_EXPONENT (z) < 0 ? -MP_EXPONENT (z) : MP_EXPONENT (z)); if (expo > MAX_MP_EXPONENT || (expo == MAX_MP_EXPONENT && ABS (MP_DIGIT (z, 1)) > (MP_T) 1)) { errno = EDOM; diagnostic (A68_RUNTIME_ERROR, p, ERROR_MP_OUT_OF_BOUNDS, NULL); extern void exit_genie (NODE_T *, int); exit_genie (p, A68_RUNTIME_ERROR); } } static inline MP_T *mp_one (int digs) { if (digs > A68_MP (mp_one_size)) { if (A68_MP (mp_one) != (MP_T *) NULL) { a68_free (A68_MP (mp_one)); } A68_MP (mp_one) = (MP_T *) get_heap_space (SIZE_MP (digs)); set_mp (A68_MP (mp_one), 1, 0, digs); } return A68_MP (mp_one); } static inline MP_T *lit_mp (NODE_T *p, MP_T u, INT_T expo, int digs) { ADDR_T pop_sp = A68_SP; if ((A68_SP += SIZE_MP (digs)) > A68 (expr_stack_limit)) { diagnostic (A68_RUNTIME_ERROR, p, ERROR_STACK_OVERFLOW); extern void exit_genie (NODE_T *, int); exit_genie (p, A68_RUNTIME_ERROR); } MP_T *z = (MP_T *) STACK_ADDRESS (pop_sp); (void) set_mp (z, u, expo, digs); return z; } static inline MP_T *nil_mp (NODE_T *p, int digs) { ADDR_T pop_sp = A68_SP; if ((A68_SP += SIZE_MP (digs)) > A68 (expr_stack_limit)) { diagnostic (A68_RUNTIME_ERROR, p, ERROR_STACK_OVERFLOW); extern void exit_genie (NODE_T *, int); exit_genie (p, A68_RUNTIME_ERROR); } MP_T *z = (MP_T *) STACK_ADDRESS (pop_sp); (void) set_mp (z, 0, 0, digs); return z; } static inline MP_T *empty_mp (NODE_T *p, int digs) { ADDR_T pop_sp = A68_SP; if ((A68_SP += SIZE_MP (digs)) > A68 (expr_stack_limit)) { diagnostic (A68_RUNTIME_ERROR, p, ERROR_STACK_OVERFLOW); extern void exit_genie (NODE_T *, int); exit_genie (p, A68_RUNTIME_ERROR); } return (MP_T *) STACK_ADDRESS (pop_sp); } extern MP_T *lengthen_mp (NODE_T *, MP_T *, int, MP_T *, int); static inline MP_T *len_mp (NODE_T *p, MP_T *u, int digs, int gdigs) { ADDR_T pop_sp = A68_SP; if ((A68_SP += SIZE_MP (gdigs)) > A68 (expr_stack_limit)) { diagnostic (A68_RUNTIME_ERROR, p, ERROR_STACK_OVERFLOW); extern void exit_genie (NODE_T *, int); exit_genie (p, A68_RUNTIME_ERROR); } MP_T *z = (MP_T *) STACK_ADDRESS (pop_sp); for (int k = 1; k <= digs; k++) { MP_DIGIT (z, k) = MP_DIGIT (u, k); } for (int k = digs + 1; k <= gdigs; k++) { MP_DIGIT (z, k) = (MP_T) 0; } MP_EXPONENT (z) = MP_EXPONENT (u); MP_STATUS (z) = MP_STATUS (u); return z; } static inline MP_T *cut_mp (NODE_T *p, MP_T *u, int digs, int gdigs) { ADDR_T pop_sp = A68_SP; ASSERT (digs > gdigs); BOOL_T neg = MP_DIGIT (u, 1) < 0; if ((A68_SP += SIZE_MP (gdigs)) > A68 (expr_stack_limit)) { diagnostic (A68_RUNTIME_ERROR, p, ERROR_STACK_OVERFLOW); extern void exit_genie (NODE_T *, int); exit_genie (p, A68_RUNTIME_ERROR); } MP_T *z = (MP_T *) STACK_ADDRESS (pop_sp); for (int k = 1; k <= gdigs; k++) { MP_DIGIT (z, k) = MP_DIGIT (u, k); } if (neg) { MP_DIGIT (z, 1) = -MP_DIGIT (z, 1); } if (MP_DIGIT (u, gdigs + 1) >= MP_RADIX / 2) { MP_DIGIT (z, gdigs) += 1; for (int k = digs; k >= 2 && MP_DIGIT (z, k) == MP_RADIX; k --) { MP_DIGIT (z, k) = 0; MP_DIGIT (z, k - 1) ++; } } if (neg) { MP_DIGIT (z, 1) = -MP_DIGIT (z, 1); } MP_EXPONENT (z) = MP_EXPONENT (u); MP_STATUS (z) = MP_STATUS (u); return z; } //! @brief Length in bytes of a long mp number. static inline size_t size_mp (void) { return (size_t) SIZE_MP (LONG_MP_DIGITS); } //! @brief Length in digits of a long mp number. static inline int mp_digits (void) { return LONG_MP_DIGITS; } //! @brief Length in bytes of a long long mp number. static inline size_t size_long_mp (void) { return (size_t) (SIZE_MP (A68_MP (varying_mp_digits))); } //! @brief digits in a long mp number. static inline int long_mp_digits (void) { return A68_MP (varying_mp_digits); } #define SET_MP_ZERO(z, digits)\ (void) set_mp ((z), 0, 0, digits); #define SET_MP_ONE(z, digits)\ (void) set_mp ((z), (MP_T) 1, 0, digits); #define SET_MP_MINUS_ONE(z, digits)\ (void) set_mp ((z), (MP_T) -1, 0, digits); #define SET_MP_HALF(z, digits)\ (void) set_mp ((z), (MP_T) (MP_RADIX / 2), -1, digits); #define SET_MP_MINUS_HALF(z, digits)\ (void) set_mp ((z), (MP_T) -(MP_RADIX / 2), -1, digits); #define SET_MP_QUART(z, digits)\ (void) set_mp ((z), (MP_T) (MP_RADIX / 4), -1, digits); enum {MP_SQRT_PI, MP_PI, MP_LN_PI, MP_SQRT_TWO_PI, MP_TWO_PI, MP_HALF_PI, MP_180_OVER_PI, MP_PI_OVER_180}; // If MP_DOUBLE_PRECISION is defined functions are evaluated in double precision. #undef MP_DOUBLE_PRECISION #define MINIMUM(x, y) ((x) < (y) ? (x) : (y)) // GUARD_DIGITS: number of guard digits. #if defined (MP_DOUBLE_PRECISION) #define GUARD_DIGITS(digits) (digits) #else #define GUARD_DIGITS(digits) (2) #endif #define FUN_DIGITS(n) ((n) + GUARD_DIGITS (n)) // External multi-precision procedures extern BOOL_T check_mp_int (MP_T *, MOID_T *); extern BOOL_T is_int_mp (NODE_T *p, MP_T *z, int digits); extern BOOL_T same_mp (NODE_T *, MP_T *, MP_T *, int); extern int long_mp_digits (void); extern INT_T mp_to_int (NODE_T *, MP_T *, int); extern int width_to_mp_digits (int); extern MP_T *abs_mp (NODE_T *, MP_T *, MP_T *, int); extern MP_T *acosdg_mp (NODE_T *, MP_T *, MP_T *, int); extern MP_T *acosh_mp (NODE_T *, MP_T *, MP_T *, int); extern MP_T *acos_mp (NODE_T *, MP_T *, MP_T *, int); extern MP_T *acotdg_mp (NODE_T *, MP_T *, MP_T *, int); extern MP_T *acot_mp (NODE_T *, MP_T *, MP_T *, int); extern MP_T *acsc_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 *align_mp (MP_T *, INT_T *, int); extern MP_T *asec_mp (NODE_T *, MP_T *, MP_T *, int); extern MP_T *asindg_mp (NODE_T *, MP_T *, MP_T *, int); extern MP_T *asinh_mp (NODE_T *, MP_T *, MP_T *, int); extern MP_T *asin_mp (NODE_T *, MP_T *, MP_T *, int); extern MP_T *atan2dg_mp (NODE_T *, MP_T *, MP_T *, MP_T *, int); extern MP_T *atan2_mp (NODE_T *, MP_T *, MP_T *, MP_T *, int); extern MP_T *atandg_mp (NODE_T *, MP_T *, MP_T *, int); extern MP_T *atanh_mp (NODE_T *, MP_T *, MP_T *, int); extern MP_T *atan_mp (NODE_T *, MP_T *, MP_T *, int); extern MP_T *beta_inc_mp (NODE_T *, MP_T *, MP_T *, MP_T *, MP_T *, int); extern MP_T *beta_mp (NODE_T *, MP_T *, MP_T *, MP_T *, int); extern MP_T *cacosh_mp (NODE_T *, MP_T *, MP_T *, int); extern MP_T *cacos_mp (NODE_T *, MP_T *, MP_T *, int); extern MP_T *casinh_mp (NODE_T *, MP_T *, MP_T *, int); extern MP_T *casin_mp (NODE_T *, MP_T *, MP_T *, int); extern MP_T *catanh_mp (NODE_T *, MP_T *, MP_T *, int); extern MP_T *catan_mp (NODE_T *, MP_T *, MP_T *, int); extern MP_T *ccosh_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 *cosdg_mp (NODE_T *, MP_T *, MP_T *, int); extern MP_T *cosh_mp (NODE_T *, MP_T *, MP_T *, int); extern MP_T *cos_mp (NODE_T *, MP_T *, MP_T *, int); extern MP_T *cospi_mp (NODE_T *, MP_T *, MP_T *, int); extern MP_T *cotdg_mp (NODE_T *, MP_T *, MP_T *, int); extern MP_T *cot_mp (NODE_T *, MP_T *, MP_T *, int); extern MP_T *cotpi_mp (NODE_T *, MP_T *, MP_T *, int); extern MP_T *csc_mp (NODE_T *, MP_T *, MP_T *, int); extern MP_T *csinh_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 *ctanh_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_digit (NODE_T *, MP_T *, MP_T *, MP_T, int); extern MP_T *div_mp (NODE_T *, MP_T *, MP_T *, MP_T *, int); extern MP_T *entier_mp (NODE_T *, MP_T *, MP_T *, int); extern MP_T *erfc_mp (NODE_T *, MP_T *, MP_T *, int); extern MP_T *erf_mp (NODE_T *, MP_T *, MP_T *, int); extern MP_T *expm1_mp (NODE_T *, MP_T *, MP_T *, int); extern MP_T *exp_mp (NODE_T *, MP_T *, MP_T *, int); extern MP_T *floor_mp (NODE_T *, MP_T *, MP_T *, int); extern MP_T *gamma_inc_mp (NODE_T *, MP_T *, MP_T *, MP_T *, int); extern MP_T *gamma_mp (NODE_T *, MP_T *, MP_T *, int); extern MP_T *half_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_T, int); extern MP_T *inverfc_mp (NODE_T *, MP_T *, MP_T *, int); extern MP_T *inverf_mp (NODE_T *, MP_T *, MP_T *, int); extern MP_T *lnbeta_mp (NODE_T *, MP_T *, MP_T *, MP_T *, int); extern MP_T *lngamma_mp (NODE_T *, MP_T *, 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 *minus_mp (NODE_T *, MP_T *, MP_T *, int); extern MP_T *minus_one_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_ln_10 (NODE_T *, MP_T *, int); extern MP_T *mp_ln_scale (NODE_T *, MP_T *, int); extern MP_T *mp_pi (NODE_T *, MP_T *, int, int); extern MP_T *ten_up_mp (NODE_T *, MP_T *, int, int); extern MP_T *mul_mp_digit (NODE_T *, MP_T *, MP_T *, MP_T, int); extern MP_T *mul_mp (NODE_T *, MP_T *, MP_T *, MP_T *, int); extern MP_T *one_minus_mp (NODE_T *, MP_T *, MP_T *, int); extern MP_T *over_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 *plus_one_mp (NODE_T *, MP_T *, MP_T *, int); extern MP_T *pow_mp_int (NODE_T *, MP_T *, MP_T *, INT_T, int); extern MP_T *pow_mp (NODE_T *, MP_T *, MP_T *, MP_T *, int); extern MP_T *real_to_mp (NODE_T *, MP_T *, REAL_T, int); extern MP_T *rec_mp (NODE_T *, MP_T *, MP_T *, int); extern MP_T *round_mp (NODE_T *, MP_T *, MP_T *, int); extern MP_T *sec_mp (NODE_T *, MP_T *, MP_T *, int); extern MP_T *set_mp (MP_T *, MP_T, INT_T, int); extern MP_T *shorten_mp (NODE_T *, MP_T *, int, MP_T *, int); extern MP_T *sindg_mp (NODE_T *, MP_T *, MP_T *, int); extern MP_T *sinh_mp (NODE_T *, MP_T *, MP_T *, int); extern MP_T *sin_mp (NODE_T *, MP_T *, MP_T *, int); extern MP_T *sinpi_mp (NODE_T *, MP_T *, MP_T *, int); extern MP_T *sqrt_mp (NODE_T *, MP_T *, MP_T *, int); extern MP_T *strtomp (NODE_T *, MP_T *, char *, int); extern MP_T *sub_mp (NODE_T *, MP_T *, MP_T *, MP_T *, int); extern MP_T *tandg_mp (NODE_T *, MP_T *, MP_T *, int); extern MP_T *tanh_mp (NODE_T *, MP_T *, MP_T *, int); extern MP_T *tan_mp (NODE_T *, MP_T *, MP_T *, int); extern MP_T *tanpi_mp (NODE_T *, MP_T *, MP_T *, int); extern MP_T *tenth_mp (NODE_T *, MP_T *, MP_T *, int); extern MP_T *trunc_mp (NODE_T *, MP_T *, MP_T *, int); extern MP_T *unt_to_mp (NODE_T *, MP_T *, UNSIGNED_T, int); extern REAL_T mp_to_real (NODE_T *, MP_T *, int); extern void eq_mp (NODE_T *, A68_BOOL *, MP_T *, MP_T *, int); extern void ge_mp (NODE_T *, A68_BOOL *, MP_T *, MP_T *, int); extern void genie_pi_mp (NODE_T *); extern void gt_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 lt_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 raw_write_mp (char *, MP_T *, int); extern void set_long_mp_digits (int); extern void test_long_int_range (NODE_T *, MP_T *, MOID_T *); extern GPROC genie_infinity_mp; extern GPROC genie_minus_infinity_mp; extern GPROC genie_beta_inc_mp; extern GPROC genie_gamma_inc_mp; extern GPROC genie_gamma_inc_f_mp; extern GPROC genie_gamma_inc_g_mp; extern GPROC genie_gamma_inc_h_mp; extern GPROC genie_gamma_inc_gf_mp; extern GPROC genie_abs_mp; extern GPROC genie_abs_mp_complex; extern GPROC genie_acosdg_mp; extern GPROC genie_acosdg_mp; extern GPROC genie_acosh_mp; extern GPROC genie_acosh_mp_complex; extern GPROC genie_acos_mp; extern GPROC genie_acos_mp_complex; extern GPROC genie_acotdg_mp; extern GPROC genie_acot_mp; extern GPROC genie_asec_mp; extern GPROC genie_acsc_mp; extern GPROC genie_add_mp; extern GPROC genie_add_mp_complex; extern GPROC genie_and_mp; extern GPROC genie_arg_mp_complex; extern GPROC genie_asindg_mp; extern GPROC genie_asindg_mp; extern GPROC genie_asinh_mp; extern GPROC genie_asinh_mp_complex; extern GPROC genie_asin_mp; extern GPROC genie_asin_mp_complex; extern GPROC genie_atan2_mp; extern GPROC genie_atandg_mp; extern GPROC genie_atan2dg_mp; extern GPROC genie_atanh_mp; extern GPROC genie_atanh_mp_complex; extern GPROC genie_atan_mp; extern GPROC genie_atan_mp_complex; extern GPROC genie_bin_mp; extern GPROC genie_clear_long_mp_bits; extern GPROC genie_conj_mp_complex; extern GPROC genie_cosdg_mp; extern GPROC genie_cosh_mp; extern GPROC genie_cosh_mp_complex; extern GPROC genie_cos_mp; extern GPROC genie_cos_mp_complex; extern GPROC genie_cospi_mp; extern GPROC genie_cotdg_mp; extern GPROC genie_cot_mp; extern GPROC genie_sec_mp; extern GPROC genie_csc_mp; extern GPROC genie_cotpi_mp; extern GPROC genie_curt_mp; extern GPROC genie_divab_mp; extern GPROC genie_divab_mp_complex; extern GPROC genie_div_mp; extern GPROC genie_div_mp_complex; extern GPROC genie_elem_long_mp_bits; extern GPROC genie_elem_long_mp_bits; extern GPROC genie_entier_mp; extern GPROC genie_eq_mp; extern GPROC genie_eq_mp_complex; extern GPROC genie_erfc_mp; extern GPROC genie_erf_mp; extern GPROC genie_exp_mp; extern GPROC genie_exp_mp_complex; extern GPROC genie_gamma_mp; extern GPROC genie_lngamma_mp; extern GPROC genie_beta_mp; extern GPROC genie_lnbeta_mp; extern GPROC genie_ge_mp; extern GPROC genie_get_long_mp_bits; extern GPROC genie_get_long_mp_complex; extern GPROC genie_get_long_mp_int; extern GPROC genie_get_long_mp_real; extern GPROC genie_get_mp_complex; extern GPROC genie_gt_mp; extern GPROC genie_im_mp_complex; extern GPROC genie_inverfc_mp; extern GPROC genie_inverf_mp; extern GPROC genie_le_mp; extern GPROC genie_lengthen_complex_to_mp_complex; extern GPROC genie_lengthen_int_to_mp; extern GPROC genie_lengthen_mp_complex_to_long_mp_complex; extern GPROC genie_lengthen_mp_to_long_mp; extern GPROC genie_lengthen_real_to_mp; extern GPROC genie_lengthen_unt_to_mp; extern GPROC genie_ln_mp; extern GPROC genie_ln_mp_complex; extern GPROC genie_log_mp; extern GPROC genie_long_mp_bits_width; extern GPROC genie_long_mp_exp_width; extern GPROC genie_long_mp_int_width; extern GPROC genie_long_mp_max_bits; extern GPROC genie_long_mp_max_int; extern GPROC genie_long_mp_max_real; extern GPROC genie_long_mp_min_real; extern GPROC genie_long_mp_real_width; extern GPROC genie_long_mp_small_real; extern GPROC genie_lt_mp; extern GPROC genie_minusab_mp; extern GPROC genie_minusab_mp_complex; extern GPROC genie_minus_mp; extern GPROC genie_minus_mp_complex; extern GPROC genie_modab_mp; extern GPROC genie_mod_mp; extern GPROC genie_mul_mp; extern GPROC genie_mul_mp_complex; extern GPROC genie_ne_mp; extern GPROC genie_ne_mp_complex; extern GPROC genie_not_mp; extern GPROC genie_odd_mp; extern GPROC genie_or_mp; extern GPROC genie_overab_mp; extern GPROC genie_over_mp; extern GPROC genie_pi_mp; extern GPROC genie_plusab_mp; extern GPROC genie_plusab_mp_complex; extern GPROC genie_pow_mp; extern GPROC genie_pow_mp_complex_int; extern GPROC genie_pow_mp_int; extern GPROC genie_pow_mp_int_int; extern GPROC genie_print_long_mp_bits; extern GPROC genie_print_long_mp_complex; extern GPROC genie_print_long_mp_int; extern GPROC genie_print_long_mp_real; extern GPROC genie_print_mp_complex; extern GPROC genie_put_long_mp_bits; extern GPROC genie_put_long_mp_complex; extern GPROC genie_put_long_mp_int; extern GPROC genie_put_long_mp_real; extern GPROC genie_put_mp_complex; extern GPROC genie_read_long_mp_bits; extern GPROC genie_read_long_mp_complex; extern GPROC genie_read_long_mp_int; extern GPROC genie_read_long_mp_real; extern GPROC genie_read_mp_complex; extern GPROC genie_re_mp_complex; extern GPROC genie_round_mp; extern GPROC genie_set_long_mp_bits; extern GPROC genie_shl_mp; extern GPROC genie_shorten_long_mp_complex_to_mp_complex; extern GPROC genie_shorten_long_mp_to_mp; extern GPROC genie_shorten_mp_complex_to_complex; extern GPROC genie_shorten_mp_to_bits; extern GPROC genie_shorten_mp_to_int; extern GPROC genie_shorten_mp_to_real; extern GPROC genie_shr_mp; extern GPROC genie_sign_mp; extern GPROC genie_sindg_mp; extern GPROC genie_sinh_mp; extern GPROC genie_sinh_mp_complex; extern GPROC genie_sin_mp; extern GPROC genie_sin_mp_complex; extern GPROC genie_sinpi_mp; extern GPROC genie_sqrt_mp; extern GPROC genie_sqrt_mp_complex; extern GPROC genie_sub_mp; extern GPROC genie_sub_mp_complex; extern GPROC genie_tandg_mp; extern GPROC genie_tanh_mp; extern GPROC genie_tanh_mp_complex; extern GPROC genie_tan_mp; extern GPROC genie_tan_mp_complex; extern GPROC genie_tanpi_mp; extern GPROC genie_timesab_mp; extern GPROC genie_timesab_mp_complex; extern GPROC genie_xor_mp; #if defined (HAVE_GNU_MPFR) extern GPROC genie_beta_inc_mpfr; extern GPROC genie_ln_beta_mpfr; extern GPROC genie_beta_mpfr; extern GPROC genie_gamma_inc_mpfr; extern GPROC genie_gamma_inc_real_mpfr; extern GPROC genie_gamma_inc_real_16_mpfr; extern GPROC genie_gamma_mpfr; extern GPROC genie_lngamma_mpfr; extern GPROC genie_mpfr_erfc_mp; extern GPROC genie_mpfr_erf_mp; extern GPROC genie_mpfr_inverfc_mp; extern GPROC genie_mpfr_inverf_mp; extern GPROC genie_mpfr_mp; extern size_t mpfr_digits (void); #endif #if (A68_LEVEL <= 2) extern int get_mp_bits_width (MOID_T *); extern int get_mp_bits_words (MOID_T *); extern MP_BITS_T *stack_mp_bits (NODE_T *, MP_T *, MOID_T *); #endif #endif algol68g-3.1.2/src/include/a68g-stddef.h0000644000175000017500000000672014361065320014465 00000000000000//! @file a68g-stddef.h //! @author J. Marcel van der Veer // //! @section Copyright // // This file is part of Algol68G - an Algol 68 compiler-interpreter. // Copyright 2001-2023 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 (__A68G_STDDEF_H__) #define __A68G_STDDEF_H__ #define DOUBLE_ACCURACY (REAL_DIG - 1) // Multi-precision parameters #define LONG_LONG_EXP_WIDTH (EXP_WIDTH) #define LONG_LONG_INT_WIDTH (1 + LONG_LONG_WIDTH) #define LONG_LONG_REAL_WIDTH ((long_mp_digits() - 1) * LOG_MP_RADIX) #define LONG_LONG_WIDTH (long_mp_digits() * LOG_MP_RADIX) // Other WIDTHs #define BYTES_WIDTH 32 #define LONG_BYTES_WIDTH 256 #define MAX_REAL_EXPO 511 #define LOG_DBL_EPSILON (-3.6043653389117154e+01) #define LOG_DBL_MIN (-7.0839641853226408e+02) #define LOG_DBL_MAX (7.0978271289338397e+02) #define REAL_DIG DBL_DIG #define REAL_EPSILON DBL_EPSILON #define REAL_MANT_DIG DBL_MANT_DIG #define REAL_MAX DBL_MAX #define REAL_MAX_10_EXP DBL_MAX_10_EXP #define REAL_MIN DBL_MIN #define REAL_MIN_10_EXP DBL_MIN_10_EXP #if (A68_LEVEL >= 3) #define REAL_WIDTH (REAL_DIG) #define MAX_REAL_16_EXPO 4932 #define A68_MAX_INT (LLONG_MAX) #define A68_MAX_BITS (ULLONG_MAX) #define LONG_WIDTH (2 * INT_WIDTH + 1) #define LONG_REAL_WIDTH (FLT128_DIG - 1) #define EXP_WIDTH (3) #define LONG_EXP_WIDTH (4) #define LONG_BITS_WIDTH (2 * BITS_WIDTH) #define D_SIGN 0x8000000000000000LL #define NaN_MP ((MP_T *) NULL) #define MP_RADIX 1000000000 #define LOG_MP_RADIX 9 #define MP_RADIX_Q MP_RADIX##q #define DEFAULT_DOUBLE_DIGITS 4 #define LONG_MP_DIGITS DEFAULT_DOUBLE_DIGITS #define LONG_LONG_MP_DIGITS width_to_mp_digits (4 * REAL_DIG + REAL_DIG / 2) #define MAX_MP_EXPONENT 111111 // Arbitrary. Largest range is A68_MAX_INT / Log A68_MAX_INT / LOG_MP_RADIX #define MAX_REPR_INT 9223372036854775808.0 // 2^63, max int in an extended double (no implicit bit, so 62-bit mantissa) #define MAX_DOUBLE_EXPO 4932 #else // if (A68_LEVEL <= 2) #define REAL_WIDTH (REAL_DIG) #define A68_MAX_INT (INT_MAX) #define A68_MAX_BITS (UINT_MAX) #define LONG_WIDTH (LONG_MP_DIGITS * LOG_MP_RADIX) #define LONG_REAL_WIDTH ((LONG_MP_DIGITS - 1) * LOG_MP_RADIX) #define EXP_WIDTH ((int) (1 + log10 ((REAL_T) REAL_MAX_10_EXP))) #define LONG_EXP_WIDTH (EXP_WIDTH) #define D_SIGN 0x80000000L #define MP_BITS_BITS 23 #define MP_BITS_RADIX 8388608 // Max power of two smaller than MP_RADIX #define NaN_MP ((MP_T *) NULL) #define MP_RADIX 10000000 #define MP_RADIX_Q MP_RADIX##q #define LOG_MP_RADIX 7 #define DEFAULT_DOUBLE_DIGITS 6 #define LONG_MP_DIGITS DEFAULT_DOUBLE_DIGITS #define LONG_LONG_MP_DIGITS width_to_mp_digits (4 * REAL_DIG + REAL_DIG / 2) #define MAX_MP_EXPONENT 142857 // Arbitrary. Largest range is A68_MAX_INT / Log A68_MAX_INT / LOG_MP_RADIX #define MAX_REPR_INT 9007199254740992.0 // 2^53, max int in a double #endif #endif algol68g-3.1.2/src/include/a68g-numbers.h0000644000175000017500000000702514361065320014666 00000000000000//! @file a68g-numbers.h //! @author J. Marcel van der Veer // //! @section Copyright // // This file is part of Algol68G - an Algol 68 compiler-interpreter. // Copyright 2001-2023 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 (__A68G_NUMBERS_H__) #define __A68G_NUMBERS_H__ #define CONST_LOG2_10 3.32192809488736234787031942948939017586483139302458061205475640 #define CONST_PI_OVER_180 0.01745329251994329576923690768488612713442871888541725456097191 #define CONST_180_OVER_PI 57.2957795130823208767981548141051703324054724665643215491602439 #define CONST_PI_OVER_180_Q 0.01745329251994329576923690768488612713442871888541725456097191q #define CONST_180_OVER_PI_Q 57.2957795130823208767981548141051703324054724665643215491602439q // Abramowitz, Milton and Stegun, Irene A. // Handbook of Mathematical Functions. // New York: Dover publications, Inc. (1970). // All constants taken from this text are given to 25 significant digits. #define CONST_E 2.718281828459045235360287471353 /* e */ #define CONST_EULER 0.577215664901532860606512090082 // Euler-Mascheroni #define CONST_LOG2E 1.442695040888963407359924681002 /* log2(e) */ #define CONST_LOG10E 0.434294481903251827651128918917 /* log10(e) */ #define CONST_LN2 0.693147180559945309417232121458 /* ln(2) */ #define CONST_LN10 2.302585092994045684017991454684 /* ln(10) */ #define CONST_PI 3.141592653589793238462643383280 /* pi */ #define CONST_PI_Q 3.141592653589793238462643383280q /* pi */ #define CONST_2PI 6.283185307179586476925286766559 /* 2*pi */ #define CONST_PI_2 1.570796326794896619231321691640 /* pi/2 */ #define CONST_PI_4 0.785398163397448309615660845820 /* pi/4 */ #define CONST_1_PI 0.318309886183790671537767526745 /* 1/pi */ #define CONST_2_PI 0.636619772367581343075535053490 /* 2/pi */ #define CONST_2_SQRTPI 1.128379167095512573896158903122 /* 2/sqrt(pi) */ #define CONST_SQRT2 1.414213562373095048801688724210 /* sqrt(2) */ #define CONST_SQRT1_2 0.707106781186547524400844362105 /* 1/sqrt(2) */ // R-Specific Constants #define CONST_SQRT_3 1.732050807568877293527446341506 /* sqrt(3) */ #define CONST_SQRT_32 5.656854249492380195206754896838 /* sqrt(32) */ #define CONST_LOG10_2 0.301029995663981195213738894724 /* log10(2) */ #define CONST_SQRT_PI 1.772453850905516027298167483341 /* sqrt(pi) */ #define CONST_1_SQRT_2PI 0.398942280401432677939946059934 /* 1/sqrt(2pi) */ #define CONST_SQRT_2dPI 0.797884560802865355879892119869 /* sqrt(2/pi) */ #define CONST_LN_2PI 1.837877066409345483560659472811 /* log(2*pi) */ #define CONST_LN_SQRT_PI 0.572364942924700087071713675677 /* log(sqrt(pi)) == log(pi)/2 */ #define CONST_LN_SQRT_2PI 0.918938533204672741780329736406 /* log(sqrt(2*pi)) == log(2*pi)/2 */ #define CONST_LN_SQRT_PId2 0.225791352644727432363097614947 /* log(sqrt(pi/2)) */ #endif algol68g-3.1.2/src/include/a68g-stack.h0000644000175000017500000000374414361065320014324 00000000000000//! @file a68g-stack.h //! @author J. Marcel van der Veer // //! @section Copyright // // This file is part of Algol68G - an Algol 68 compiler-interpreter. // Copyright 2001-2023 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 (__A68G_STACK_H__) #define __A68G_STACK_H__ // 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) (A68 (system_stack_offset) - &stack_offset))) #define LOW_SYSTEM_STACK_ALERT(p) {\ BYTE_T stack_offset;\ if (A68 (stack_size) > 0 && SYSTEM_STACK_USED >= A68 (stack_limit)) {\ if ((p) == NO_NODE) {\ ABEND (A68_TRUE, TOO_COMPLEX, ERROR_STACK_OVERFLOW);\ } else {\ diagnostic (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 && (A68_FP >= A68 (frame_stack_limit) || A68_SP >= A68 (expr_stack_limit))) { \ diagnostic (A68_RUNTIME_ERROR, (p), ERROR_STACK_OVERFLOW);\ exit_genie ((p), A68_RUNTIME_ERROR);\ }} #endif algol68g-3.1.2/src/include/a68g-level-3.h0000644000175000017500000000367114361065320014465 00000000000000//! @file a68g-level-3.h //! @author J. Marcel van der Veer // //! @section Copyright // // This file is part of Algol68G - an Algol 68 compiler-interpreter. // Copyright 2001-2023 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 (__A68G_LEVEL_3_H__) #define __A68G_LEVEL_3_H__ typedef long long int INT_T; typedef long long unt UNSIGNED_T; typedef UNSIGNED_T ADDR_T; typedef __float128 DOUBLE_T; typedef struct A68_DOUBLE A68_DOUBLE, A68_LONG_INT, A68_LONG_REAL, A68_LONG_BITS; typedef DOUBLE_T A68_ALIGN_T; typedef union QUAD_WORD_T QUAD_WORD_T; union QUAD_WORD_T { UNSIGNED_T u[2]; DOUBLE_T f; }; struct A68_DOUBLE { STATUS_MASK_T status; QUAD_WORD_T value; } ALIGNED; typedef A68_LONG_REAL A68_LONG_COMPLEX[2]; #define DOUBLE_COMPLEX_T __complex128 #define a68_strtoi strtoll #define a68_strtou strtoull #define A68_LD "%lld" #define A68_LU "%llu" #define A68_LX "%llx" #define A68_FRAME_ALIGN(s) (A68_ALIGN(s)) #define SIGNQ(n) ((n) == 0.0q ? 0 : ((n) > 0 ? 1 : -1)) extern void standardise_double (DOUBLE_T *, int, int, int *); extern DOUBLE_T ten_up_double (int); extern BOOL_T convert_radix_double (NODE_T *, QUAD_WORD_T, int, int); typedef __float80 MP_REAL_T; typedef INT_T MP_INT_T; typedef UNSIGNED_T MP_BITS_T; typedef INT_T MP_T; #define FLOOR_MP floorl #endif algol68g-3.1.2/src/include/a68g-frames.h0000644000175000017500000001574414361065320014477 00000000000000//! @file a68g-frames.h //! @author J. Marcel van der Veer // //! @section Copyright // // This file is part of Algol68G - an Algol 68 compiler-interpreter. // Copyright 2001-2023 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 (__A68G_FRAMES_H__) #define __A68G_FRAMES_H__ // Operations on stack frames #define FRAME_ADDRESS(n) ((BYTE_T *) &(A68_STACK[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_FRAME_ALIGN (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 (A68_FP + (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 (BUILD_PARALLEL_CLAUSE) #define FRAME_THREAD_ID(n) (THREAD_ID (FACT (n))) #endif #define FOLLOW_SL(dest, l) {\ (dest) = A68_FP;\ 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) == A68 (global_level) && A68_GLOBALS > 0) {\ (dest) = A68_GLOBALS;\ } 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 *) & (A68_STACK [_m_z + FRAME_INFO_SIZE + (offset)]);\ } #define GET_GLOBAL(dest, cast, offset) {\ (dest) = (cast *) & (A68_STACK [A68_GLOBALS + 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 (A68_FP);\ if (_m_cur_lex_lvl == (new_lex_lvl)) {\ (dest) = FRAME_STATIC_LINK (A68_FP);\ } else if (_m_cur_lex_lvl > (new_lex_lvl)) {\ ADDR_T _m_static_link = A68_FP;\ 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) = A68_FP;\ }} #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) == A68 (global_level)) {\ A68_GLOBALS = A68_FP;\ }} #if defined (BUILD_PARALLEL_CLAUSE) #define OPEN_STATIC_FRAME(p) {\ ADDR_T dynamic_link = A68_FP, static_link;\ ACTIVATION_RECORD *act, *pre;\ STATIC_LINK_FOR_FRAME (static_link, LEX_LEVEL (p));\ pre = FACT (A68_FP);\ A68_FP += FRAME_SIZE (dynamic_link);\ act = FACT (A68_FP);\ 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) = A68_FP;\ 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 = A68_FP, static_link;\ ACTIVATION_RECORD *act, *pre;\ STATIC_LINK_FOR_FRAME (static_link, LEX_LEVEL (p));\ pre = FACT (A68_FP);\ A68_FP += FRAME_SIZE (dynamic_link);\ act = FACT (A68_FP);\ 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) = A68_FP;\ 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 (BUILD_PARALLEL_CLAUSE) #define OPEN_PROC_FRAME(p, environ) {\ ADDR_T dynamic_link = A68_FP, static_link;\ ACTIVATION_RECORD *act;\ LOW_STACK_ALERT (p);\ static_link = (environ > 0 ? environ : A68_FP);\ if (A68_FP < static_link) {\ diagnostic (A68_RUNTIME_ERROR, (p), ERROR_SCOPE_DYNAMIC_0);\ exit_genie (p, A68_RUNTIME_ERROR);\ }\ A68_FP += FRAME_SIZE (dynamic_link);\ act = FACT (A68_FP);\ FRAME_NO (act) = FRAME_NUMBER (dynamic_link) + 1;\ FRAME_LEVEL (act) = LEX_LEVEL (p);\ PARAMETER_LEVEL (act) = LEX_LEVEL (p);\ PARAMETERS (act) = A68_FP;\ STATIC_LINK (act) = static_link;\ DYNAMIC_LINK (act) = dynamic_link;\ DYNAMIC_SCOPE (act) = A68_FP;\ 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 = A68_FP, static_link;\ ACTIVATION_RECORD *act;\ LOW_STACK_ALERT (p);\ static_link = (environ > 0 ? environ : A68_FP);\ if (A68_FP < static_link) {\ diagnostic (A68_RUNTIME_ERROR, (p), ERROR_SCOPE_DYNAMIC_0);\ exit_genie (p, A68_RUNTIME_ERROR);\ }\ A68_FP += FRAME_SIZE (dynamic_link);\ act = FACT (A68_FP);\ FRAME_NO (act) = FRAME_NUMBER (dynamic_link) + 1;\ FRAME_LEVEL (act) = LEX_LEVEL (p);\ PARAMETER_LEVEL (act) = LEX_LEVEL (p);\ PARAMETERS (act) = A68_FP;\ STATIC_LINK (act) = static_link;\ DYNAMIC_LINK (act) = dynamic_link;\ DYNAMIC_SCOPE (act) = A68_FP;\ NODE (act) = p;\ JUMP_STAT (act) = NO_JMP_BUF;\ PROC_FRAME (act) = A68_TRUE;\ } #endif #define CLOSE_FRAME {\ ACTIVATION_RECORD *act = FACT (A68_FP);\ A68_FP = DYNAMIC_LINK (act);\ } #endif algol68g-3.1.2/src/include/a68g.h0000644000175000017500000001161014361065320013210 00000000000000//! @file a68g.h //! @author J. Marcel van der Veer // //! @section Copyright // // This file is part of Algol68G - an Algol 68 compiler-interpreter. // Copyright 2001-2023 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 (__A68G_H__) #define __A68G_H__ // Debugging switch, only useful during development. #undef A68_DEBUG // Early typedef #define unt unsigned // Configuration #include "a68g-platform.h" #include "a68g-includes.h" // Build switches depending on platform. #if ((defined (BUILD_LINUX) || defined (BUILD_BSD)) && defined (HAVE_GCC) && defined (HAVE_DL)) # define BUILD_A68_COMPILER #else // Untested, so disabled. # undef BUILD_A68_COMPILER #endif #if defined (BUILD_LINUX) # define BUILD_UNIX #elif defined (BUILD_BSD) # define BUILD_UNIX #elif defined (BUILD_CYGWIN) # define BUILD_UNIX #elif defined (BUILD_HAIKU) # define BUILD_UNIX #endif // REAL_T should be a REAL*8 for external libs. typedef double REAL_T; #if (A68_LEVEL >= 3) # include #endif // Can we access the internet? #if defined (BUILD_WIN32) # undef BUILD_HTTP #else # if (defined (HAVE_NETDB_H) && defined (HAVE_NETINET_IN_H) && defined (HAVE_SYS_SOCKET_H)) # if (defined (BUILD_LINUX) || defined (BUILD_BSD) || defined (BUILD_HAIKU)) # define BUILD_HTTP # endif # endif #endif // Compatibility. #if ! defined (O_BINARY) # define O_BINARY 0x0000 #endif // Forward type definitions. typedef struct NODE_T NODE_T; typedef unt STATUS_MASK_T, BOOL_T; // Decide the internal representation of A68 modes. #include "a68g-stddef.h" #define ALIGNED __attribute__((aligned (sizeof (A68_ALIGN_T)))) #if (A68_LEVEL >= 3) # include "a68g-level-3.h" #else // Vintage Algol 68 Genie (versions 1 and 2). # include "a68g-generic.h" #endif #define MP_REAL_RADIX ((MP_REAL_T) MP_RADIX) #if defined (BUILD_WIN32) typedef unt __off_t; # if defined (__MSVCRT__) && defined (_environ) # undef _environ # endif #endif #define A68_ALIGN(s) ((int) ((s) % A68_ALIGNMENT) == 0 ? (s) : ((s) - (s) % A68_ALIGNMENT + A68_ALIGNMENT)) #define A68_ALIGNMENT ((int) (sizeof (A68_ALIGN_T))) #include "a68g-defines.h" #include "a68g-stack.h" #include "a68g-masks.h" #include "a68g-enums.h" #include "a68g-types.h" #include "a68g-nil.h" #include "a68g-diagnostics.h" #include "a68g-common.h" #include "a68g-lib.h" // Global declarations extern BOOL_T a68_mkstemp (char *, int, mode_t); 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 char *a68_basename (char *); extern char *a68_dirname (char *); extern char *a68_relpath (char *, char *, char *); extern char *ctrl_char (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 *read_string_from_tty (char *); extern char *standard_environ_proc_name (GPROC); extern int get_row_size (A68_TUPLE *, int); extern int moid_digits (MOID_T *); extern int moid_size (MOID_T *); extern int (snprintf) (char *, size_t, const char *, ...); // Prevent macro substitution on Darwin. extern void *a68_alloc (size_t, const char *, int); extern void a68_exit (int); extern void a68_free (void *); extern void a68_getty (int *, int *); extern void *a68_memmove (void *, void *, size_t); extern void abend (char *, char *, char *, int); extern void announce_phase (char *); extern void apropos (FILE_T, char *, char *); extern void bufcat (char *, char *, int); extern void bufcpy (char *, char *, int); extern void default_mem_sizes (int); extern void discard_heap (void); extern void free_file_entries (void); extern void free_syntax_tree (NODE_T *); extern void get_stack_size (void); extern void indenter (MODULE_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_rng (unt); extern void init_tty (void); extern void install_signal_handlers (void); extern void online_help (FILE_T); extern void state_version (FILE_T); // Below from R mathlib extern void GetRNGstate(void); extern void PutRNGstate(void); extern REAL_T a68_unif_rand(void); extern REAL_T R_unif_index(REAL_T); #endif algol68g-3.1.2/src/include/a68g-common.h0000644000175000017500000002114214361065320014477 00000000000000//! @file a68g-common.h //! @author J. Marcel van der Veer // //! @section Copyright // // This file is part of Algol68G - an Algol 68 compiler-interpreter. // Copyright 2001-2023 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 (__A68G_COMMON_H__) #define __A68G_COMMON_H__ typedef struct MODULE_T MODULE_T; struct MODULE_T { BOOL_T tree_listing_safe, cross_reference_safe; FILES_T files; NODE_T *top_node; MOID_T *top_moid, *standenv_moid; OPTIONS_T options; PROP_T global_prop; REFINEMENT_T *top_refinement; LINE_T *top_line; int error_count, warning_count, source_scan; jmp_buf rendez_vous; struct { LINE_T *save_l; char *save_s, save_c; } scan_state; }; typedef struct MODE_CACHE_T MODE_CACHE_T; #define MODE(p) A68 (a68_modes.p) struct MODE_CACHE_T { MOID_T *proc_bool; MOID_T *proc_char; MOID_T *proc_complex_complex; MOID_T *proc_int; MOID_T *proc_int_int; MOID_T *proc_int_int_real; MOID_T *proc_int_real; MOID_T *proc_int_real_real; MOID_T *proc_int_real_real_real; MOID_T *proc_real; MOID_T *proc_real_int_real; MOID_T *proc_real_real; MOID_T *proc_real_real_int_real; MOID_T *proc_real_real_real; MOID_T *proc_real_real_real_int; MOID_T *proc_real_real_real_real; MOID_T *proc_real_real_real_real_real; MOID_T *proc_real_real_real_real_real_real; MOID_T *proc_real_ref_real_ref_int_void; MOID_T *proc_void; }; #define MAX_OPEN_FILES 64 // Some OS's won't open more than this number #define MAX_TRANSPUT_BUFFER (MAX_OPEN_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; }; // Administration for common (sub) expression elimination. // BOOK keeps track of already seen (temporary) variables and denotations. enum { BOOK_NONE = 0, BOOK_DECL, BOOK_INIT, BOOK_DEREF, BOOK_ARRAY, BOOK_COMPILE }; typedef struct BOOK_T BOOK_T; struct BOOK_T { int action, phase; char *idf; void *info; int number; }; typedef struct UNIC_T UNIC_T; struct UNIC_T { char *fun; }; // #define A68(z) (common.z) #define A68_JOB A68 (job) #define A68_STANDENV A68 (standenv) #define A68_MCACHE(z) A68 (mode_cache.z) #define A68_SP A68 (stack_pointer) #define A68_FP A68 (frame_pointer) #define A68_HP A68 (heap_pointer) #define A68_GLOBALS A68 (global_pointer) #define A68_STACK A68 (stack_segment) #define A68_HEAP A68 (heap_segment) #define A68_HANDLES A68 (handle_segment) typedef struct GC_GLOBALS_T GC_GLOBALS_T; #define A68_GC(z) A68 (gc.z) struct GC_GLOBALS_T { A68_HANDLE *available_handles, *busy_handles; UNSIGNED_T free_handles, max_handles, sweeps, refused, freed, total; unt preemptive; REAL_T seconds; }; typedef struct INDENT_GLOBALS_T INDENT_GLOBALS_T; #define A68_INDENT(z) A68 (indent.z) struct INDENT_GLOBALS_T { FILE_T fd; int ind, col; int indentation; BOOL_T use_folder; }; #define MON_STACK_SIZE 32 typedef struct MONITOR_GLOBALS_T MONITOR_GLOBALS_T; #define A68_MON(z) A68 (mon.z) struct MONITOR_GLOBALS_T { ADDR_T finish_frame_pointer; char *watchpoint_expression; BOOL_T in_monitor; int break_proc_level; char symbol[BUFFER_SIZE], error_text[BUFFER_SIZE], expr[BUFFER_SIZE]; char prompt[BUFFER_SIZE]; BOOL_T prompt_set; int current_frame; int max_row_elems; int mon_errors; int _m_sp; int pos, attr; int tabs; MOID_T *_m_stack[MON_STACK_SIZE]; }; typedef struct MP_GLOBALS_T MP_GLOBALS_T; #define A68_MP(z) A68 (mp.z) struct MP_GLOBALS_T { int mp_gamma_size; int mp_ln_10_size; int mp_ln_scale_size; int mp_one_size; int mp_pi_size; int varying_mp_digits; MP_T *mp_180_over_pi; MP_T **mp_gam_ck; MP_T *mp_half_pi; MP_T *mp_ln_10; MP_T *mp_ln_pi; MP_T *mp_ln_scale; MP_T *mp_one; MP_T *mp_pi; MP_T *mp_pi_over_180; MP_T *mp_sqrt_pi; MP_T *mp_sqrt_two_pi; MP_T *mp_two_pi; }; #define MAX_BOOK 1024 #define MAX_UNIC 2048 typedef struct OPTIMISER_GLOBALS_T OPTIMISER_GLOBALS_T; #define A68_OPT(z) A68 (optimiser.z) struct OPTIMISER_GLOBALS_T { int OPTION_CODE_LEVEL; int indentation; int code_errors; int procedures; BOOK_T cse_book[MAX_BOOK]; int cse_pointer; DEC_T *root_idf; BOOL_T put_idf_comma; UNIC_T unic_functions[MAX_UNIC]; int unic_pointer; }; #if defined (BUILD_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. // Note that _POSIX_THREAD_THREADS_MAX may be ULONG_MAX. #define THREAD_LIMIT 256 #if (_POSIX_THREAD_THREADS_MAX < THREAD_LIMIT) #undef THREAD_LIMIT #define THREAD_LIMIT _POSIX_THREAD_THREADS_MAX #endif #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 typedef struct PARALLEL_GLOBALS_T PARALLEL_GLOBALS_T; #define A68_PAR(z) A68 (parallel.z) struct PARALLEL_GLOBALS_T { ADDR_T fp0, sp0; BOOL_T abend_all_threads, exit_from_threads; A68_THREAD_CONTEXT context[THREAD_MAX]; int par_return_code; int context_index; NODE_T *jump_label; jmp_buf *jump_buffer; pthread_mutex_t unit_sema; pthread_t main_thread_id; pthread_t parent_thread_id; }; #endif typedef struct PARSER_GLOBALS_T PARSER_GLOBALS_T; #define A68_PARSER(z) A68 (parser.z) struct PARSER_GLOBALS_T { TAG_T *error_tag; BOOL_T stop_scanner, read_error, no_preprocessing; char *scan_buf; int max_scan_buf_length, source_file_size; int reductions; int tag_number; jmp_buf bottom_up_crash_exit, top_down_crash_exit; }; typedef struct GLOBALS_T GLOBALS_T; struct GLOBALS_T { MODULE_T job; A68_CHANNEL stand_in_channel, stand_out_channel, stand_back_channel; A68_CHANNEL stand_draw_channel, stand_error_channel, associate_channel, skip_channel; A68_REF stand_in, stand_out, stand_back, stand_error, skip_file; BYTE_T *stack_segment, *heap_segment, *handle_segment; ADDR_T frame_pointer, stack_pointer, heap_pointer, global_pointer; ADDR_T fixed_heap_pointer, temp_heap_pointer; ADDR_T frame_start, frame_end, stack_start, stack_end; unt frame_stack_size, expr_stack_size, heap_size, handle_pool_size, stack_size; unt stack_limit, frame_stack_limit, expr_stack_limit; unt storage_overhead; int global_level, max_lex_lvl; int new_nodes, new_modes, new_postulates, new_node_infos, new_genie_infos; int symbol_table_count, mode_count; int term_heigth, term_width; int argc; BOOL_T in_execution; BOOL_T close_tty_on_exit; BYTE_T *system_stack_offset; MODES_T a68_modes; NODE_T **node_register; char a68_cmd_name[BUFFER_SIZE]; char **argv; char output_line[BUFFER_SIZE], edit_line[BUFFER_SIZE], input_line[BUFFER_SIZE]; char *marker[BUFFER_SIZE]; REAL_T cputime_0; clock_t clock_res; BOOL_T halt_typing; BOOL_T heap_is_fluid; BOOL_T in_monitor; BOOL_T do_confirm_exit; BOOL_T no_warnings; int chars_in_tty_line; POSTULATE_T *postulates, *top_postulate, *top_postulate_list; KEYWORD_T *top_keyword; TOKEN_T *top_token; NODE_T *f_entry; TAG_T *error_tag; int ret_code, ret_line_number, ret_char_number; jmp_buf genie_exit_label; A68_PROCEDURE on_gc_event; TABLE_T *standenv; char *f_library; BOOL_T curses_mode; SOID_T *top_soid_list; int max_simplout_size; OPTIONS_T *options; FILE_ENTRY file_entries[MAX_OPEN_FILES]; // Private structs MODE_CACHE_T mode_cache; MONITOR_GLOBALS_T mon; GC_GLOBALS_T gc; PARSER_GLOBALS_T parser; OPTIMISER_GLOBALS_T optimiser; MP_GLOBALS_T mp; INDENT_GLOBALS_T indent; #if defined (BUILD_PARALLEL_CLAUSE) PARALLEL_GLOBALS_T parallel; #endif }; extern GLOBALS_T common; #endif algol68g-3.1.2/src/include/a68g-generic.h0000644000175000017500000000270714361065320014631 00000000000000//! @file a68g-legacy.h //! @author J. Marcel van der Veer // //! @section Copyright // // This file is part of Algol68G - an Algol 68 compiler-interpreter. // Copyright 2001-2023 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 (__A68G_LEGACY_H__) #define __A68G_LEGACY_H__ typedef int INT_T; typedef unt UNSIGNED_T; typedef UNSIGNED_T ADDR_T; typedef REAL_T A68_LONG_COMPLEX[2]; typedef REAL_T DOUBLE_T; typedef int *A68_ALIGN_T; #define A68_LD "%d" #define A68_LU "%u" #define A68_LX "%x" #define a68_strtoi strtol #define a68_strtou strtoul #define A68_FRAME_ALIGN(s) ((int) ((s) % 8) == 0 ? (s) : ((s) - (s) % 8 + 8)) typedef REAL_T MP_REAL_T; typedef int MP_INT_T; typedef unt MP_BITS_T; typedef MP_REAL_T MP_T; #define FLOOR_MP floor extern void stand_longlong_bits (void); #endif algol68g-3.1.2/src/include/a68g-prelude.h0000644000175000017500000007552714361065320014667 00000000000000//! @file a68g-prelude.h //! @author J. Marcel van der Veer // //! @section Copyright // // This file is part of Algol68G - an Algol 68 compiler-interpreter. // Copyright 2001-2023 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 (__A68G_PRELUDE_H__) #define __A68G_PRELUDE_H__ #define A68_STD A68_TRUE #define A68_EXT A68_FALSE extern MOID_T *a68_proc (MOID_T *, ...); extern void a68_idf (BOOL_T, char *, MOID_T *, GPROC *); extern void a68_prio (char *, int); extern void a68_op (BOOL_T, char *, MOID_T *, GPROC *); extern void a68_mode (int, char *, MOID_T **); // ALGOL68C type procs. #define A68C_DEFIO(name, pname, mode) {\ m = a68_proc (MODE (mode), M_REF_FILE, NO_MOID);\ a68_idf (A68_EXT, "get" #name, m, genie_get_##pname);\ m = a68_proc (M_VOID, M_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 (M_VOID, MODE (mode), NO_MOID);\ a68_idf (A68_EXT, "print" #name, m, genie_print_##pname);\ } #define IS_NL_FF(ch) ((ch) == NEWLINE_CHAR || (ch) == FORMFEED_CHAR) #define MANT_DIGS(n) ((int) round ((n) * log10 (2.0))) #define MANT_BITS(n) ((int) round ((n) / log10 (2.0))) #define REAL_DIGITS MANT_DIGS (REAL_MANT_DIG) #define DOUBLE_DIGITS MANT_DIGS (FLT128_MANT_DIG) #define A68_MONAD(n, MODE, OP)\ void n (NODE_T * p) {\ MODE *i;\ POP_OPERAND_ADDRESS (p, i, MODE);\ VALUE (i) = OP (VALUE (i));\ } #if (A68_LEVEL >= 3) extern GPROC genie_lt_bits; extern GPROC genie_gt_bits; extern DOUBLE_T mp_to_real_16 (NODE_T *, MP_T *, int); extern MP_T *real_16_to_mp (NODE_T *, MP_T *, DOUBLE_T, int); #endif // Standard prelude RTS extern void skip_nl_ff (NODE_T *, int *, A68_REF); extern void value_sign_error (NODE_T *, MOID_T *, A68_REF); extern GPROC initialise_frame; extern GPROC get_global_level; extern GPROC genie_a68_argc; extern GPROC genie_a68_argv; 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_real; extern GPROC genie_acos_complex; extern GPROC genie_acosdg_real; extern GPROC genie_acosh_complex; extern GPROC genie_acosh_real; extern GPROC genie_acos_real; extern GPROC genie_acotdg_real; extern GPROC genie_acot_real; extern GPROC genie_acsc_real; extern GPROC genie_add_bits; 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_int; extern GPROC genie_add_real; extern GPROC genie_add_string; extern GPROC genie_and_bits; extern GPROC genie_and_bool; extern GPROC genie_argc; extern GPROC genie_arg_complex; extern GPROC genie_argv; extern GPROC genie_asec_real; extern GPROC genie_asin_complex; extern GPROC genie_asindg_real; extern GPROC genie_asinh_complex; extern GPROC genie_asinh_real; extern GPROC genie_asin_real; extern GPROC genie_associate; extern GPROC genie_atan2dg_real; extern GPROC genie_atan2_real; extern GPROC genie_atan_complex; extern GPROC genie_atandg_real; extern GPROC genie_atanh_complex; extern GPROC genie_atanh_real; extern GPROC genie_atan_real; extern GPROC genie_backspace; extern GPROC genie_backtrace; extern GPROC genie_beta_inc_cf_real; extern GPROC genie_beta_real; extern GPROC genie_bin_int; extern GPROC genie_bin_possible; extern GPROC genie_bits; 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_bytespack; extern GPROC genie_bytes_shorths; extern GPROC genie_bytes_width; extern GPROC genie_cd; extern GPROC genie_char_in_string; extern GPROC genie_choose_real; extern GPROC genie_clear_bits; extern GPROC genie_clear_long_bits; extern GPROC genie_close; extern GPROC genie_columns; extern GPROC genie_complex_lengths; extern GPROC genie_complex_shorths; extern GPROC genie_compressible; extern GPROC genie_conj_complex; extern GPROC genie_cos_complex; extern GPROC genie_cosdg_real; extern GPROC genie_cosh_complex; extern GPROC genie_cosh_real; extern GPROC genie_cospi_real; extern GPROC genie_cos_real; extern GPROC genie_cotdg_real; extern GPROC genie_cotpi_real; extern GPROC genie_cot_real; extern GPROC genie_cputime; extern GPROC genie_create; extern GPROC genie_create_pipe; extern GPROC genie_csc_real; extern GPROC genie_curt_real; extern GPROC genie_debug; extern GPROC genie_declaration; extern GPROC genie_directory; extern GPROC genie_divab_complex; extern GPROC genie_divab_real; extern GPROC genie_div_complex; extern GPROC genie_div_int; extern GPROC genie_div_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_string; extern GPROC genie_enquiry_clause; 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_real; extern GPROC genie_eq_string; extern GPROC genie_erase; extern GPROC genie_erfc_real; extern GPROC genie_erf_real; extern GPROC genie_errno; extern GPROC genie_error_char; extern GPROC genie_establish; extern GPROC genie_evaluate; extern GPROC genie_exec; extern GPROC genie_exec_sub; extern GPROC genie_exec_sub_pipeline; extern GPROC genie_exec_sub_output; extern GPROC genie_exp_char; extern GPROC genie_exp_complex; extern GPROC genie_exp_real; extern GPROC genie_exp_width; extern GPROC genie_fact_real; 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_flip_char; extern GPROC genie_flop_char; extern GPROC genie_fork; extern GPROC genie_formfeed_char; extern GPROC genie_gamma_inc_f_real; extern GPROC genie_gamma_inc_gf_real; extern GPROC genie_gamma_inc_g_real; extern GPROC genie_gamma_inc_h_real; extern GPROC genie_gamma_real; extern GPROC genie_garbage_collections; extern GPROC genie_garbage_freed; extern GPROC genie_garbage_refused; 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_generator_bounds; extern GPROC genie_ge_real; extern GPROC genie_ge_string; extern GPROC genie_get_bits; extern GPROC genie_get_bool; extern GPROC genie_get_char; extern GPROC genie_get_complex; extern GPROC genie_getenv; extern GPROC genie_get_int; extern GPROC genie_get_long_bits; extern GPROC genie_get_long_int; extern GPROC genie_get_long_real; extern GPROC genie_get_possible; extern GPROC genie_get_real; extern GPROC genie_get_sound; extern GPROC genie_get_string; 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_real; extern GPROC genie_gt_string; extern GPROC genie_i_complex; extern GPROC genie_identity_dec; extern GPROC genie_idf; extern GPROC genie_idle; extern GPROC genie_i_int_complex; extern GPROC genie_im_complex; extern GPROC genie_infinity_real; extern GPROC genie_init_heap; extern GPROC genie_init_transput; extern GPROC genie_int_lengths; extern GPROC genie_int_shorths; extern GPROC genie_int_width; extern GPROC genie_inverfc_real; extern GPROC genie_inverf_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_leng_bytes; extern GPROC genie_lengthen_long_bits_to_row_bool; extern GPROC genie_le_real; extern GPROC genie_le_string; extern GPROC genie_lj_e_12_6; extern GPROC genie_lj_f_12_6; extern GPROC genie_ln1p_real; extern GPROC genie_ln_beta_real; extern GPROC genie_ln_choose_real; extern GPROC genie_ln_complex; extern GPROC genie_ln_fact_real; extern GPROC genie_ln_gamma_real; extern GPROC genie_ln_real; extern GPROC genie_localtime; extern GPROC genie_lock; extern GPROC genie_log_real; extern GPROC genie_long_bits_pack; extern GPROC genie_long_bits_width; extern GPROC genie_long_bytespack; extern GPROC genie_long_bytes_width; 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_lt_bytes; extern GPROC genie_lt_char; extern GPROC genie_lt_int; extern GPROC genie_lt_long_bytes; 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_minusab_complex; extern GPROC genie_minusab_int; extern GPROC genie_minusab_long_int; extern GPROC genie_minusab_real; extern GPROC genie_minus_complex; extern GPROC genie_minus_infinity_real; extern GPROC genie_minus_int; extern GPROC genie_minus_real; extern GPROC genie_modab_int; extern GPROC genie_mod_bits; extern GPROC genie_mod_int; extern GPROC genie_monad_elems; extern GPROC genie_monad_lwb; extern GPROC genie_monad_upb; extern GPROC genie_mp_radix; extern GPROC genie_mul_complex; extern GPROC genie_mul_int; extern GPROC genie_mul_long_int; 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_real; extern GPROC genie_ne_string; extern GPROC genie_new_line; extern GPROC genie_newline_char; extern GPROC genie_new_page; extern GPROC genie_new_sound; extern GPROC genie_next_random; extern GPROC genie_next_rnd; extern GPROC genie_not_bits; extern GPROC genie_not_bool; extern GPROC genie_null_char; extern GPROC genie_odd_int; 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_operator_dec; extern GPROC genie_or_bits; extern GPROC genie_or_bool; extern GPROC genie_overab_int; extern GPROC genie_over_bits; extern GPROC genie_over_int; extern GPROC genie_pi; 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_int; 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_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_int; extern GPROC genie_print_long_real; extern GPROC genie_print_real; extern GPROC genie_print_string; extern GPROC genie_print_string; extern GPROC genie_proc_variable_dec; extern GPROC genie_program_idf; 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_long_bits; extern GPROC genie_put_long_int; extern GPROC genie_put_long_real; extern GPROC genie_put_possible; extern GPROC genie_put_real; extern GPROC genie_put_string; extern GPROC genie_pwd; 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_line; extern GPROC genie_read_long_bits; extern GPROC genie_read_long_int; extern GPROC genie_read_long_real; extern GPROC genie_read_real; extern GPROC genie_read_string; extern GPROC genie_realpath; extern GPROC genie_real_lengths; extern GPROC genie_real_shorths; extern GPROC genie_real_width; extern GPROC genie_re_complex; extern GPROC genie_reidf_possible; extern GPROC genie_repr_char; extern GPROC genie_reset; extern GPROC genie_reset_errno; extern GPROC genie_reset_possible; extern GPROC genie_rol_bits; extern GPROC genie_ror_bits; extern GPROC genie_round_real; extern GPROC genie_rows; extern GPROC genie_sec_real; extern GPROC genie_set; extern GPROC genie_set_bits; extern GPROC genie_set_long_bits; extern GPROC genie_set_possible; extern GPROC genie_set_return_code; extern GPROC genie_set_sound; extern GPROC genie_shl_bits; extern GPROC genie_shorten_bytes; extern GPROC genie_shr_bits; extern GPROC genie_sign_int; extern GPROC genie_sign_real; extern GPROC genie_sin_complex; extern GPROC genie_sindg_real; extern GPROC genie_sinh_complex; extern GPROC genie_sinh_real; extern GPROC genie_sinpi_real; extern GPROC genie_sin_real; extern GPROC genie_sleep; 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_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_strerror; extern GPROC genie_string_in_string; extern GPROC genie_sub_bits; extern GPROC genie_sub_complex; extern GPROC genie_sub_int; extern GPROC genie_sub_long_int; extern GPROC genie_sub_real; extern GPROC genie_system; extern GPROC genie_system_heap_pointer; 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_tandg_real; extern GPROC genie_tanh_complex; extern GPROC genie_tanh_real; extern GPROC genie_tanpi_real; extern GPROC genie_tan_real; extern GPROC genie_term; extern GPROC genie_timesab_complex; extern GPROC genie_timesab_int; extern GPROC genie_timesab_long_int; extern GPROC genie_timesab_real; extern GPROC genie_timesab_string; extern GPROC genie_times_bits; 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_to_lower; extern GPROC genie_to_upper; extern GPROC genie_unimplemented; extern GPROC genie_utctime; extern GPROC genie_waitpid; 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; #if defined (S_ISFIFO) extern GPROC genie_file_is_fifo; #endif #if defined (S_ISLNK) extern GPROC genie_file_is_link; #endif #if defined (BUILD_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 (BUILD_HTTP) extern GPROC genie_http_content; extern GPROC genie_tcp_request; #endif extern GPROC genie_grep_in_string; extern GPROC genie_grep_in_substring; extern GPROC genie_sub_in_string; // 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_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 extern void genie_call_event_routine (NODE_T *, MOID_T *, A68_PROCEDURE *, ADDR_T, ADDR_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_check_initialisation (NODE_T *, BYTE_T *, MOID_T *); extern void genie_f_and_becomes (NODE_T *, MOID_T *, GPROC *); extern void genie_find_proc_op (NODE_T *, int *); extern void genie_generator_internal (NODE_T *, MOID_T *, TAG_T *, LEAP_T, ADDR_T); extern void genie_init_rng (void); extern void genie_preprocess (NODE_T *, int *, void *); 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_serial_clause (NODE_T *, jmp_buf *); extern void genie_serial_units (NODE_T *, NODE_T **, jmp_buf *, ADDR_T); extern void genie_string_to_value (NODE_T *, MOID_T *, BYTE_T *, A68_REF); extern void genie_subscript (NODE_T *, A68_TUPLE **, INT_T *, 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 (void *); extern void genie_write_standard (NODE_T *, MOID_T *, BYTE_T *, A68_REF); #if defined (BUILD_PARALLEL_CLAUSE) extern PROP_T genie_parallel (NODE_T *); 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); #define SAME_THREAD(p, q) (pthread_equal((p), (q)) != 0) #define OTHER_THREAD(p, q) (pthread_equal((p), (q)) == 0) #endif extern PROP_T genie_generator (NODE_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_make_row (NODE_T *, MOID_T *, int, ADDR_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 close_device (NODE_T *, A68_FILE *); extern BOOL_T genie_int_case_unit (NODE_T *, int, int *); extern BOOL_T increment_internal_index (A68_TUPLE *, int); extern char *a_to_c_string (NODE_T *, char *, A68_REF); extern char *propagator_name (PROP_PROC * p); extern FILE *a68_fopen (char *, char *, char *); extern int a68_finite (REAL_T); extern int a68_isinf (REAL_T); extern int a68_isnan (REAL_T); extern int a68_string_size (NODE_T *, A68_REF); extern int char_value (int); extern int grep_in_string (char *, char *, int *, int *); extern INT_T a68_round (REAL_T); extern REAL_T seconds (void); extern REAL_T ten_up (int); extern void deltagammainc (REAL_T *, REAL_T *, REAL_T, REAL_T, REAL_T, REAL_T); extern ssize_t io_read_conv (FILE_T, void *, size_t); extern ssize_t io_read (FILE_T, void *, size_t); extern ssize_t io_write_conv (FILE_T, const void *, size_t); extern ssize_t io_write (FILE_T, const void *, size_t); extern unt heap_available (void); extern void a68_div_complex (A68_REAL *, A68_REAL *, A68_REAL *); extern void a68_exit (int); extern void a68_exp_complex (A68_REAL *, A68_REAL *); extern void change_breakpoints (NODE_T *, unt, int, BOOL_T *, char *); extern void change_masks (NODE_T *, unt, BOOL_T); extern void colour_object (BYTE_T *, MOID_T *); extern void exit_genie (NODE_T *, int); extern void gc_heap (NODE_T *, ADDR_T); extern void genie_free (NODE_T *); extern void genie_generator_stowed (NODE_T *, BYTE_T *, NODE_T **, ADDR_T *); extern void initialise_internal_index (A68_TUPLE *, int); extern void io_close_tty_line (void); extern void io_write_string (FILE_T, const char *); extern void monitor_error (char *, char *); extern void mp_strtou (NODE_T *, MP_T *, char *, MOID_T *); extern void print_internal_index (FILE_T, A68_TUPLE *, int); extern void print_item (NODE_T *, FILE_T, BYTE_T *, MOID_T *); extern void single_step (NODE_T *, unt); extern void stack_dump (FILE_T, ADDR_T, int, int *); extern void where_in_source (FILE_T, NODE_T *); extern A68_REF tmp_to_a68_string (NODE_T *, char *); #if defined (BUILD_LINUX) extern GPROC genie_sigsegv; #endif #endif algol68g-3.1.2/src/include/a68g-defines.h0000644000175000017500000006031614361065320014632 00000000000000//! @file a68g-defines.h //! @author J. Marcel van der Veer // //! @section Copyright // // This file is part of Algol68G - an Algol 68 compiler-interpreter. // Copyright 2001-2023 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 (__A68G_DEFINES_H__) #define __A68G_DEFINES_H__ // Constants #define KILOBYTE ((unt) 1024) #define MEGABYTE (KILOBYTE * KILOBYTE) #define GIGABYTE (KILOBYTE * MEGABYTE) #define A68_TRUE ((BOOL_T) 1) #define A68_FALSE ((BOOL_T) 0) #define BACKSLASH_CHAR '\\' #define BLANK_CHAR ' ' #define CR_CHAR '\r' #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 NEWLINE_CHAR '\n' #define NULL_CHAR '\0' #define POINT_CHAR '.' #define QUOTE_CHAR '"' #define RADIX_CHAR 'r' #define TAB_CHAR '\t' // File extensions #define BINARY_EXTENSION ".o" #define LIBRARY_EXTENSION ".so" #define LISTING_EXTENSION ".l" #define OBJECT_EXTENSION ".c" #define PRETTY_EXTENSION ".f" #define SCRIPT_EXTENSION "" // Static options for GCC. // // -fno-stack-protector is needed for Ubuntu etcetera that enforce -fstack-protector-strong // which may give an undefined reference to `__stack_chk_fail_local'. // // -Wno-parentheses-equality is needed for OpenBSD. // #define A68_GCC_OPTIONS "-DA68_OPTIMISE -ggdb -fno-stack-protector -Wno-parentheses-equality" // Formats #define DIGIT_BLANK ((unt) 0x2) #define DIGIT_NORMAL ((unt) 0x1) #define INSERTION_BLANK ((unt) 0x20) #define INSERTION_NORMAL ((unt) 0x10) #define MAX_RESTART 256 #define A68_DIR ".a68g" #define A68_HISTORY_FILE ".a68g.edit.hist" #define A68_NO_FILENO ((FILE_T) -1) #define A68_PROTECTION (S_IRUSR | S_IWUSR | S_IRGRP | S_IROTH) // -rw-r--r-- #define A68_READ_ACCESS (O_RDONLY) #define A68_WRITE_ACCESS (O_WRONLY | O_CREAT | O_TRUNC) #define BUFFER_SIZE (KILOBYTE) #define DEFAULT_WIDTH (-1) #define EMBEDDED_FORMAT A68_TRUE #define EVEN(k) ((k) % 2 == 0) #define HIDDEN_TEMP_FILE_NAME ".a68g.tmp" #define ITEM_NOT_USED (-1) #define MAX_ERRORS 5 #define MAX_PRIORITY 9 #define MAX_TERM_HEIGTH 24 #define MAX_TERM_WIDTH (BUFFER_SIZE / 2) #define MIN_MEM_SIZE (128 * KILOBYTE) #define MOID_ERROR_WIDTH 80 #define MOID_WIDTH 80 #define MONADS "%^&+-~!?" #define NEWLINE_STRING "\n" #define NOMADS "> (REAL_T) (2 * GIGABYTE)) #define PRIMAL_SCOPE 0 #define SKIP_PATTERN A68_FALSE #define SMALL_BUFFER_SIZE 128 #define SNPRINTF_SIZE ((size_t) (BUFFER_SIZE - 1)) #define TRANSPUT_BUFFER_SIZE BUFFER_SIZE #define WANT_PATTERN A68_TRUE // Macros #define _SKIP_ { (void) 0;} #define MAX(u, v) (((u) > (v) ? (u) : (v))) #define MAXIMISE(u, v) ((u) = MAX (u, v)) #define MIN(u, v) (((u) < (v) ? (u) : (v))) #define MINIMISE(u, v) ((u) = MIN (u, v)) #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 (A68 (curses_mode) == A68_TRUE) {\ (void) attrset (A_NORMAL);\ (void) endwin ();\ A68 (curses_mode) = A68_FALSE;\ }\ ABEND (A68_TRUE, ERROR_ASSERTION, __func__)\ }} #else #define ASSERT(f) {\ ABEND((!(f)), ERROR_ASSERTION, __func__)\ } #endif // Some macros to overcome the ambiguity in having signed or unt char // on various systems. PDP-11s and IBM 370s are still haunting us with this. #define IS_ALNUM(c) isalnum ((unt char) (c)) #define IS_ALPHA(c) isalpha ((unt char) (c)) #define IS_CNTRL(c) iscntrl ((unt char) (c)) #define IS_DIGIT(c) isdigit ((unt char) (c)) #define IS_GRAPH(c) isgraph ((unt char) (c)) #define IS_LOWER(c) islower ((unt char) (c)) #define IS_PRINT(c) isprint ((unt char) (c)) #define IS_PUNCT(c) ispunct ((unt char) (c)) #define IS_SPACE(c) isspace ((unt char) (c)) #define IS_UPPER(c) isupper ((unt char) (c)) #define IS_XDIGIT(c) isxdigit ((unt char) (c)) #define TO_LOWER(c) (char) tolower ((unt char) (c)) #define TO_UCHAR(c) ((c) >= 0 ? (int) (c) : (int) (UCHAR_MAX + (int) (c) + 1)) #define TO_UPPER(c) (char) toupper ((unt char) (c)) // Macro's for fat A68 pointers #define ADDRESS(z) (&(((IS_IN_HEAP (z) || IS_IN_COMMON (z)) ? REF_POINTER (z) : A68_STACK)[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 *) & (A68_HEAP[n])) #define IS_IN_FRAME(z) (STATUS (z) & IN_FRAME_MASK) #define IS_IN_HEAP(z) (STATUS (z) & IN_HEAP_MASK) #define IS_IN_COMMON(z) (STATUS (z) & IN_COMMON_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) (& A68_STACK[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 *) &(A68_STACK[(n)])) #define STACK_OFFSET(n) (STACK_ADDRESS (A68_SP + (int) (n))) #define STACK_TOP (STACK_ADDRESS (A68_SP)) // Miscellaneous macros #define IN_PRELUDE(p) (LINE_NUMBER (p) <= 0) #define EOL(c) ((c) == NEWLINE_CHAR || (c) == NULL_CHAR) #define SIZE_ALIGNED(p) ((int) A68_ALIGN (sizeof (p))) #define A68_REF_SIZE (SIZE_ALIGNED (A68_REF)) #define A68_UNION_SIZE (SIZE_ALIGNED (A68_UNION)) #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 ((REAL_T) A68_MAX_INT) / log ((REAL_T) 2)))) #define DEFLEX(p) (DEFLEXED (p) != NO_MOID ? DEFLEXED(p) : (p)) #define FORWARD(p) ((p) = NEXT (p)) #define INT_WIDTH ((int) (1 + floor (log ((REAL_T) A68_MAX_INT) / log ((REAL_T) 10)))) #define LONG_INT_WIDTH (1 + LONG_WIDTH) #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)) != (unt) 0) #define WIS(p) where_in_source (STDOUT_FILENO, (p)) #define WRITE(f, s) io_write_string ((f), (s)); #define WRITELN(f, s) {WRITE ((f), "\n"); WRITE ((f), (s));} // Access macros #define A(p) ((p)->a) #define A68_STANDENV_PROC(p) ((p)->a68_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)->fp_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 ln(x) (log (x)) #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 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_COMPILE_CHECK(p) (OPTIONS (p).compile_check) #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_LICENSE(p) (OPTIONS (p).license) #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_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_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 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 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 SCAN_WARNING(c, u, v, txt) if (c) {scan_warning (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_ALIGNED (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 IF_ROW(m) (IS_FLEX (m) || IS_ROW (m) || m == M_STRING) #define IS_COERCION(p) ((p)->is_coercion) #define IS_FLEX(m) IS ((m), FLEX_SYMBOL) #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(p, s) (ATTRIBUTE (p) == (s)) #define IS_REF_FLEX(m) (IS (m, REF_SYMBOL) && IS (SUB (m), FLEX_SYMBOL)) #define IS_REF(m) IS ((m), REF_SYMBOL) #define IS_ROW(m) IS ((m), ROW_SYMBOL) #define IS_STRUCT(m) IS ((m), STRUCT_SYMBOL) #define IS_UNION(m) IS ((m), UNION_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) #endif algol68g-3.1.2/src/include/a68g-prelude-gsl.h0000644000175000017500000002547514361065320015447 00000000000000//! @file a68g-prelude-gsl.h //! @author J. Marcel van der Veer // //! @section Copyright // // This file is part of Algol68G - an Algol 68 compiler-interpreter. // Copyright 2001-2023 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 (__A68G_PRELUDE_GSL_H__) #define __A68G_PRELUDE_GSL_H__ #if defined (HAVE_GSL) extern void stand_gsl (void); extern GPROC genie_airy_ai_deriv_real; extern GPROC genie_airy_ai_deriv_scaled_real; extern GPROC genie_airy_ai_real; extern GPROC genie_airy_ai_scaled_real; extern GPROC genie_airy_bi_deriv_real; extern GPROC genie_airy_bi_deriv_scaled_real; extern GPROC genie_airy_bi_real; extern GPROC genie_airy_bi_scaled_real; extern GPROC genie_airy_zero_ai_deriv_real; extern GPROC genie_airy_zero_ai_real; extern GPROC genie_airy_zero_bi_deriv_real; extern GPROC genie_airy_zero_bi_real; extern GPROC genie_angle_restrict_pos_real; extern GPROC genie_angle_restrict_symm_real; extern GPROC genie_atanint_real; extern GPROC genie_bessel_il0_scaled_real; extern GPROC genie_bessel_il1_scaled_real; extern GPROC genie_bessel_il2_scaled_real; extern GPROC genie_bessel_il_scaled_real; extern GPROC genie_bessel_in0_real; extern GPROC genie_bessel_in0_scaled_real; extern GPROC genie_bessel_in1_real; extern GPROC genie_bessel_in1_scaled_real; extern GPROC genie_bessel_in_real; extern GPROC genie_bessel_in_scaled_real; extern GPROC genie_bessel_inu_real; extern GPROC genie_bessel_inu_scaled_real; extern GPROC genie_bessel_jl0_real; extern GPROC genie_bessel_jl1_real; extern GPROC genie_bessel_jl2_real; extern GPROC genie_bessel_jl_real; extern GPROC genie_bessel_jn0_real; extern GPROC genie_bessel_jn1_real; extern GPROC genie_bessel_jn_real; extern GPROC genie_bessel_jnu_real; extern GPROC genie_bessel_kl0_scaled_real; extern GPROC genie_bessel_kl1_scaled_real; extern GPROC genie_bessel_kl2_scaled_real; extern GPROC genie_bessel_kl_scaled_real; extern GPROC genie_bessel_kn0_real; extern GPROC genie_bessel_kn0_scaled_real; extern GPROC genie_bessel_kn1_real; extern GPROC genie_bessel_kn1_scaled_real; extern GPROC genie_bessel_kn_real; extern GPROC genie_bessel_kn_scaled_real; extern GPROC genie_bessel_knu_real; extern GPROC genie_bessel_knu_scaled_real; extern GPROC genie_bessel_knu_scaled_real; extern GPROC genie_bessel_ln_knu_real; extern GPROC genie_bessel_yl0_real; extern GPROC genie_bessel_yl1_real; extern GPROC genie_bessel_yl2_real; extern GPROC genie_bessel_yl_real; extern GPROC genie_bessel_yn0_real; extern GPROC genie_bessel_yn1_real; extern GPROC genie_bessel_yn_real; extern GPROC genie_bessel_ynu_real; extern GPROC genie_bessel_zero_jnu0_real; extern GPROC genie_bessel_zero_jnu1_real; extern GPROC genie_bessel_zero_jnu_real; extern GPROC genie_beta_inc_gsl_real; extern GPROC genie_beta_inc_real; extern GPROC genie_chi_real; extern GPROC genie_ci_real; extern GPROC genie_clausen_real; extern GPROC genie_conicalp_0_real; extern GPROC genie_conicalp_1_real; extern GPROC genie_conicalp_cyl_reg_real; extern GPROC genie_conicalp_half_real; extern GPROC genie_conicalp_mhalf_real; extern GPROC genie_conicalp_sph_reg_real; extern GPROC genie_dawson_real; extern GPROC genie_debye_1_real; extern GPROC genie_debye_2_real; extern GPROC genie_debye_3_real; extern GPROC genie_debye_4_real; extern GPROC genie_debye_5_real; extern GPROC genie_debye_6_real; extern GPROC genie_dilog_real; extern GPROC genie_doublefact_real; extern GPROC genie_ellint_d_real; extern GPROC genie_ellint_d_real; extern GPROC genie_ellint_e_comp_real; extern GPROC genie_ellint_e_real; extern GPROC genie_ellint_f_real; extern GPROC genie_ellint_k_comp_real; extern GPROC genie_ellint_p_comp_real; extern GPROC genie_ellint_p_real; extern GPROC genie_ellint_rc_real; extern GPROC genie_ellint_rd_real; extern GPROC genie_ellint_rf_real; extern GPROC genie_ellint_rj_real; extern GPROC genie_etaint_real; extern GPROC genie_eta_real; extern GPROC genie_expint_3_real; extern GPROC genie_expint_e1_real; extern GPROC genie_expint_e2_real; extern GPROC genie_expint_ei_real; extern GPROC genie_expint_en_real; extern GPROC genie_expm1_real; extern GPROC genie_exprel_2_real; extern GPROC genie_exprel_n_real; extern GPROC genie_exprel_real; extern GPROC genie_fact_real; extern GPROC genie_fermi_dirac_0_real; extern GPROC genie_fermi_dirac_1_real; extern GPROC genie_fermi_dirac_2_real; extern GPROC genie_fermi_dirac_3half_real; extern GPROC genie_fermi_dirac_half_real; extern GPROC genie_fermi_dirac_inc_0_real; extern GPROC genie_fermi_dirac_int_real; extern GPROC genie_fermi_dirac_m1_real; extern GPROC genie_fermi_dirac_mhalf_real; extern GPROC genie_gamma_inc_real; extern GPROC genie_gamma_inc_p_real; extern GPROC genie_gamma_inc_q_real; extern GPROC genie_gammainv_real; extern GPROC genie_gammastar_real; extern GPROC genie_gegenpoly_1_real; extern GPROC genie_gegenpoly_2_real; extern GPROC genie_gegenpoly_3_real; extern GPROC genie_gegenpoly_n_real; extern GPROC genie_hermite_func_real; extern GPROC genie_hypot_real; extern GPROC genie_hzeta_real; extern GPROC genie_laguerre_1_real; extern GPROC genie_laguerre_2_real; extern GPROC genie_laguerre_3_real; extern GPROC genie_laguerre_n_real; extern GPROC genie_lambert_w0_real; extern GPROC genie_lambert_wm1_real; extern GPROC genie_legendre_h3d_0_real; extern GPROC genie_legendre_h3d_1_real; extern GPROC genie_legendre_H3d_real; extern GPROC genie_legendre_p1_real; extern GPROC genie_legendre_p2_real; extern GPROC genie_legendre_p3_real; extern GPROC genie_legendre_pl_real; extern GPROC genie_legendre_q0_real; extern GPROC genie_legendre_q1_real; extern GPROC genie_legendre_ql_real; extern GPROC genie_lncosh_real; extern GPROC genie_lndoublefact_real; extern GPROC genie_lnfact_real; extern GPROC genie_lnpoch_real; extern GPROC genie_lnsinh_real; extern GPROC genie_log_1plusx_mx_real; extern GPROC genie_log_1plusx_real; extern GPROC genie_log_abs_real; extern GPROC genie_poch_real; extern GPROC genie_pochrel_real; extern GPROC genie_psi_1_int_real; extern GPROC genie_psi_1piy_real; extern GPROC genie_psi_1_real; extern GPROC genie_psi_int_real; extern GPROC genie_psi_n_real; extern GPROC genie_psi_real; extern GPROC genie_shi_real; extern GPROC genie_sinc_real; extern GPROC genie_si_real; extern GPROC genie_synchrotron_1_real; extern GPROC genie_synchrotron_2_real; extern GPROC genie_taylorcoeff_real; extern GPROC genie_transport_2_real; extern GPROC genie_transport_3_real; extern GPROC genie_transport_4_real; extern GPROC genie_transport_5_real; extern GPROC genie_zeta_int_real; extern GPROC genie_zetam1_int_real; extern GPROC genie_zetam1_real; extern GPROC genie_zeta_real; extern GPROC genie_complex_scale_matrix_complex; extern GPROC genie_complex_scale_vector_complex; 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_laplace; 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; extern GPROC genie_beta_inc_real; extern GPROC genie_gamma_inc_real; extern GPROC genie_poch_real; extern GPROC genie_digamma_real; #endif #endif algol68g-3.1.2/src/include/a68g-physics.h0000644000175000017500000003267314361065320014704 00000000000000//! @file a68g-physics.h //! @author J. Marcel van der Veer // //! @section Copyright // // This file is part of Algol68G - an Algol 68 compiler-interpreter. // Copyright 2001-2023 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 (__A68G_PHYSICS_H__) #define __A68G_PHYSICS_H__ // 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 */ #endif algol68g-3.1.2/src/include/a68g-optimiser.h0000644000175000017500000001102114361065320015215 00000000000000//! @file a68g-optimiser.h //! @author J. Marcel van der Veer // //! @section Copyright // // This file is part of Algol68G - an Algol 68 compiler-interpreter. // Copyright 2001-2023 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 (__A68G_OPTIMISER_H__) #define __A68G_OPTIMISER_H__ extern BOOL_T constant_unit (NODE_T *); extern BOOL_T folder_mode (MOID_T *); extern void build_script (void); extern void compiler (FILE_T); extern void load_script (void); extern void push_unit (NODE_T *); extern void rewrite_script_source (void); // Library for code generator extern INT_T a68_add_int (INT_T, INT_T); extern INT_T a68_sub_int (INT_T, INT_T); extern INT_T a68_mul_int (INT_T, INT_T); extern INT_T a68_over_int (INT_T, INT_T); extern INT_T a68_mod_int (INT_T, INT_T); extern REAL_T a68_div_int (INT_T, INT_T); extern void a68_ln_complex (A68_REAL *, A68_REAL *); extern void a68_sqrt_complex (A68_REAL *, A68_REAL *); extern void a68_sin_complex (A68_REAL *, A68_REAL *); extern void a68_cos_complex (A68_REAL *, A68_REAL *); extern void a68_tan_complex (A68_REAL *, A68_REAL *); extern void a68_asin_complex (A68_REAL *, A68_REAL *); extern void a68_acos_complex (A68_REAL *, A68_REAL *); extern void a68_atan_complex (A68_REAL *, A68_REAL *); extern void a68_sinh_complex (A68_REAL *, A68_REAL *); extern void a68_cosh_complex (A68_REAL *, A68_REAL *); extern void a68_tanh_complex (A68_REAL *, A68_REAL *); extern void a68_asinh_complex (A68_REAL *, A68_REAL *); extern void a68_acosh_complex (A68_REAL *, A68_REAL *); extern void a68_atanh_complex (A68_REAL *, A68_REAL *); // Operators that are inlined in compiled code #define a68_eq_complex(/* A68_REAL * */ x, y) (RE (x) == RE (y) && IM (x) == IM (y)) #define a68_ne_complex(/* A68_REAL * */ x, y) (! a68_eq_complex (x, y)) #define a68_plusab_int(/* A68_REF * */ i, /* int */ j) (VALUE ((A68_INT *) ADDRESS (i)) += (j), (i)) #define a68_minusab_int(/* A68_REF * */ i, /* int */ j) (VALUE ((A68_INT *) ADDRESS (i)) -= (j), (i)) #define a68_timesab_int(/* A68_REF * */ i, /* int */ j) (VALUE ((A68_INT *) ADDRESS (i)) *= (j), (i)) #define a68_overab_int(/* A68_REF * */ i, /* int */ j) (VALUE ((A68_INT *) ADDRESS (i)) /= (j), (i)) #define a68_entier(/* REAL_T */ x) ((int) floor (x)) #define a68_plusab_real(/* A68_REF * */ i, /* REAL_T */ j) (VALUE ((A68_REAL *) ADDRESS (i)) += (j), (i)) #define a68_minusab_real(/* A68_REF * */ i, /* REAL_T */ j) (VALUE ((A68_REAL *) ADDRESS (i)) -= (j), (i)) #define a68_timesab_real(/* A68_REF * */ i, /* REAL_T */ j) (VALUE ((A68_REAL *) ADDRESS (i)) *= (j), (i)) #define a68_divab_real(/* A68_REF * */ i, /* REAL_T */ j) (VALUE ((A68_REAL *) ADDRESS (i)) /= (j), (i)) #define a68_re_complex(/* A68_REAL * */ z) (RE (z)) #define a68_im_complex(/* A68_REAL * */ z) (IM (z)) #define a68_abs_complex(/* A68_REAL * */ z) a68_hypot (RE (z), IM (z)) #define a68_arg_complex(/* A68_REAL * */ z) atan2 (IM (z), RE (z)) #define a68_i_complex(/* A68_REAL * */ z, /* REAL_T */ re, im) {\ STATUS_RE (z) = INIT_MASK;\ STATUS_IM (z) = INIT_MASK;\ RE (z) = re;\ IM (z) = im;} #define a68_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 a68_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 a68_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 a68_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 a68_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);} #endif algol68g-3.1.2/src/include/a68g-config.win32.h0000644000175000017500000000420614361065554015430 00000000000000#if defined (BUILD_WIN32) #define HAVE_ISINF 1 #define HAVE_ISNAN 1 #define HAVE_ISFINITE 1 #define HAVE_GSL #define HAVE_GNU_PLOTUTILS #define HAVE_QUADMATH #define HAVE_MATHLIB #undef HAVE_GNU_MPFR #undef HAVE_CURSES #define HAVE_REGEX_H #if defined (HAVE_GSL) #define HAVE_GSL_GSL_BLAS_H 1 #define HAVE_GSL_GSL_COMPLEX_H 1 #define HAVE_GSL_GSL_COMPLEX_MATH_H 1 #define HAVE_GSL_GSL_ERRNO_H 1 #define HAVE_GSL_GSL_FFT_COMPLEX_H 1 #define HAVE_GSL_GSL_INTEGRATION_H 1 #define HAVE_GSL_GSL_LINALG_H 1 #define HAVE_GSL_GSL_MATH_H 1 #define HAVE_GSL_GSL_MATRIX_H 1 #define HAVE_GSL_GSL_PERMUTATION_H 1 #define HAVE_GSL_GSL_SF_H 1 #define HAVE_GSL_GSL_VECTOR_H 1 #define HAVE_GSL_GSL_VERSION_H 1 #endif #if defined (HAVE_GNU_PLOTUTILS) #define HAVE_PLOT_H #else #undef HAVE_PLOT_H #endif #if defined (BUILD_HTTP) #define HAVE_STDINT_H #else #undef HAVE_STDINT_H #endif #if defined (HAVE_CURSES) #define HAVE_CURSES_H #define HAVE_LIBNCURSES #else #undef HAVE_CURSES_H #undef HAVE_LIBNCURSES #endif #undef HAVE_DLFCN_H #undef HAVE_LIBPQ_FE_H #undef HAVE_PTHREAD_H #undef HAVE_TERM_H #define HAVE_STDINT_H #define HAVE_STDARG_H #define HAVE_STDLIB_H #define HAVE_ERRNO_H #define HAVE_ASSERT_H #define HAVE_CONIO_H #define HAVE_CTYPE_H #define HAVE_DIRENT_H #define HAVE_FCNTL_H #define HAVE_FLOAT_H #define HAVE_LIMITS_H #define HAVE_MATH_H #define HAVE_COMPLEX_H #define HAVE_SETJMP_H #define HAVE_SIGNAL_H #define HAVE_STDIO_H #define HAVE_STRING_H #define HAVE_SYS_STAT_H #define HAVE_SYS_TYPES_H #define HAVE_TIME_H #define HAVE_UNISTD_H #define HAVE_WINSOCK_H #endif // BUILD_WIN32 // Name of package #define PACKAGE "algol68g" // Define to the full name of this package. #define PACKAGE_NAME "algol68g" // Define to the one symbol short name of this package. #define PACKAGE_TARNAME "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 and version of this package. #define PACKAGE_STRING "algol68g 3.1.2" // Define to the version of this package. #define PACKAGE_VERSION "3.1.2" // Version number of package #define VERSION "3.1.2" algol68g-3.1.2/src/include/a68g-lib.h0000644000175000017500000000764114361065320013765 00000000000000//! @file a68g-lib.h //! @author J. Marcel van der Veer // //! @section Copyright // // This file is part of Algol68G - an Algol 68 compiler-interpreter. // Copyright 2001-2023 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 __A68G_LIB_H__ #define __A68G_LIB_H__ #define MATH_EPSILON DBL_EPSILON #define A68_INVALID(c)\ if (c) {\ errno = EDOM;\ return 0;\ } #define A68_OVERFLOW(c)\ if (c) {\ errno = ERANGE;\ return 0;\ } #define A68_MAX_FAC 170 extern INT_T a68_add_int (INT_T, INT_T); extern INT_T a68_mod_int (INT_T, INT_T); extern INT_T a68_mul_int (INT_T, INT_T); extern INT_T a68_m_up_n (INT_T, INT_T); extern INT_T a68_over_int (INT_T, INT_T); extern INT_T a68_round (REAL_T); extern INT_T a68_sub_int (INT_T, INT_T); extern REAL_T a68_abs (REAL_T); extern REAL_T a68_acosdg (REAL_T); extern REAL_T a68_acosh (REAL_T); extern REAL_T a68_acotdg (REAL_T); extern REAL_T a68_acot (REAL_T); extern REAL_T a68_acsc (REAL_T); extern REAL_T a68_asec (REAL_T); extern REAL_T a68_asindg (REAL_T); extern REAL_T a68_asinh (REAL_T); extern REAL_T a68_atan2 (REAL_T, REAL_T); extern REAL_T a68_atandg (REAL_T); extern REAL_T a68_atanh (REAL_T); extern REAL_T a68_beta (REAL_T, REAL_T); extern REAL_T a68_choose (INT_T, INT_T); extern REAL_T a68_cosdg (REAL_T); extern REAL_T a68_cospi (REAL_T); extern REAL_T a68_cotdg (REAL_T); extern REAL_T a68_cotpi (REAL_T); extern REAL_T a68_cot (REAL_T); extern REAL_T a68_csc (REAL_T); extern REAL_T a68_sec (REAL_T); extern REAL_T a68_div_int (INT_T, INT_T); extern REAL_T a68_exp (REAL_T); extern REAL_T a68_fact (INT_T); extern REAL_T a68_fdiv (REAL_T, REAL_T); extern REAL_T a68_hypot (REAL_T, REAL_T); extern REAL_T a68_int (REAL_T); extern REAL_T a68_inverfc (REAL_T); extern REAL_T a68_inverf (REAL_T); extern REAL_T a68_ln1p (REAL_T); extern REAL_T a68_ln1p (REAL_T); extern REAL_T a68_ln_beta (REAL_T, REAL_T); extern REAL_T a68_ln_choose (INT_T, INT_T); extern REAL_T a68_ln_fact (INT_T); extern REAL_T a68_ln (REAL_T); extern REAL_T a68_max (REAL_T, REAL_T); extern REAL_T a68_min (REAL_T, REAL_T); extern REAL_T a68_nan (void); extern REAL_T a68_neginf (void); extern REAL_T a68_posinf (void); extern REAL_T a68_psi (REAL_T); extern REAL_T a68_sign (REAL_T); extern REAL_T a68_sindg (REAL_T); extern REAL_T a68_sinpi (REAL_T); extern REAL_T a68_tandg (REAL_T); extern REAL_T a68_tanpi (REAL_T); extern REAL_T a68_x_up_n (REAL_T, INT_T); extern REAL_T a68_x_up_y (REAL_T, REAL_T); extern REAL_T a68_beta_inc (REAL_T, REAL_T, REAL_T); extern DOUBLE_T a68_beta_inc_16 (DOUBLE_T, DOUBLE_T, DOUBLE_T); extern DOUBLE_T a68_cot_16 (DOUBLE_T); extern DOUBLE_T a68_csc_16 (DOUBLE_T); extern DOUBLE_T a68_sec_16 (DOUBLE_T); extern DOUBLE_T a68_acot_16 (DOUBLE_T); extern DOUBLE_T a68_acsc_16 (DOUBLE_T); extern DOUBLE_T a68_asec_16 (DOUBLE_T); extern DOUBLE_T a68_sindg_16 (DOUBLE_T); extern DOUBLE_T a68_cosdg_16 (DOUBLE_T); extern DOUBLE_T a68_tandg_16 (DOUBLE_T); extern DOUBLE_T a68_asindg_16 (DOUBLE_T); extern DOUBLE_T a68_acosdg_16 (DOUBLE_T); extern DOUBLE_T a68_atandg_16 (DOUBLE_T); extern DOUBLE_T a68_cotdg_16 (DOUBLE_T); extern DOUBLE_T a68_acotdg_16 (DOUBLE_T); extern DOUBLE_T a68_sinpi_16 (DOUBLE_T); extern DOUBLE_T a68_cospi_16 (DOUBLE_T); extern DOUBLE_T a68_tanpi_16 (DOUBLE_T); extern DOUBLE_T a68_cotpi_16 (DOUBLE_T); #endif algol68g-3.1.2/src/include/a68g-listing.h0000644000175000017500000000250214361065320014657 00000000000000//! @file a68g-listing.h //! @author J. Marcel van der Veer // //! @section Copyright // // This file is part of Algol68G - an Algol 68 compiler-interpreter. // Copyright 2001-2023 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 (__A68G_LISTING_H__) #define __A68G_LISTING_H__ extern void list_source_line (FILE_T, LINE_T *, BOOL_T); extern void print_mode_flat (FILE_T, MOID_T *); extern void tree_listing (FILE_T, NODE_T *, int, LINE_T *, int *, BOOL_T); extern void write_listing_header (void); extern void write_listing (void); extern void write_object_listing (void); extern void write_source_listing (void); extern void write_tree_listing (void); #endif algol68g-3.1.2/src/include/a68g-double.h0000644000175000017500000002756114361065320014474 00000000000000//! @file a68g-double.h //! @author J. Marcel van der Veer // //! @section Copyright // // This file is part of Algol68G - an Algol 68 compiler-interpreter. // Copyright 2001-2023 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 (__A68G_DOUBLE_H__) #define __A68G_DOUBLE_H__ #if (A68_LEVEL >= 3) #define MODCHK(p, m, c) (!(MODULAR_MATH (p) && (m == M_LONG_BITS)) && (c)) #if defined (HAVE_IEEE_754) #define CHECK_DOUBLE_REAL(p, u) PRELUDE_ERROR (!finiteq (u), p, ERROR_INFINITE, M_LONG_REAL) #define CHECK_DOUBLE_COMPLEX(p, u, v)\ PRELUDE_ERROR (isinfq (u), p, ERROR_INFINITE, M_LONG_REAL);\ PRELUDE_ERROR (isinfq (v), p, ERROR_INFINITE, M_LONG_REAL); #else #define CHECK_DOUBLE_REAL(p, u) {;} #define CHECK_DOUBLE_COMPLEX(p, u, v) {;} #endif #define LONG_INT_BASE (9223372036854775808.0q) #define HW(z) ((z).u[1]) #define LW(z) ((z).u[0]) #define D_NEG(d) ((HW(d) & D_SIGN) != 0) #define D_LT(u, v) (HW (u) < HW (v) ? A68_TRUE : (HW (u) == HW (v) ? LW (u) < LW (v) : A68_FALSE)) #define DBLEQ(z) ((dble_16 (A68 (f_entry), (z))).f) #define ABSQ(n) ((n) >= 0.0q ? (n) : -(n)) #define POP_LONG_COMPLEX(p, re, im) {\ POP_OBJECT (p, im, A68_LONG_REAL);\ POP_OBJECT (p, re, A68_LONG_REAL);\ } #define set_lw(z, k) {LW(z) = k; HW(z) = 0;} #define set_hw(z, k) {LW(z) = 0; HW(z) = k;} #define set_hwlw(z, h, l) {LW (z) = l; HW (z) = h;} #define D_ZERO(z) (HW (z) == 0 && LW (z) == 0) #define add_double(p, m, w, u, v)\ {\ QUAD_WORD_T _ww_;\ LW (_ww_) = LW (u) + LW (v);\ HW (_ww_) = HW (u) + HW (v);\ PRELUDE_ERROR (MODCHK (p, m, HW (_ww_) < HW (v)), p, ERROR_MATH, (m));\ if (LW (_ww_) < LW (v)) {\ HW (_ww_)++;\ PRELUDE_ERROR (MODCHK (p, m, HW (_ww_) < 1), p, ERROR_MATH, (m));\ }\ w = _ww_;\ } #define sub_double(p, m, w, u, v)\ {\ QUAD_WORD_T _ww_;\ LW (_ww_) = LW (u) - LW (v);\ HW (_ww_) = HW (u) - HW (v);\ PRELUDE_ERROR (MODCHK (p, m, HW (_ww_) > HW (u)), p, ERROR_MATH, (m));\ if (LW (_ww_) > LW (u)) {\ PRELUDE_ERROR (MODCHK (p, m, HW (_ww_) == 0), p, ERROR_MATH, (m));\ HW (_ww_)--;\ }\ w = _ww_;\ } static inline QUAD_WORD_T dble (DOUBLE_T x) { QUAD_WORD_T w; w.f = x; return w; } static inline int sign_int_16 (QUAD_WORD_T w) { if (D_NEG (w)) { return -1; } else if (D_ZERO (w)) { return 0; } else { return 1; } } static inline int sign_real_16 (QUAD_WORD_T w) { if (w.f < 0.0q) { return -1; } else if (w.f == 0.0q) { return 0; } else { return 1; } } static inline QUAD_WORD_T inline abs_int_16 (QUAD_WORD_T z) { QUAD_WORD_T w; LW (w) = LW (z); HW (w) = HW (z) & (~D_SIGN); return w; } static inline QUAD_WORD_T inline neg_int_16 (QUAD_WORD_T z) { QUAD_WORD_T w; LW (w) = LW (z); if (D_NEG (z)) { HW (w) = HW (z) & (~D_SIGN); } else { HW (w) = HW (z) | D_SIGN; } return w; } extern int sign_int_16 (QUAD_WORD_T); extern int sign_real_16 (QUAD_WORD_T); extern int string_to_int_16 (NODE_T *, A68_LONG_INT *, char *); extern DOUBLE_T a68_double_hypot (DOUBLE_T, DOUBLE_T); extern DOUBLE_T a68_strtoq (char *, char **); extern DOUBLE_T inverf_real_16 (DOUBLE_T); extern QUAD_WORD_T abs_int_16 (QUAD_WORD_T); extern QUAD_WORD_T bits_to_int_16 (NODE_T *, char *); extern QUAD_WORD_T dble_16 (NODE_T *, REAL_T); extern QUAD_WORD_T int_16_to_real_16 (NODE_T *, QUAD_WORD_T); extern QUAD_WORD_T double_strtou (NODE_T *, char *); extern QUAD_WORD_T double_udiv (NODE_T *, MOID_T *, QUAD_WORD_T, QUAD_WORD_T, int); extern DOUBLE_T a68_dneginf (void); extern DOUBLE_T a68_dposinf (void); extern void deltagammainc_16 (DOUBLE_T *, DOUBLE_T *, DOUBLE_T, DOUBLE_T, DOUBLE_T, DOUBLE_T); extern GPROC genie_infinity_real_16; extern GPROC genie_minus_infinity_real_16; extern GPROC genie_gamma_inc_g_real_16; extern GPROC genie_gamma_inc_f_real_16; extern GPROC genie_gamma_inc_h_real_16; extern GPROC genie_gamma_inc_gf_real_16; extern GPROC genie_abs_complex_32; extern GPROC genie_abs_int_16; extern GPROC genie_abs_real_16; extern GPROC genie_acos_complex_32; extern GPROC genie_acosdg_real_16; extern GPROC genie_acosh_complex_32; extern GPROC genie_acosh_real_16; extern GPROC genie_acos_real_16; extern GPROC genie_acotdg_real_16; extern GPROC genie_acot_real_16; extern GPROC genie_asec_real_16; extern GPROC genie_acsc_real_16; extern GPROC genie_add_complex_32; extern GPROC genie_add_double_bits; extern GPROC genie_add_int_16; extern GPROC genie_add_real_16; extern GPROC genie_add_real_16; extern GPROC genie_and_double_bits; extern GPROC genie_arg_complex_32; extern GPROC genie_asin_complex_32; extern GPROC genie_asindg_real_16; extern GPROC genie_asindg_real_16; extern GPROC genie_asinh_complex_32; extern GPROC genie_asinh_real_16; extern GPROC genie_asin_real_16; extern GPROC genie_atan2dg_real_16; extern GPROC genie_atan2_real_16; extern GPROC genie_atan_complex_32; extern GPROC genie_atandg_real_16; extern GPROC genie_atanh_complex_32; extern GPROC genie_atanh_real_16; extern GPROC genie_atan_real_16; extern GPROC genie_bin_int_16; extern GPROC genie_clear_double_bits; extern GPROC genie_conj_complex_32; extern GPROC genie_cos_complex_32; extern GPROC genie_cosdg_real_16; extern GPROC genie_cosdg_real_16; extern GPROC genie_cosh_complex_32; extern GPROC genie_cosh_real_16; extern GPROC genie_cospi_real_16; extern GPROC genie_cos_real_16; extern GPROC genie_cotdg_real_16; extern GPROC genie_cotpi_real_16; extern GPROC genie_cot_real_16; extern GPROC genie_sec_real_16; extern GPROC genie_csc_real_16; extern GPROC genie_curt_real_16; extern GPROC genie_divab_complex_32; extern GPROC genie_divab_real_16; extern GPROC genie_divab_real_16; extern GPROC genie_div_complex_32; extern GPROC genie_div_int_16; extern GPROC genie_double_bits_pack; extern GPROC genie_double_max_bits; extern GPROC genie_double_max_int; extern GPROC genie_double_max_real; extern GPROC genie_double_min_real; extern GPROC genie_double_small_real; extern GPROC genie_double_zeroin; extern GPROC genie_elem_double_bits; extern GPROC genie_entier_real_16; extern GPROC genie_eq_complex_32; extern GPROC genie_eq_double_bits; extern GPROC genie_eq_int_16; extern GPROC genie_eq_int_16; extern GPROC genie_eq_real_16; extern GPROC genie_eq_real_16; extern GPROC genie_eq_real_16; extern GPROC genie_eq_real_16; extern GPROC genie_erfc_real_16; extern GPROC genie_erf_real_16; extern GPROC genie_exp_complex_32; extern GPROC genie_exp_real_16; extern GPROC genie_gamma_real_16; extern GPROC genie_ge_double_bits; extern GPROC genie_ge_int_16; extern GPROC genie_ge_int_16; extern GPROC genie_ge_real_16; extern GPROC genie_ge_real_16; extern GPROC genie_ge_real_16; extern GPROC genie_ge_real_16; extern GPROC genie_gt_double_bits; extern GPROC genie_gt_int_16; extern GPROC genie_gt_int_16; extern GPROC genie_gt_real_16; extern GPROC genie_gt_real_16; extern GPROC genie_gt_real_16; extern GPROC genie_gt_real_16; extern GPROC genie_i_complex_32; extern GPROC genie_i_int_complex_32; extern GPROC genie_im_complex_32; extern GPROC genie_inverfc_real_16; extern GPROC genie_inverf_real_16; extern GPROC genie_le_double_bits; extern GPROC genie_le_int_16; extern GPROC genie_le_int_16; extern GPROC genie_lengthen_bits_to_double_bits; extern GPROC genie_lengthen_complex_32_to_long_mp_complex; extern GPROC genie_lengthen_complex_to_complex_32; extern GPROC genie_lengthen_int_16_to_mp; extern GPROC genie_lengthen_int_to_int_16; extern GPROC genie_lengthen_real_16_to_mp; extern GPROC genie_lengthen_real_to_real_16; extern GPROC genie_le_real_16; extern GPROC genie_le_real_16; extern GPROC genie_le_real_16; extern GPROC genie_le_real_16; extern GPROC genie_ln_complex_32; extern GPROC genie_lngamma_real_16; extern GPROC genie_ln_real_16; extern GPROC genie_log_real_16; extern GPROC genie_lt_double_bits; extern GPROC genie_lt_int_16; extern GPROC genie_lt_int_16; extern GPROC genie_lt_real_16; extern GPROC genie_lt_real_16; extern GPROC genie_lt_real_16; extern GPROC genie_lt_real_16; extern GPROC genie_minusab_complex_32; extern GPROC genie_minusab_int_16; extern GPROC genie_minusab_int_16; extern GPROC genie_minusab_real_16; extern GPROC genie_minusab_real_16; extern GPROC genie_minus_complex_32; extern GPROC genie_minus_int_16; extern GPROC genie_minus_real_16; extern GPROC genie_modab_int_16; extern GPROC genie_modab_int_16; extern GPROC genie_mod_double_bits; extern GPROC genie_mod_int_16; extern GPROC genie_mul_complex_32; extern GPROC genie_mul_int_16; extern GPROC genie_mul_real_16; extern GPROC genie_mul_real_16; extern GPROC genie_ne_complex_32; extern GPROC genie_ne_double_bits; extern GPROC genie_ne_int_16; extern GPROC genie_ne_int_16; extern GPROC genie_ne_int_16; extern GPROC genie_ne_int_16; extern GPROC genie_ne_real_16; extern GPROC genie_ne_real_16; extern GPROC genie_ne_real_16; extern GPROC genie_ne_real_16; extern GPROC genie_ne_real_16; extern GPROC genie_ne_real_16; extern GPROC genie_ne_real_16; extern GPROC genie_ne_real_16; extern GPROC genie_next_random_real_16; extern GPROC genie_not_double_bits; extern GPROC genie_odd_int_16; extern GPROC genie_or_double_bits; extern GPROC genie_overab_int_16; extern GPROC genie_overab_int_16; extern GPROC genie_over_double_bits; extern GPROC genie_over_int_16; extern GPROC genie_over_real_16; extern GPROC genie_over_real_16; extern GPROC genie_pi_double; extern GPROC genie_plusab_complex_32; extern GPROC genie_plusab_int_16; extern GPROC genie_plusab_int_16; extern GPROC genie_plusab_real_16; extern GPROC genie_pow_complex_32_int; extern GPROC genie_pow_int_16_int; extern GPROC genie_pow_real_16; extern GPROC genie_pow_real_16_int; extern GPROC genie_re_complex_32; extern GPROC genie_rol_double_bits; extern GPROC genie_ror_double_bits; extern GPROC genie_round_real_16; extern GPROC genie_set_double_bits; extern GPROC genie_shl_double_bits; extern GPROC genie_shorten_complex_32_to_complex; extern GPROC genie_shorten_double_bits_to_bits; extern GPROC genie_shorten_long_int_to_int; extern GPROC genie_shorten_long_mp_complex_to_complex_32; extern GPROC genie_shorten_mp_to_int_16; extern GPROC genie_shorten_mp_to_real_16; extern GPROC genie_shorten_real_16_to_real; extern GPROC genie_shr_double_bits; extern GPROC genie_sign_int_16; extern GPROC genie_sign_real_16; extern GPROC genie_sin_complex_32; extern GPROC genie_sindg_real_16; extern GPROC genie_sinh_complex_32; extern GPROC genie_sinh_real_16; extern GPROC genie_sinpi_real_16; extern GPROC genie_sin_real_16; extern GPROC genie_sqrt_complex_32; extern GPROC genie_sqrt_double; extern GPROC genie_sqrt_real_16; extern GPROC genie_sqrt_real_16; extern GPROC genie_sub_complex_32; extern GPROC genie_sub_double_bits; extern GPROC genie_sub_int_16; extern GPROC genie_sub_real_16; extern GPROC genie_sub_real_16; extern GPROC genie_tan_complex_32; extern GPROC genie_tandg_real_16; extern GPROC genie_tanh_complex_32; extern GPROC genie_tanh_real_16; extern GPROC genie_tanpi_real_16; extern GPROC genie_tan_real_16; extern GPROC genie_timesab_complex_32; extern GPROC genie_timesab_int_16; extern GPROC genie_timesab_int_16; extern GPROC genie_timesab_real_16; extern GPROC genie_timesab_real_16; extern GPROC genie_times_double_bits; extern GPROC genie_widen_int_16_to_real_16; extern GPROC genie_xor_double_bits; extern GPROC genie_beta_inc_cf_real_16; extern GPROC genie_beta_real_16; extern GPROC genie_ln_beta_real_16; extern GPROC genie_gamma_inc_real_16; extern GPROC genie_zero_int_16; #endif #endif algol68g-3.1.2/src/include/a68g-enums.h0000644000175000017500000001572614361065320014351 00000000000000//! @file a68g-enums.h //! @author J. Marcel van der Veer // //! @section Copyright // // This file is part of Algol68G - an Algol 68 compiler-interpreter. // Copyright 2001-2023 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 (__A68G_ENUMS_H__) #define __A68G_ENUMS_H__ // Enumerated constants enum { UPPER_STROPPING = 1, QUOTE_STROPPING }; enum { NO_OPTIMISE = 0, OPTIMISE_0, OPTIMISE_1, OPTIMISE_2, OPTIMISE_3, OPTIMISE_FAST, }; enum { STOP = 0, A68_PATTERN, ACCO_SYMBOL, ACTUAL_DECLARER_MARK, ALIF_IF_PART, ALIF_PART, ALIF_SYMBOL, 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_CLOSE_SYMBOL, FORMAT_DELIMITER_SYMBOL, FORMAT_IDENTIFIER, FORMAT_A_FRAME, FORMAT_D_FRAME, FORMAT_E_FRAME, FORMAT_I_FRAME, FORMAT_ITEM_A, FORMAT_ITEM_B, FORMAT_ITEM_C, FORMAT_ITEM_D, FORMAT_ITEM_E, 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_N, FORMAT_ITEM_O, FORMAT_ITEM_P, 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_ITEM_ESCAPE, FORMAT_ITEM_MINUS, FORMAT_ITEM_PLUS, FORMAT_ITEM_POINT, 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, GUARDED_CONDITIONAL_CLAUSE, GUARDED_LOOP_CLAUSE, 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_LONG_LONG_BITS, MODE_LONG_LONG_COMPLEX, MODE_LONG_LONG_INT, MODE_LONG_LONG_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 }; enum { INPUT_BUFFER = 0, OUTPUT_BUFFER, EDIT_BUFFER, UNFORMATTED_BUFFER, FORMATTED_BUFFER, DOMAIN_BUFFER, PATH_BUFFER, REQUEST_BUFFER, CONTENT_BUFFER, STRING_BUFFER, PATTERN_BUFFER, REPLACE_BUFFER, FIXED_TRANSPUT_BUFFERS }; enum { NO_DEFLEXING = 1, SAFE_DEFLEXING, ALIAS_DEFLEXING, FORCE_DEFLEXING, SKIP_DEFLEXING }; #endif algol68g-3.1.2/src/include/a68g-options.h0000644000175000017500000000253614361065320014710 00000000000000//! @file a68g-options.h //! @author J. Marcel van der Veer // //! @section Copyright // // This file is part of Algol68G - an Algol 68 compiler-interpreter. // Copyright 2001-2023 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 (__A68G_OPTIONS_H__) #define __A68G_OPTIONS_H__ extern BOOL_T set_options (OPTION_LIST_T *, BOOL_T); extern char *optimisation_option (void); extern void add_option_list (OPTION_LIST_T **, char *, LINE_T *); extern void free_option_list (OPTION_LIST_T *); extern void default_options (MODULE_T *); extern void init_options (void); extern void isolate_options (char *, LINE_T *); extern void read_env_options (void); extern void read_rc_options (void); #endif algol68g-3.1.2/src/a68g/0000755000175000017500000000000014361065617011506 500000000000000algol68g-3.1.2/src/a68g/scope.c0000644000175000017500000006357514361065320012712 00000000000000//! @file scope.c //! @author J. Marcel van der Veer // //! @section Copyright // // This file is part of Algol68G - an Algol 68 compiler-interpreter. // Copyright 2001-2023 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 . // A static scope checker inspects the source. Note that Algol 68 also // needs dynamic scope checking. This phase concludes the parser. #include "a68g.h" #include "a68g-parser.h" 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 }; void gather_scopes_for_youngest (NODE_T *, SCOPE_T **); void scope_statement (NODE_T *, SCOPE_T **); void scope_enclosed_clause (NODE_T *, SCOPE_T **); void scope_formula (NODE_T *, SCOPE_T **); void scope_routine_text (NODE_T *, SCOPE_T **); // 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. 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. 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 ((unt) SIZE_ALIGNED (SCOPE_T)); WHERE (ns) = p; TUPLE (ns) = tup; NEXT (ns) = *sl; *sl = ns; } } //! @brief Scope_check. 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 (A68_ERROR, WHERE (s), ERROR_TRANSIENT_NAME); STATUS_SET (WHERE (s), SCOPE_ERROR_MASK); errors++; } } } // Potential scope violations. for (s = top; s != NO_SCOPE; FORWARD (s)) { if (dest < LEVEL (&TUPLE (s)) && !STATUS_TEST (WHERE (s), SCOPE_ERROR_MASK)) { MOID_T *ws = MOID (WHERE (s)); if (ws != NO_MOID) { if (IS_REF (ws) || IS (ws, PROC_SYMBOL) || IS (ws, FORMAT_SYMBOL) || IS (ws, UNION_SYMBOL)) { diagnostic (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. 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. 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 (A68_WARNING, p, WARNING_UNINITIALISED); } check_identifier_usage (t, SUB (p)); } } //! @brief Scope_find_youngest_outside. 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. TUPLE_T scope_find_youngest (SCOPE_T * s) { return scope_find_youngest_outside (s, INT_MAX); } // Routines for determining scope of ROUTINE TEXT or FORMAT TEXT. //! @brief Get_declarer_elements. 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_REF (p)) { 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. 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. 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. void bind_scope_to_tag (NODE_T * p) { for (; p != NO_NODE; FORWARD (p)) { if (IS (p, DEFINING_IDENTIFIER) && MOID (p) == M_FORMAT) { if (IS (NEXT_NEXT (p), FORMAT_TEXT)) { SCOPE (TAX (p)) = YOUNGEST_ENVIRON (TAX (NEXT_NEXT (p))); SCOPE_ASSIGNED (TAX (p)) = 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. 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. 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. void scope_declarer (NODE_T * p) { if (p != NO_NODE) { if (IS (p, BOUNDS)) { scope_bounds (SUB (p)); } else if (IS (p, INDICANT)) { ; } else if (IS_REF (p)) { scope_declarer (NEXT (p)); } else if (is_one_of (p, PROC_SYMBOL, UNION_SYMBOL, STOP)) { ; } else { scope_declarer (SUB (p)); scope_declarer (NEXT (p)); } } } //! @brief Scope_identity_declaration. 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. 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. 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. 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. 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. 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. void scope_coercion (NODE_T * p, SCOPE_T ** s) { if (is_coercion (p)) { if (IS (p, VOIDING)) { scope_coercion (SUB (p), NO_VAR); } else if (IS (p, DEREFERENCING)) { // Leave this to the dynamic scope checker. scope_coercion (SUB (p), NO_VAR); } else if (IS (p, DEPROCEDURING)) { scope_coercion (SUB (p), NO_VAR); } else if (IS (p, ROWING)) { SCOPE_T *z = NO_SCOPE; scope_coercion (SUB (p), &z); (void) scope_check (z, TRANSIENT, LEX_LEVEL (p)); if (IS_REF_FLEX (MOID (SUB (p)))) { scope_add (s, p, scope_make_tuple (LEX_LEVEL (p), TRANSIENT)); } else { scope_add (s, p, scope_make_tuple (LEX_LEVEL (p), NOT_TRANSIENT)); } } else if (IS (p, PROCEDURING)) { // Can only be a JUMP. NODE_T *q = SUB_SUB (p); if (IS (q, GOTO_SYMBOL)) { FORWARD (q); } scope_add (s, q, scope_make_tuple (TAG_LEX_LEVEL (TAX (q)), NOT_TRANSIENT)); } else if (IS (p, UNITING)) { SCOPE_T *z = NO_SCOPE; scope_coercion (SUB (p), &z); if (z != NO_SCOPE) { (void) scope_check (z, TRANSIENT, LEX_LEVEL (p)); scope_add (s, p, scope_find_youngest (z)); } } else { scope_coercion (SUB (p), s); } } else { scope_statement (p, s); } } //! @brief Scope_format_text. 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. 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. 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. 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. 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, NIHIL, STOP)) { scope_add (s, p, scope_make_tuple (PRIMAL_SCOPE, NOT_TRANSIENT)); } else if (IS (p, DENOTATION)) { ; } else if (IS (p, IDENTIFIER)) { if (IS_REF (MOID (p))) { if (PRIO (TAX (p)) == PARAMETER_IDENTIFIER) { scope_add (s, p, scope_make_tuple (TAG_LEX_LEVEL (TAX (p)) - 1, NOT_TRANSIENT)); } else { if (HEAP (TAX (p)) == HEAP_SYMBOL) { scope_add (s, p, scope_make_tuple (PRIMAL_SCOPE, NOT_TRANSIENT)); } else if (SCOPE_ASSIGNED (TAX (p))) { scope_add (s, p, scope_make_tuple (SCOPE (TAX (p)), NOT_TRANSIENT)); } else { scope_add (s, p, scope_make_tuple (TAG_LEX_LEVEL (TAX (p)), NOT_TRANSIENT)); } } } else if (ATTRIBUTE (MOID (p)) == PROC_SYMBOL && SCOPE_ASSIGNED (TAX (p)) == A68_TRUE) { scope_add (s, p, scope_make_tuple (SCOPE (TAX (p)), NOT_TRANSIENT)); } else if (MOID (p) == M_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_REF (m)) { if (ATTRIBUTE (SUB (p)) == PRIMARY && ATTRIBUTE (SUB_SUB (p)) == SLICE) { scope_statement (SUB (p), s); } else { scope_statement (SUB (p), &x); (void) scope_check (x, NOT_TRANSIENT, LEX_LEVEL (p)); } if (IS_FLEX (SUB (m))) { scope_add (s, SUB (p), scope_make_tuple (LEX_LEVEL (p), TRANSIENT)); } scope_bounds (SUB (NEXT_SUB (p))); } if (IS_REF (MOID (p))) { scope_add (s, p, scope_find_youngest (x)); } } else if (IS (p, FORMAT_TEXT)) { SCOPE_T *x = NO_SCOPE; scope_format_text (SUB (p), &x); scope_add (s, p, scope_find_youngest (x)); } else if (IS (p, CAST)) { SCOPE_T *x = NO_SCOPE; scope_enclosed_clause (SUB (NEXT_SUB (p)), &x); (void) scope_check (x, NOT_TRANSIENT, LEX_LEVEL (p)); scope_add (s, p, scope_find_youngest (x)); } else if (IS (p, SELECTION)) { SCOPE_T *ns = NO_SCOPE; scope_statement (NEXT_SUB (p), &ns); (void) scope_check (ns, NOT_TRANSIENT, LEX_LEVEL (p)); if (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. 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. 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. 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. 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. 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. 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. 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. 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. 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. 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. 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); } algol68g-3.1.2/src/a68g/double-gamic.c0000644000175000017500000003255014361065320014116 00000000000000//! @file double-gamic.c //! @author J. Marcel van der Veer // //! @section Copyright // // This file is part of Algol68G - an Algol 68 compiler-interpreter. // Copyright 2001-2023 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 . // Generalised incomplete gamma code in this file was downloaded from // http://helios.mi.parisdescartes.fr/~rabergel/ // and adapted for Algol 68 Genie. // // Reference: // Rémy Abergel, Lionel Moisan. Fast and accurate evaluation of a // generalized incomplete gamma function. 2019. hal-01329669v2 // // Original source code copyright and license: // // DELTAGAMMAINC Fast and Accurate Evaluation of a Generalized Incomplete Gamma // Function. Copyright (C) 2016 Remy Abergel (remy.abergel AT gmail.com), Lionel // Moisan (Lionel.Moisan AT parisdescartes.fr). // // This file is a part of the DELTAGAMMAINC software, dedicated to the // computation of a generalized incomplete gammafunction. See the Companion paper // for a complete description of the algorithm. // // ``Fast and accurate evaluation of a generalized incomplete gamma function'' // (Rémy Abergel, Lionel Moisan), preprint MAP5 nº2016-14, revision 1. // // 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 . // References // // R. Abergel and L. Moisan. 2016. Fast and accurate evaluation of a // generalized incomplete gamma function, preprint MAP5 nº2016-14, revision 1 // // Rémy Abergel, Lionel Moisan. Fast and accurate evaluation of a // generalized incomplete gamma function. 2019. hal-01329669v2 // // F. W. J. Olver, D. W. Lozier, R. F. Boisvert, and C. W. Clark // (Eds.). 2010. NIST Handbook of Mathematical Functions. Cambridge University // Press. (see online version at [[http://dlmf.nist.gov/]]) // // W. H. Press, S. A. Teukolsky, W. T. Vetterling, and // B. P. Flannery. 1992. Numerical recipes in C: the art of scientific // computing (2nd ed.). // // G. R. Pugh, 2004. An analysis of the Lanczos Gamma approximation (phd // thesis) #include "a68g.h" #if (A68_LEVEL >= 3) #include "a68g-genie.h" #include "a68g-prelude.h" #include "a68g-lib.h" #include "a68g-double.h" #include "a68g-mp.h" #define ITMAX 1000000000 // Maximum allowed number of iterations #define DPMIN FLT128_MIN // Number near the smallest representable double-point number #define EPS FLT128_EPSILON // Machine epsilon #define NITERMAX_ROMBERG 15 // Maximum allowed number of Romberg iterations #define TOL_ROMBERG 0.1q // Tolerance factor used to stop the Romberg iterations #define TOL_DIFF 0.2q // Tolerance factor used for the approximation of I_{x,y}^{mu,p} using differences // double_plim: compute plim (x), the limit of the partition of the domain (p,x) // detailed in the paper. // // | x if 0 < x // | // plim (x) = < 0 if -9 <= x <= 0 // | // | 5.*sqrt (|x|)-5. otherwise DOUBLE_T double_plim (DOUBLE_T x) { return (x >= 0.0q) ? x : ((x >= -9.0q) ? 0.0q : 5.0q * sqrt (-x) - 5.0q); } //! @brief compute G(p,x) in the domain x <= p using a continued fraction // // p >= 0 // x <= p void double_G_cfrac_lower (DOUBLE_T * Gcfrac, DOUBLE_T p, DOUBLE_T x) { DOUBLE_T c, d, del, f, an, bn; INT_T k, n; // deal with special case if (x == 0.0q) { *Gcfrac = 0.0q; return; } // Evaluate the continued fraction using Modified Lentz's method. However, // as detailed in the paper, perform manually the first pass (n=1), of the // initial Modified Lentz's method. an = 1.0q; bn = p; f = an / bn; c = an / DPMIN; d = 1.0q / bn; n = 2; do { k = n / 2; an = (n & 1 ? k : -(p - 1.0q + k)) * x; bn++; d = an * d + bn; if (d == 0.0q) { d = DPMIN; } c = bn + an / c; if (c == 0.0q) { c = DPMIN; } d = 1.0q / d; del = d * c; f *= del; n++; } while ((fabsq (del - 1.0q) >= EPS) && (n < ITMAX)); *Gcfrac = f; } //! @brief compute the G-function in the domain x < 0 and |x| < max (1,p-1) // using a recursive integration by parts relation. // This function cannot be used when mu > 0. // // p > 0, integer // x < 0, |x| < max (1,p-1) void double_G_ibp (DOUBLE_T * Gibp, DOUBLE_T p, DOUBLE_T x) { DOUBLE_T t, tt, c, d, s, del; INT_T l; BOOL_T odd, stop; t = fabsq (x); tt = 1.0q / (t * t); odd = (INT_T) (p) % 2 != 0; c = 1.0q / t; d = (p - 1.0q); s = c * (t - d); l = 0; do { c *= d * (d - 1.0q) * tt; d -= 2.0q; del = c * (t - d); s += del; l++; stop = fabsq (del) < fabsq (s) * EPS; } while ((l < floorq ((p - 2.0q) / 2.0q)) && !stop); if (odd && !stop) { s += d * c / t; } *Gibp = ((odd ? -1.0q : 1.0q) * expq (-t + lgammaq (p) - (p - 1.0q) * logq (t)) + s) / t; } //! @brief compute the G-function in the domain x > p using a // continued fraction. // // p > 0 // x > p, or x = +infinity void double_G_cfrac_upper (DOUBLE_T * Gcfrac, DOUBLE_T p, DOUBLE_T x) { DOUBLE_T c, d, del, f, an, bn; INT_T i, n; BOOL_T t; // Special case if (isinfq (x)) { *Gcfrac = 0.0q; return; } // Evaluate the continued fraction using Modified Lentz's method. However, // as detailed in the paper, perform manually the first pass (n=1), of the // initial Modified Lentz's method. an = 1.0q; bn = x + 1.0q - p; t = bn != 0.0q; if (t) { // b{1} is non-zero f = an / bn; c = an / DPMIN; d = 1.0q / bn; n = 2; } else { // b{1}=0 but b{2} is non-zero, compute Mcfrac = a{1}/f with f = a{2}/(b{2}+) a{3}/(b{3}+) ... an = -(1.0q - p); bn = x + 3.0q - p; f = an / bn; c = an / DPMIN; d = 1.0q / bn; n = 3; } i = n - 1; do { an = -i * (i - p); bn += 2.0q; d = an * d + bn; if (d == 0.0q) { d = DPMIN; } c = bn + an / c; if (c == 0.0q) { c = DPMIN; } d = 1.0q / d; del = d * c; f *= del; i++; n++; } while ((fabsq (del - 1.0q) >= EPS) && (n < ITMAX)); *Gcfrac = t ? f : 1.0q / f; } //! @brief compute G : (p,x) --> R defined as follows // // if x <= p: // G(p,x) = exp (x-p*ln (|x|)) * integral of s^{p-1} * exp (-sign (x)*s) ds from s = 0 to |x| // otherwise: // G(p,x) = exp (x-p*ln (|x|)) * integral of s^{p-1} * exp (-s) ds from s = x to infinity // // p > 0 // x is a real number or +infinity. void double_G_func (DOUBLE_T * G, DOUBLE_T p, DOUBLE_T x) { if (p >= double_plim (x)) { double_G_cfrac_lower (G, p, x); } else if (x < 0.0q) { double_G_ibp (G, p, x); } else { double_G_cfrac_upper (G, p, x); } } //! @brief iteration of the Romberg approximation of I_{x,y}^{mu,p} void double_romberg_iterations (DOUBLE_T * R, DOUBLE_T sigma, INT_T n, DOUBLE_T x, DOUBLE_T y, DOUBLE_T mu, DOUBLE_T p, DOUBLE_T h, DOUBLE_T pow2) { INT_T j, m; DOUBLE_T sum, xx; INT_T adr0_prev = ((n - 1) * n) / 2; INT_T adr0 = (n * (n + 1)) / 2; for (sum = 0.0q, j = 1; j <= pow2; j++) { xx = x + ((y - x) * (2.0q * j - 1.0q)) / (2.0q * pow2); sum += expq (-mu * xx + (p - 1.0q) * logq (xx) - sigma); } R[adr0] = 0.5q * R[adr0_prev] + h * sum; DOUBLE_T pow4 = 4.0q; for (m = 1; m <= n; m++) { R[adr0 + m] = (pow4 * R[adr0 + (m - 1)] - R[adr0_prev + (m - 1)]) / (pow4 - 1.0q); pow4 *= 4.0q; } } //! @ compute I_{x,y}^{mu,p} using a Romberg approximation. // Compute rho and sigma so I_{x,y}^{mu,p} = rho * exp (sigma) void double_romberg_estimate (DOUBLE_T * rho, DOUBLE_T * sigma, DOUBLE_T x, DOUBLE_T y, DOUBLE_T mu, DOUBLE_T p) { DOUBLE_T *R = (DOUBLE_T *) get_heap_space (((NITERMAX_ROMBERG + 1) * (NITERMAX_ROMBERG + 2)) / 2 * sizeof (DOUBLE_T)); ASSERT (R != NULL); // Initialization (n=1) *sigma = -mu * y + (p - 1.0q) * logq (y); R[0] = 0.5q * (y - x) * (expq (-mu * x + (p - 1.0q) * logq (x) - (*sigma)) + 1.0q); // Loop for n > 0 DOUBLE_T relneeded = EPS / TOL_ROMBERG; INT_T adr0 = 0; INT_T n = 1; DOUBLE_T h = (y - x) / 2.0q; // n=1, h = (y-x)/2^n DOUBLE_T pow2 = 1.0q; // n=1; pow2 = 2^(n-1) if (NITERMAX_ROMBERG >= 1) { DOUBLE_T relerr; do { double_romberg_iterations (R, *sigma, n, x, y, mu, p, h, pow2); h /= 2.0q; pow2 *= 2.0q; adr0 = (n * (n + 1)) / 2; relerr = fabsq ((R[adr0 + n] - R[adr0 + n - 1]) / R[adr0 + n]); n++; } while (n <= NITERMAX_ROMBERG && relerr > relneeded); } // save Romberg estimate and free memory *rho = R[adr0 + (n - 1)]; a68_free (R); } //! @brief compute generalized incomplete gamma function I_{x,y}^{mu,p} // // I_{x,y}^{mu,p} = integral from x to y of s^{p-1} * exp (-mu*s) ds // // This procedure computes (rho, sigma) described below. // The approximated value of I_{x,y}^{mu,p} is I = rho * exp (sigma) // // mu is a real number non equal to zero // (in general we take mu = 1 or -1 but any nonzero real number is allowed) // // x, y are two numbers with 0 <= x <= y <= +infinity, // (the setting y=+infinity is allowed only when mu > 0) // // p is a real number > 0, p must be an integer when mu < 0. void deltagammainc_16 (DOUBLE_T * rho, DOUBLE_T * sigma, DOUBLE_T x, DOUBLE_T y, DOUBLE_T mu, DOUBLE_T p) { DOUBLE_T mA, mB, mx, my, nA, nB, nx, ny; // Particular cases if (isinfq (x) && isinfq (y)) { *rho = 0.0q; *sigma = a68_dneginf (); return; } else if (x == y) { *rho = 0.0q; *sigma = a68_dneginf (); return; } if (x == 0.0q && isinfq (y)) { *rho = 1.0q; (*sigma) = lgammaq (p) - p * logq (mu); return; } // Initialization double_G_func (&mx, p, mu * x); nx = (isinfq (x) ? a68_dneginf () : -mu * x + p * logq (x)); double_G_func (&my, p, mu * y); ny = (isinfq (y) ? a68_dneginf () : -mu * y + p * logq (y)); // Compute (mA,nA) and (mB,nB) such as I_{x,y}^{mu,p} can be // approximated by the difference A-B, where A >= B >= 0, A = mA*exp (nA) an // B = mB*exp (nB). When the difference involves more than one digit loss due to // cancellation errors, the integral I_{x,y}^{mu,p} is evaluated using the // Romberg approximation method. if (mu < 0.0q) { mA = my; nA = ny; mB = mx; nB = nx; } else { if (p < double_plim (mu * x)) { mA = mx; nA = nx; mB = my; nB = ny; } else if (p < double_plim (mu * y)) { mA = 1.0q; nA = lgammaq (p) - p * logq (mu); nB = fmax (nx, ny); mB = mx * expq (nx - nB) + my * expq (ny - nB); } else { mA = my; nA = ny; mB = mx; nB = nx; } } // Compute (rho,sigma) such that rho*exp (sigma) = A-B *rho = mA - mB * expq (nB - nA); *sigma = nA; // If the difference involved a significant loss of precision, compute Romberg estimate. if (!isinfq (y) && ((*rho) / mA < TOL_DIFF)) { double_romberg_estimate (rho, sigma, x, y, mu, p); } } // A68G Driver routines //! @brief PROC long gamma inc g = (LONG REAL p, x, y, mu) LONG REAL void genie_gamma_inc_g_real_16 (NODE_T * n) { A68_LONG_REAL x, y, mu, p; POP_OBJECT (n, &mu, A68_LONG_REAL); POP_OBJECT (n, &y, A68_LONG_REAL); POP_OBJECT (n, &x, A68_LONG_REAL); POP_OBJECT (n, &p, A68_LONG_REAL); DOUBLE_T rho, sigma; deltagammainc_16 (&rho, &sigma, VALUE (&x).f, VALUE (&y).f, VALUE (&mu).f, VALUE (&p).f); PUSH_VALUE (n, dble (rho * expq (sigma)), A68_LONG_REAL); } //! @brief PROC long gamma inc f = (LONG REAL p, x) LONG REAL void genie_gamma_inc_f_real_16 (NODE_T * n) { A68_LONG_REAL x, p; POP_OBJECT (n, &x, A68_LONG_REAL); POP_OBJECT (n, &p, A68_LONG_REAL); DOUBLE_T rho, sigma; deltagammainc_16 (&rho, &sigma, VALUE (&x).f, a68_dposinf (), 1.0q, VALUE (&p).f); PUSH_VALUE (n, dble (rho * expq (sigma)), A68_LONG_REAL); } //! @brief PROC long gamma inc gf = (LONG REAL p, x) LONG REAL void genie_gamma_inc_gf_real_16 (NODE_T * q) { // if x <= p: G(p,x) = exp (x-p*ln (|x|)) * integral over [0,|x|] of s^{p-1} * exp (-sign (x)*s) ds // otherwise: G(p,x) = exp (x-p*ln (x)) * integral over [x,inf] of s^{p-1} * exp (-s) ds A68_LONG_REAL x, p; POP_OBJECT (q, &x, A68_LONG_REAL); POP_OBJECT (q, &p, A68_LONG_REAL); DOUBLE_T G; double_G_func (&G, VALUE (&p).f, VALUE (&x).f); PUSH_VALUE (q, dble (G), A68_LONG_REAL); } //! @brief PROC long gamma inc = (LONG REAL p, x) LONG REAL void genie_gamma_inc_h_real_16 (NODE_T * n) { #if (A68_LEVEL >= 3) && defined (HAVE_GNU_MPFR) genie_gamma_inc_real_16_mpfr (n); #else genie_gamma_inc_f_real_16 (n); #endif } #endif algol68g-3.1.2/src/a68g/mp-constant.c0000644000175000017500000001142014361065320014022 00000000000000//! @file mp-constant.c //! @author J. Marcel van der Veer // //! @section Copyright // // This file is part of Algol68G - an Algol 68 compiler-interpreter. // Copyright 2001-2023 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" #include "a68g-genie.h" #include "a68g-prelude.h" #include "a68g-double.h" #include "a68g-mp.h" //! @brief Return "pi" with "digs" precision, using Borwein & Borwein AGM. MP_T *mp_pi (NODE_T * p, MP_T * api, int mod, int digs) { int gdigs = FUN_DIGITS (digs); if (gdigs > A68_MP (mp_pi_size)) { // 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 digs every iteration. a68_free (A68_MP (mp_pi)); a68_free (A68_MP (mp_half_pi)); a68_free (A68_MP (mp_two_pi)); a68_free (A68_MP (mp_sqrt_two_pi)); a68_free (A68_MP (mp_sqrt_pi)); a68_free (A68_MP (mp_ln_pi)); a68_free (A68_MP (mp_180_over_pi)); a68_free (A68_MP (mp_pi_over_180)); // ADDR_T pop_sp = A68_SP; MP_T *pi_g = nil_mp (p, gdigs); MP_T *two = lit_mp (p, 2, 0, gdigs); MP_T *x_g = lit_mp (p, 2, 0, gdigs); MP_T *y_g = nil_mp (p, gdigs); MP_T *u_g = nil_mp (p, gdigs); MP_T *v_g = nil_mp (p, gdigs); (void) sqrt_mp (p, x_g, x_g, gdigs); (void) add_mp (p, pi_g, x_g, two, gdigs); (void) sqrt_mp (p, y_g, x_g, gdigs); BOOL_T iterate = A68_TRUE; while (iterate) { // New x. (void) sqrt_mp (p, u_g, x_g, gdigs); (void) rec_mp (p, v_g, u_g, gdigs); (void) add_mp (p, u_g, u_g, v_g, gdigs); (void) half_mp (p, x_g, u_g, gdigs); // New pi. (void) plus_one_mp (p, u_g, x_g, gdigs); (void) plus_one_mp (p, v_g, y_g, gdigs); (void) div_mp (p, u_g, u_g, v_g, gdigs); (void) mul_mp (p, v_g, pi_g, u_g, gdigs); // Done yet?. if (same_mp (p, v_g, pi_g, gdigs)) { iterate = A68_FALSE; } else { (void) move_mp (pi_g, v_g, gdigs); // New y. (void) sqrt_mp (p, u_g, x_g, gdigs); (void) rec_mp (p, v_g, u_g, gdigs); (void) mul_mp (p, u_g, y_g, u_g, gdigs); (void) add_mp (p, u_g, u_g, v_g, gdigs); (void) plus_one_mp (p, v_g, y_g, gdigs); (void) div_mp (p, y_g, u_g, v_g, gdigs); } } // Keep the result for future restore. (void) shorten_mp (p, api, digs, pi_g, gdigs); A68_MP (mp_pi) = (MP_T *) get_heap_space ((unt) SIZE_MP (digs)); (void) move_mp (A68_MP (mp_pi), api, digs); A68_MP (mp_half_pi) = (MP_T *) get_heap_space ((unt) SIZE_MP (digs)); (void) half_mp (p, A68_MP (mp_half_pi), api, digs); A68_MP (mp_sqrt_pi) = (MP_T *) get_heap_space ((unt) SIZE_MP (digs)); (void) sqrt_mp (p, A68_MP (mp_sqrt_pi), api, digs); A68_MP (mp_ln_pi) = (MP_T *) get_heap_space ((unt) SIZE_MP (digs)); (void) ln_mp (p, A68_MP (mp_ln_pi), api, digs); A68_MP (mp_two_pi) = (MP_T *) get_heap_space ((unt) SIZE_MP (digs)); (void) mul_mp_digit (p, A68_MP (mp_two_pi), api, (MP_T) 2, digs); A68_MP (mp_sqrt_two_pi) = (MP_T *) get_heap_space ((unt) SIZE_MP (digs)); (void) sqrt_mp (p, A68_MP (mp_sqrt_two_pi), A68_MP (mp_two_pi), digs); A68_MP (mp_pi_over_180) = (MP_T *) get_heap_space ((unt) SIZE_MP (digs)); (void) div_mp_digit (p, A68_MP (mp_pi_over_180), api, 180, digs); A68_MP (mp_180_over_pi) = (MP_T *) get_heap_space ((unt) SIZE_MP (digs)); (void) rec_mp (p, A68_MP (mp_180_over_pi), A68_MP (mp_pi_over_180), digs); A68_MP (mp_pi_size) = gdigs; A68_SP = pop_sp; } switch (mod) { case MP_PI: return move_mp (api, A68_MP (mp_pi), digs); case MP_HALF_PI: return move_mp (api, A68_MP (mp_half_pi), digs); case MP_TWO_PI: return move_mp (api, A68_MP (mp_two_pi), digs); case MP_SQRT_TWO_PI: return move_mp (api, A68_MP (mp_sqrt_two_pi), digs); case MP_SQRT_PI: return move_mp (api, A68_MP (mp_sqrt_pi), digs); case MP_LN_PI: return move_mp (api, A68_MP (mp_ln_pi), digs); case MP_180_OVER_PI: return move_mp (api, A68_MP (mp_180_over_pi), digs); case MP_PI_OVER_180: return move_mp (api, A68_MP (mp_pi_over_180), digs); default: return NaN_MP; // Should not be here. } } algol68g-3.1.2/src/a68g/compiler-tables.c0000644000175000017500000005024214361065320014646 00000000000000//! @file compiler-tables.c //! @author J. Marcel van der Veer // //! @section Copyright // // This file is part of Algol68G - an Algol 68 compiler-interpreter. // Copyright 2001-2023 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" #include "a68g-prelude.h" #include "a68g-genie.h" #include "a68g-listing.h" #include "a68g-mp.h" #include "a68g-optimiser.h" #include "a68g-compiler.h" #include "a68g-parser.h" #include "a68g-transput.h" TRANSLATION *monadics, *dyadics, *functions; TRANSLATION monadics_nocheck[] = { {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, "a68_entier"}, {genie_round_real, "a68_round"}, {genie_not_bool, "!"}, {genie_abs_bool, "(int) "}, {genie_abs_bits, "(INT_T) "}, {genie_bin_int, "(UNSIGNED_T) "}, {genie_not_bits, "~"}, {genie_abs_char, "TO_UCHAR"}, {genie_repr_char, ""}, {genie_re_complex, "a68_re_complex"}, {genie_im_complex, "a68_im_complex"}, {genie_minus_complex, "a68_minus_complex"}, {genie_abs_complex, "a68_abs_complex"}, {genie_arg_complex, "a68_arg_complex"}, {genie_conj_complex, "a68_conj_complex"}, {genie_idle, ""}, {NO_GPROC, NO_TEXT} }; TRANSLATION monadics_check[] = { {genie_minus_int, "-"}, {genie_minus_real, "-"}, {genie_abs_int, "labs"}, {genie_abs_real, "fabs"}, {genie_sign_int, "SIGN"}, {genie_sign_real, "SIGN"}, {genie_not_bool, "!"}, {genie_abs_bool, "(int) "}, {genie_abs_bits, "(INT_T) "}, {genie_bin_int, "(UNSIGNED_T) "}, {genie_not_bits, "~"}, {genie_abs_char, "TO_UCHAR"}, {genie_repr_char, ""}, {genie_re_complex, "a68_re_complex"}, {genie_im_complex, "a68_im_complex"}, {genie_minus_complex, "a68_minus_complex"}, {genie_abs_complex, "a68_abs_complex"}, {genie_arg_complex, "a68_arg_complex"}, {genie_conj_complex, "a68_conj_complex"}, {genie_idle, ""}, {NO_GPROC, NO_TEXT} }; TRANSLATION dyadics_nocheck[] = { {genie_add_int, "+"}, {genie_sub_int, "-"}, {genie_mul_int, "*"}, {genie_over_int, "/"}, {genie_mod_int, "a68_mod_int"}, {genie_div_int, "a68_div_int"}, {genie_eq_int, "=="}, {genie_ne_int, "!="}, {genie_lt_int, "<"}, {genie_gt_int, ">"}, {genie_le_int, "<="}, {genie_ge_int, ">="}, {genie_plusab_int, "a68_plusab_int"}, {genie_minusab_int, "a68_minusab_int"}, {genie_timesab_int, "a68_timesab_int"}, {genie_overab_int, "a68_overab_int"}, {genie_add_real, "+"}, {genie_sub_real, "-"}, {genie_mul_real, "*"}, {genie_div_real, "/"}, {genie_pow_real, "a68_x_up_y"}, {genie_pow_real_int, "a68_x_up_n"}, {genie_eq_real, "=="}, {genie_ne_real, "!="}, {genie_lt_real, "<"}, {genie_gt_real, ">"}, {genie_le_real, "<="}, {genie_ge_real, ">="}, {genie_plusab_real, "a68_plusab_real"}, {genie_minusab_real, "a68_minusab_real"}, {genie_timesab_real, "a68_timesab_real"}, {genie_divab_real, "a68_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_i_complex, "a68_i_complex"}, {genie_i_int_complex, "a68_i_complex"}, {genie_abs_complex, "a68_abs_complex"}, {genie_arg_complex, "a68_arg_complex"}, {genie_add_complex, "a68_add_complex"}, {genie_sub_complex, "a68_sub_complex"}, {genie_mul_complex, "a68_mul_complex"}, {genie_div_complex, "a68_div_complex"}, {genie_eq_complex, "a68_eq_complex"}, {genie_ne_complex, "a68_ne_complex"}, {NO_GPROC, NO_TEXT} }; TRANSLATION dyadics_check[] = { {genie_add_int, "a68_add_int"}, {genie_sub_int, "a68_sub_int"}, {genie_mul_int, "a68_mul_int"}, {genie_over_int, "a68_over_int"}, {genie_mod_int, "a68_mod_int"}, {genie_div_int, "a68_div_int"}, {genie_add_real, "+"}, {genie_sub_real, "-"}, {genie_mul_real, "*"}, {genie_div_real, "/"}, {genie_pow_real, "a68_x_up_y"}, {genie_pow_real_int, "a68_x_up_n"}, {genie_eq_int, "=="}, {genie_ne_int, "!="}, {genie_lt_int, "<"}, {genie_gt_int, ">"}, {genie_le_int, "<="}, {genie_ge_int, ">="}, {genie_eq_real, "=="}, {genie_ne_real, "!="}, {genie_lt_real, "<"}, {genie_gt_real, ">"}, {genie_le_real, "<="}, {genie_ge_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_i_complex, "a68_i_complex"}, {genie_i_int_complex, "a68_i_complex"}, {genie_abs_complex, "a68_abs_complex"}, {genie_arg_complex, "a68_arg_complex"}, {genie_add_complex, "a68_add_complex"}, {genie_sub_complex, "a68_sub_complex"}, {genie_mul_complex, "a68_mul_complex"}, {genie_div_complex, "a68_div_complex"}, {genie_eq_complex, "a68_eq_complex"}, {genie_ne_complex, "a68_ne_complex"}, {NO_GPROC, NO_TEXT} }; TRANSLATION functions_nocheck[] = { {genie_sqrt_real, "sqrt"}, {genie_curt_real, "cbrt"}, {genie_exp_real, "a68_exp"}, {genie_ln_real, "log"}, {genie_log_real, "log10"}, {genie_sin_real, "sin"}, {genie_cos_real, "cos"}, {genie_tan_real, "tan"}, {genie_asin_real, "asin"}, {genie_acos_real, "acos"}, {genie_atan_real, "atan"}, {genie_sinh_real, "sinh"}, {genie_cosh_real, "cosh"}, {genie_tanh_real, "tanh"}, {genie_erfc_real, "erfc"}, {genie_erf_real, "erf"}, {genie_gamma_real, "tgamma"}, {genie_ln_gamma_real, "lgamma"}, {genie_sindg_real, "a68_sindg"}, {genie_cosdg_real, "a68_cosdg"}, {genie_tandg_real, "a68_tandg"}, {genie_asindg_real, "a68_asindg"}, {genie_acosdg_real, "a68_acosdg"}, {genie_atandg_real, "a68_atandg"}, {genie_sqrt_complex, "a68_sqrt_complex"}, {genie_exp_complex, "a68_exp_complex"}, {genie_ln_complex, "a68_ln_complex"}, {genie_sin_complex, "a68_sin_complex"}, {genie_cos_complex, "a68_cos_complex"}, {genie_tan_complex, "a68_tan_complex"}, {genie_asin_complex, "a68_asin_complex"}, {genie_acos_complex, "a68_acos_complex"}, {genie_atan_complex, "a68_atan_complex"}, {genie_sinh_complex, "a68_sinh_complex"}, {genie_cosh_complex, "a68_cosh_complex"}, {genie_tanh_complex, "a68_tanh_complex"}, {genie_asinh_complex, "a68_asinh_complex"}, {genie_acosh_complex, "a68_acosh_complex"}, {genie_atanh_complex, "a68_atanh_complex"}, {genie_asinh_real, "a68_asinh"}, {genie_acosh_real, "a68_acosh"}, {genie_atanh_real, "a68_atanh"}, {genie_inverfc_real, "a68_inverfc"}, {genie_inverf_real, "a68_inverf"}, {NO_GPROC, NO_TEXT} }; TRANSLATION functions_check[] = { {genie_sqrt_real, "sqrt"}, {genie_curt_real, "cbrt"}, {genie_exp_real, "a68_exp"}, {genie_ln_real, "log"}, {genie_log_real, "log10"}, {genie_sin_real, "sin"}, {genie_cos_real, "cos"}, {genie_tan_real, "tan"}, {genie_asin_real, "asin"}, {genie_acos_real, "acos"}, {genie_atan_real, "atan"}, {genie_sinh_real, "sinh"}, {genie_cosh_real, "cosh"}, {genie_tanh_real, "tanh"}, {genie_erfc_real, "erfc"}, {genie_erf_real, "erf"}, {genie_gamma_real, "tgamma"}, {genie_ln_gamma_real, "lgamma"}, {genie_sindg_real, "a68_sindg"}, {genie_cosdg_real, "a68_cosdg"}, {genie_tandg_real, "a68_tandg"}, {genie_asindg_real, "a68_asindg"}, {genie_acosdg_real, "a68_acosdg"}, {genie_atandg_real, "a68_atandg"}, {genie_asinh_real, "a68_asinh"}, {genie_acosh_real, "a68_acosh"}, {genie_atanh_real, "a68_atanh"}, {genie_inverfc_real, "a68_inverfc"}, {genie_inverf_real, "a68_inverf"}, {NO_GPROC, NO_TEXT} }; 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"}, #if (A68_LEVEL >= 3) {genie_bits_lengths, "2"}, #else {genie_bits_lengths, "3"}, #endif {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_long_mp_int_width, "LONG_LONG_INT_WIDTH"}, {genie_real_width, "REAL_WIDTH"}, {genie_long_real_width, "LONG_REAL_WIDTH"}, {genie_long_mp_real_width, "LONG_LONG_REAL_WIDTH"}, {genie_exp_width, "EXP_WIDTH"}, {genie_long_exp_width, "LONG_EXP_WIDTH"}, {genie_long_mp_exp_width, "LONG_LONG_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, "REAL_MAX"}, {genie_min_real, "REAL_MIN"}, {genie_null_char, "NULL_CHAR"}, {genie_small_real, "REAL_EPSILON"}, {genie_pi, "A68_PI"}, {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} }; algol68g-3.1.2/src/a68g/transput.c0000644000175000017500000042220214361065320013443 00000000000000//! @file transput.c //! @author J. Marcel van der Veer // //! @section Copyright // // This file is part of Algol68G - an Algol 68 compiler-interpreter. // Copyright 2001-2023 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" #include "a68g-genie.h" #include "a68g-prelude.h" #include "a68g-mp.h" #include "a68g-double.h" #include "a68g-transput.h" // 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. // 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 :-) //! @brief Init a file entry. void init_file_entry (int k) { if (k >= 0 && k < MAX_OPEN_FILES) { FILE_ENTRY *fe = &(A68 (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. 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 = &(A68 (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, M_C_STRING, len); BLOCK_GC_HANDLE (&(IDF (fe))); bufcpy (DEREF (char, &IDF (fe)), idf, len); return k; } } diagnostic (A68_RUNTIME_ERROR, p, ERROR_TOO_MANY_OPEN_FILES); exit_genie (p, A68_RUNTIME_ERROR); return -1; } //! @brief Close file and delete temp file. void close_file_entry (NODE_T * p, int k) { if (k >= 0 && k < MAX_OPEN_FILES) { FILE_ENTRY *fe = &(A68 (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 (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. void free_file_entry (NODE_T * p, int k) { close_file_entry (p, k); if (k >= 0 && k < MAX_OPEN_FILES) { FILE_ENTRY *fe = &(A68 (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))), M_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 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), M_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_VALUE (p, A68_TRUE, A68_BOOL); return; } } PUSH_VALUE (p, A68_FALSE, A68_BOOL); } //! @brief PROC last char in string = (CHAR, REF INT, STRING) BOOL 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), M_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_VALUE (p, A68_TRUE, A68_BOOL); return; } } PUSH_VALUE (p, A68_FALSE, A68_BOOL); } //! @brief PROC string in string = (STRING, REF INT, STRING) BOOL 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), M_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_VALUE (p, A68_TRUE, A68_BOOL); } else { PUSH_VALUE (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 gc'ed. If it is too small, we give up on // it and make a larger one. A68_REF ref_transput_buffer[MAX_TRANSPUT_BUFFER]; //! @brief Set max number of chars in a transput buffer. 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. void set_transput_buffer_index (int n, int cindex) { A68_INT *k = (A68_INT *) (ADDRESS (&ref_transput_buffer[n]) + SIZE (M_INT)); STATUS (k) = INIT_MASK; VALUE (k) = cindex; } //! @brief Get max number of chars in a transput buffer. 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. int get_transput_buffer_index (int n) { A68_INT *k = (A68_INT *) (ADDRESS (&ref_transput_buffer[n]) + SIZE (M_INT)); return VALUE (k); } //! @brief Get char[] from transput buffer. char *get_transput_buffer (int n) { return (char *) (ADDRESS (&ref_transput_buffer[n]) + 2 * SIZE (M_INT)); } //! @brief Mark transput buffer as no longer in use. void unblock_transput_buffer (int n) { set_transput_buffer_index (n, -1); } //! @brief Find first unused transput buffer (for opening a file). 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 (A68_RUNTIME_ERROR, p, ERROR_TOO_MANY_OPEN_FILES); exit_genie (p, A68_RUNTIME_ERROR); return -1; } //! @brief Empty contents of transput buffer. 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. void init_transput_buffers (NODE_T * p) { int k; for (k = 0; k < MAX_TRANSPUT_BUFFER; k++) { ref_transput_buffer[k] = heap_generator (p, M_ROWS, 2 * SIZE (M_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. void enlarge_transput_buffer (NODE_T * p, int k, int size) { int n = 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, M_ROWS, 2 * SIZE (M_INT) + size); BLOCK_GC_HANDLE (&ref_transput_buffer[k]); set_transput_buffer_size (k, size); set_transput_buffer_index (k, n); 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. void plusab_transput_buffer (NODE_T * p, int k, char ch) { char *sb = get_transput_buffer (k); int size = get_transput_buffer_size (k); int n = get_transput_buffer_index (k); if (n == size - 2) { enlarge_transput_buffer (p, k, 10 * size); plusab_transput_buffer (p, k, ch); } else { sb[n] = ch; sb[n + 1] = NULL_CHAR; set_transput_buffer_index (k, n + 1); } } //! @brief Add char to transput buffer at the head; if the buffer is full, make it larger. void plusto_transput_buffer (NODE_T * p, char ch, int k) { char *sb = get_transput_buffer (k); int size = get_transput_buffer_size (k); int n = get_transput_buffer_index (k); if (n == size - 2) { enlarge_transput_buffer (p, k, 10 * size); plusto_transput_buffer (p, ch, k); } else { MOVE (&sb[1], &sb[0], (unt) size); sb[0] = ch; sb[n + 1] = NULL_CHAR; set_transput_buffer_index (k, n + 1); } } //! @brief Add chars to transput buffer. void add_chars_transput_buffer (NODE_T * p, int k, int N, char *ch) { int j; for (j = 0; j < N; j++) { plusab_transput_buffer (p, k, ch[j]); } } //! @brief Add char[] to transput buffer. void add_string_transput_buffer (NODE_T * p, int k, char *ch) { for (; ch[0] != NULL_CHAR; ch++) { plusab_transput_buffer (p, k, ch[0]); } } //! @brief Add A68 string to transput buffer. 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), M_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), M_CHAR); plusab_transput_buffer (p, k, (char) VALUE (ch)); } } } //! @brief Pop A68 string and add to buffer. 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. char pop_char_transput_buffer (int k) { char *sb = get_transput_buffer (k); int n = get_transput_buffer_index (k); if (n <= 0) { return NULL_CHAR; } else { char ch = sb[0]; MOVE (&sb[0], &sb[1], n); set_transput_buffer_index (k, n - 1); return ch; } } //! @brief Add C string to A68 string. void add_c_string_to_a_string (NODE_T * p, A68_REF ref_str, char *s) { 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 (s); // left part. CHECK_REF (p, ref_str, M_REF_STRING); a = *DEREF (A68_REF, &ref_str); CHECK_INIT (p, INITIALISED (&a), M_STRING); GET_DESCRIPTOR (a_1, t_1, &a); l_1 = ROW_SIZE (t_1); // Sum string. c = heap_generator (p, M_STRING, DESCRIPTOR_SIZE (1)); d = heap_generator (p, M_STRING, (l_1 + l_2) * SIZE (M_CHAR)); // Calculate again since garbage collector might have moved data. // Todo: GC should not move volatile 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) = M_CHAR; ELEM_SIZE (a_3) = SIZE (M_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 (M_CHAR)); u += SIZE (M_CHAR); } for (v = 0; v < l_2; v++) { A68_CHAR ch; STATUS (&ch) = INIT_MASK; VALUE (&ch) = s[v]; MOVE ((BYTE_T *) & b_3[u], (BYTE_T *) & ch, SIZE (M_CHAR)); u += SIZE (M_CHAR); } *DEREF (A68_REF, &ref_str) = c; } //! @brief Purge buffer 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 && A68 (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. char *stack_string (NODE_T * p, int size) { char *new_str = (char *) STACK_TOP; INCREMENT_STACK_POINTER (p, size); if (A68_SP > A68 (expr_stack_limit)) { diagnostic (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 void genie_stand_in (NODE_T * p) { PUSH_REF (p, A68 (stand_in)); } //! @brief REF FILE standout void genie_stand_out (NODE_T * p) { PUSH_REF (p, A68 (stand_out)); } //! @brief REF FILE standback void genie_stand_back (NODE_T * p) { PUSH_REF (p, A68 (stand_back)); } //! @brief REF FILE standerror void genie_stand_error (NODE_T * p) { PUSH_REF (p, A68 (stand_error)); } //! @brief CHAR error char void genie_error_char (NODE_T * p) { PUSH_VALUE (p, ERROR_CHAR, A68_CHAR); } //! @brief CHAR exp char void genie_exp_char (NODE_T * p) { PUSH_VALUE (p, EXPONENT_CHAR, A68_CHAR); } //! @brief CHAR flip char void genie_flip_char (NODE_T * p) { PUSH_VALUE (p, FLIP_CHAR, A68_CHAR); } //! @brief CHAR flop char void genie_flop_char (NODE_T * p) { PUSH_VALUE (p, FLOP_CHAR, A68_CHAR); } //! @brief CHAR null char void genie_null_char (NODE_T * p) { PUSH_VALUE (p, NULL_CHAR, A68_CHAR); } //! @brief CHAR blank void genie_blank_char (NODE_T * p) { PUSH_VALUE (p, BLANK_CHAR, A68_CHAR); } //! @brief CHAR newline char void genie_newline_char (NODE_T * p) { PUSH_VALUE (p, NEWLINE_CHAR, A68_CHAR); } //! @brief CHAR formfeed char void genie_formfeed_char (NODE_T * p) { PUSH_VALUE (p, FORMFEED_CHAR, A68_CHAR); } //! @brief CHAR tab char void genie_tab_char (NODE_T * p) { PUSH_VALUE (p, TAB_CHAR, A68_CHAR); } //! @brief CHANNEL standin channel void genie_stand_in_channel (NODE_T * p) { PUSH_OBJECT (p, A68 (stand_in_channel), A68_CHANNEL); } //! @brief CHANNEL standout channel void genie_stand_out_channel (NODE_T * p) { PUSH_OBJECT (p, A68 (stand_out_channel), A68_CHANNEL); } //! @brief CHANNEL stand draw channel void genie_stand_draw_channel (NODE_T * p) { PUSH_OBJECT (p, A68 (stand_draw_channel), A68_CHANNEL); } //! @brief CHANNEL standback channel void genie_stand_back_channel (NODE_T * p) { PUSH_OBJECT (p, A68 (stand_back_channel), A68_CHANNEL); } //! @brief CHANNEL standerror channel void genie_stand_error_channel (NODE_T * p) { PUSH_OBJECT (p, A68 (stand_error_channel), A68_CHANNEL); } //! @brief PROC STRING program idf void genie_program_idf (NODE_T * p) { PUSH_REF (p, c_to_a_string (p, FILE_SOURCE_NAME (&A68_JOB), DEFAULT_WIDTH)); } // FILE and CHANNEL initialisations. //! @brief Set_default_event_procedure. void set_default_event_procedure (A68_PROCEDURE * z) { STATUS (z) = INIT_MASK; NODE (&(BODY (z))) = NO_NODE; ENVIRON (z) = 0; } //! @brief Initialise channel. 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. 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. 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, M_REF_FILE, SIZE (M_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, M_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. void genie_init_transput (NODE_T * p) { init_transput_buffers (p); // Channels. init_channel (&(A68 (stand_in_channel)), A68_FALSE, A68_FALSE, A68_TRUE, A68_FALSE, A68_FALSE, A68_FALSE); init_channel (&(A68 (stand_out_channel)), A68_FALSE, A68_FALSE, A68_FALSE, A68_TRUE, A68_FALSE, A68_FALSE); init_channel (&(A68 (stand_back_channel)), A68_TRUE, A68_TRUE, A68_TRUE, A68_TRUE, A68_TRUE, A68_FALSE); init_channel (&(A68 (stand_error_channel)), A68_FALSE, A68_FALSE, A68_FALSE, A68_TRUE, A68_FALSE, A68_FALSE); init_channel (&(A68 (associate_channel)), A68_TRUE, A68_TRUE, A68_TRUE, A68_TRUE, A68_FALSE, A68_FALSE); init_channel (&(A68 (skip_channel)), A68_FALSE, A68_FALSE, A68_FALSE, A68_FALSE, A68_FALSE, A68_FALSE); #if defined (HAVE_GNU_PLOTUTILS) init_channel (&(A68 (stand_draw_channel)), A68_FALSE, A68_FALSE, A68_FALSE, A68_FALSE, A68_FALSE, A68_TRUE); #else init_channel (&(A68 (stand_draw_channel)), A68_FALSE, A68_FALSE, A68_FALSE, A68_FALSE, A68_FALSE, A68_TRUE); #endif // Files. init_file (p, &(A68 (stand_in)), A68 (stand_in_channel), STDIN_FILENO, A68_TRUE, A68_FALSE, A68_TRUE, "A68_STANDIN"); init_file (p, &(A68 (stand_out)), A68 (stand_out_channel), STDOUT_FILENO, A68_FALSE, A68_TRUE, A68_TRUE, "A68_STANDOUT"); init_file (p, &(A68 (stand_back)), A68 (stand_back_channel), A68_NO_FILENO, A68_FALSE, A68_FALSE, A68_FALSE, NO_TEXT); init_file (p, &(A68 (stand_error)), A68 (stand_error_channel), STDERR_FILENO, A68_FALSE, A68_TRUE, A68_TRUE, "A68_STANDERROR"); init_file (p, &(A68 (skip_file)), A68 (skip_channel), A68_NO_FILENO, A68_FALSE, A68_FALSE, A68_FALSE, NO_TEXT); } //! @brief PROC (REF FILE) STRING idf void genie_idf (NODE_T * p) { A68_REF ref_file, ref_filename; char *filename; POP_REF (p, &ref_file); CHECK_REF (p, ref_file, M_REF_FILE); ref_file = *(A68_REF *) STACK_TOP; ref_filename = IDENTIFICATION (FILE_DEREF (&ref_file)); CHECK_REF (p, ref_filename, M_ROWS); filename = DEREF (char, &ref_filename); PUSH_REF (p, c_to_a_string (p, filename, DEFAULT_WIDTH)); } //! @brief PROC (REF FILE) STRING term void genie_term (NODE_T * p) { A68_REF ref_file, ref_term; char *term; POP_REF (p, &ref_file); CHECK_REF (p, ref_file, M_REF_FILE); ref_file = *(A68_REF *) STACK_TOP; ref_term = TERMINATOR (FILE_DEREF (&ref_file)); CHECK_REF (p, ref_term, M_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 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, M_REF_FILE); ref_file = *(A68_REF *) STACK_TOP; file = FILE_DEREF (&ref_file); // Don't check initialisation so we can "make term" before opening. size = a68_string_size (p, str); if (INITIALISED (&(TERMINATOR (file))) && !IS_NIL (TERMINATOR (file))) { UNBLOCK_GC_HANDLE (&(TERMINATOR (file))); } TERMINATOR (file) = heap_generator (p, M_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 void genie_put_possible (NODE_T * p) { A68_REF ref_file; A68_FILE *file; POP_REF (p, &ref_file); CHECK_REF (p, ref_file, M_REF_FILE); file = FILE_DEREF (&ref_file); CHECK_INIT (p, INITIALISED (file), M_FILE); PUSH_VALUE (p, PUT (&CHANNEL (file)), A68_BOOL); } //! @brief PROC (REF FILE) BOOL get possible void genie_get_possible (NODE_T * p) { A68_REF ref_file; A68_FILE *file; POP_REF (p, &ref_file); CHECK_REF (p, ref_file, M_REF_FILE); file = FILE_DEREF (&ref_file); CHECK_INIT (p, INITIALISED (file), M_FILE); PUSH_VALUE (p, GET (&CHANNEL (file)), A68_BOOL); } //! @brief PROC (REF FILE) BOOL bin possible void genie_bin_possible (NODE_T * p) { A68_REF ref_file; A68_FILE *file; POP_REF (p, &ref_file); CHECK_REF (p, ref_file, M_REF_FILE); file = FILE_DEREF (&ref_file); CHECK_INIT (p, INITIALISED (file), M_FILE); PUSH_VALUE (p, BIN (&CHANNEL (file)), A68_BOOL); } //! @brief PROC (REF FILE) BOOL set possible void genie_set_possible (NODE_T * p) { A68_REF ref_file; A68_FILE *file; POP_REF (p, &ref_file); CHECK_REF (p, ref_file, M_REF_FILE); file = FILE_DEREF (&ref_file); CHECK_INIT (p, INITIALISED (file), M_FILE); PUSH_VALUE (p, SET (&CHANNEL (file)), A68_BOOL); } //! @brief PROC (REF FILE) BOOL reidf possible void genie_reidf_possible (NODE_T * p) { A68_REF ref_file; A68_FILE *file; POP_REF (p, &ref_file); CHECK_REF (p, ref_file, M_REF_FILE); file = FILE_DEREF (&ref_file); CHECK_INIT (p, INITIALISED (file), M_FILE); PUSH_VALUE (p, A68_FALSE, A68_BOOL); } //! @brief PROC (REF FILE) BOOL reset possible void genie_reset_possible (NODE_T * p) { A68_REF ref_file; A68_FILE *file; POP_REF (p, &ref_file); CHECK_REF (p, ref_file, M_REF_FILE); file = FILE_DEREF (&ref_file); CHECK_INIT (p, INITIALISED (file), M_FILE); PUSH_VALUE (p, RESET (&CHANNEL (file)), A68_BOOL); } //! @brief PROC (REF FILE) BOOL compressible void genie_compressible (NODE_T * p) { A68_REF ref_file; A68_FILE *file; POP_REF (p, &ref_file); CHECK_REF (p, ref_file, M_REF_FILE); file = FILE_DEREF (&ref_file); CHECK_INIT (p, INITIALISED (file), M_FILE); PUSH_VALUE (p, COMPRESS (&CHANNEL (file)), A68_BOOL); } //! @brief PROC (REF FILE) BOOL draw possible void genie_draw_possible (NODE_T * p) { A68_REF ref_file; A68_FILE *file; POP_REF (p, &ref_file); CHECK_REF (p, ref_file, M_REF_FILE); file = FILE_DEREF (&ref_file); CHECK_INIT (p, INITIALISED (file), M_FILE); PUSH_VALUE (p, DRAW (&CHANNEL (file)), A68_BOOL); } //! @brief PROC (REF FILE, STRING, CHANNEL) INT open 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, M_REF_STRING); POP_REF (p, &ref_file); CHECK_REF (p, ref_file, M_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, M_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_VALUE (p, (S_ISREG (ST_MODE (&status)) != 0 ? 0 : 1), A68_INT); } else { PUSH_VALUE (p, 1, A68_INT); } errno = 0; } } //! @brief PROC (REF FILE, STRING, CHANNEL) INT establish 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, M_REF_STRING); POP_REF (p, &ref_file); CHECK_REF (p, ref_file, M_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 (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, M_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_VALUE (p, 0, A68_INT); } //! @brief PROC (REF FILE, CHANNEL) INT create 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, M_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_VALUE (p, 0, A68_INT); } //! @brief PROC (REF FILE, REF STRING) VOID associate 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, M_REF_STRING); POP_REF (p, &ref_file); CHECK_REF (p, ref_file, M_REF_FILE); if (IS_IN_HEAP (&ref_file) && !IS_IN_HEAP (&ref_string)) { diagnostic (A68_RUNTIME_ERROR, p, ERROR_SCOPE_DYNAMIC_1, M_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 (A68_RUNTIME_ERROR, p, ERROR_SCOPE_DYNAMIC_1, M_REF_STRING); exit_genie (p, A68_RUNTIME_ERROR); } } file = FILE_DEREF (&ref_file); STATUS (file) = INIT_MASK; FILE_ENTRY (file) = -1; CHANNEL (file) = A68 (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 void genie_close (NODE_T * p) { A68_REF ref_file; A68_FILE *file; POP_REF (p, &ref_file); CHECK_REF (p, ref_file, M_REF_FILE); file = FILE_DEREF (&ref_file); CHECK_INIT (p, INITIALISED (file), M_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 void genie_lock (NODE_T * p) { A68_REF ref_file; A68_FILE *file; POP_REF (p, &ref_file); CHECK_REF (p, ref_file, M_REF_FILE); file = FILE_DEREF (&ref_file); CHECK_INIT (p, INITIALISED (file), M_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 (BUILD_UNIX) errno = 0; ASSERT (fchmod (FD (file), (mode_t) 0x0) != -1); #endif if (FD (file) != A68_NO_FILENO && close (FD (file)) == -1) { diagnostic (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 void genie_erase (NODE_T * p) { A68_REF ref_file; A68_FILE *file; POP_REF (p, &ref_file); CHECK_REF (p, ref_file, M_REF_FILE); file = FILE_DEREF (&ref_file); CHECK_INIT (p, INITIALISED (file), M_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 (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))), M_ROWS); filename = DEREF (char, &IDENTIFICATION (file)); if (remove (filename) != 0) { diagnostic (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 void genie_backspace (NODE_T * p) { ADDR_T pop_sp = A68_SP; PUSH_VALUE (p, -1, A68_INT); genie_set (p); A68_SP = pop_sp; } //! @brief PROC (REF FILE, INT) INT set 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, M_REF_FILE); file = FILE_DEREF (&ref_file); CHECK_INIT (p, INITIALISED (file), M_FILE); if (!OPENED (file)) { diagnostic (A68_RUNTIME_ERROR, p, ERROR_FILE_NOT_OPEN); exit_genie (p, A68_RUNTIME_ERROR); } if (!SET (&CHANNEL (file))) { diagnostic (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 (A68_RUNTIME_ERROR, p, ERROR_FILE_ENDED); exit_genie (p, A68_RUNTIME_ERROR); } } PUSH_VALUE (p, STRPOS (file), A68_INT); } else if (FD (file) == A68_NO_FILENO) { diagnostic (A68_RUNTIME_ERROR, p, ERROR_FILE_RESET); exit_genie (p, A68_RUNTIME_ERROR); } else { errno = 0; __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 (A68_RUNTIME_ERROR, p, ERROR_FILE_ENDED); exit_genie (p, A68_RUNTIME_ERROR); } PUSH_VALUE (p, (int) lseek (FD (file), 0, SEEK_CUR), A68_INT); } else { res = lseek (FD (file), curpos, SEEK_SET); if (res == -1 || errno != 0) { diagnostic (A68_RUNTIME_ERROR, p, ERROR_FILE_SET); exit_genie (p, A68_RUNTIME_ERROR); } PUSH_VALUE (p, (int) res, A68_INT); } } } //! @brief PROC (REF FILE) VOID reset void genie_reset (NODE_T * p) { A68_REF ref_file; A68_FILE *file; POP_REF (p, &ref_file); CHECK_REF (p, ref_file, M_REF_FILE); file = FILE_DEREF (&ref_file); CHECK_INIT (p, INITIALISED (file), M_FILE); if (!OPENED (file)) { diagnostic (A68_RUNTIME_ERROR, p, ERROR_FILE_NOT_OPEN); exit_genie (p, A68_RUNTIME_ERROR); } if (!RESET (&CHANNEL (file))) { diagnostic (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 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, M_REF_FILE); file = FILE_DEREF (&ref_file); CHECK_INIT (p, INITIALISED (file), M_FILE); FILE_END_MENDED (file) = z; } //! @brief PROC (REF FILE, PROC (REF FILE) BOOL) VOID on page end 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, M_REF_FILE); file = FILE_DEREF (&ref_file); CHECK_INIT (p, INITIALISED (file), M_FILE); PAGE_END_MENDED (file) = z; } //! @brief PROC (REF FILE, PROC (REF FILE) BOOL) VOID on line end 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, M_REF_FILE); file = FILE_DEREF (&ref_file); CHECK_INIT (p, INITIALISED (file), M_FILE); LINE_END_MENDED (file) = z; } //! @brief PROC (REF FILE, PROC (REF FILE) BOOL) VOID on format end 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, M_REF_FILE); file = FILE_DEREF (&ref_file); CHECK_INIT (p, INITIALISED (file), M_FILE); FORMAT_END_MENDED (file) = z; } //! @brief PROC (REF FILE, PROC (REF FILE) BOOL) VOID on format error 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, M_REF_FILE); file = FILE_DEREF (&ref_file); CHECK_INIT (p, INITIALISED (file), M_FILE); FORMAT_ERROR_MENDED (file) = z; } //! @brief PROC (REF FILE, PROC (REF FILE) BOOL) VOID on value error 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, M_REF_FILE); file = FILE_DEREF (&ref_file); CHECK_INIT (p, INITIALISED (file), M_FILE); VALUE_ERROR_MENDED (file) = z; } //! @brief PROC (REF FILE, PROC (REF FILE) BOOL) VOID on open error 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, M_REF_FILE); file = FILE_DEREF (&ref_file); CHECK_INIT (p, INITIALISED (file), M_FILE); OPEN_ERROR_MENDED (file) = z; } //! @brief PROC (REF FILE, PROC (REF FILE) BOOL) VOID on transput error 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, M_REF_FILE); file = FILE_DEREF (&ref_file); CHECK_INIT (p, INITIALISED (file), M_FILE); TRANSPUT_ERROR_MENDED (file) = z; } //! @brief Invoke event routine. void on_event_handler (NODE_T * p, A68_PROCEDURE z, A68_REF ref_file) { if (NODE (&(BODY (&z))) == NO_NODE) { // Default procedure. PUSH_VALUE (p, A68_FALSE, A68_BOOL); } else { ADDR_T pop_sp = A68_SP, pop_fp = A68_FP; PUSH_REF (p, ref_file); genie_call_event_routine (p, M_PROC_REF_FILE_BOOL, &z, pop_sp, pop_fp); } } //! @brief Handle end-of-file event. 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 (A68_RUNTIME_ERROR, p, ERROR_FILE_ENDED); exit_genie (p, A68_RUNTIME_ERROR); } } //! @brief Handle file-open-error event. 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, M_REF_FILE); file = FILE_DEREF (&ref_file); CHECK_INIT (p, INITIALISED (file), M_FILE); if (!IS_NIL (IDENTIFICATION (file))) { filename = DEREF (char, &IDENTIFICATION (FILE_DEREF (&ref_file))); } else { filename = "(missing filename)"; } diagnostic (A68_RUNTIME_ERROR, p, ERROR_FILE_CANNOT_OPEN_FOR, filename, mode); exit_genie (p, A68_RUNTIME_ERROR); } } //! @brief Handle value error event. 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 (A68_RUNTIME_ERROR, p, ERROR_FILE_TRANSPUT, m); exit_genie (p, A68_RUNTIME_ERROR); } } } //! @brief Handle value_error event. 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 (A68_RUNTIME_ERROR, p, ERROR_FILE_TRANSPUT_SIGN, m); exit_genie (p, A68_RUNTIME_ERROR); } } } //! @brief Handle transput-error event. 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 (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. 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. void unchar_scanner (NODE_T * p, A68_FILE * f, char ch) { END_OF_FILE (f) = A68_FALSE; plusab_transput_buffer (p, TRANSPUT_BUFFER (f), ch); } //! @brief PROC (REF FILE) BOOL eof void genie_eof (NODE_T * p) { A68_REF ref_file; A68_FILE *file; POP_REF (p, &ref_file); CHECK_REF (p, ref_file, M_REF_FILE); file = FILE_DEREF (&ref_file); CHECK_INIT (p, INITIALISED (file), M_FILE); if (!OPENED (file)) { diagnostic (A68_RUNTIME_ERROR, p, ERROR_FILE_NOT_OPEN); exit_genie (p, A68_RUNTIME_ERROR); } if (DRAW_MOOD (file)) { diagnostic (A68_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "draw"); exit_genie (p, A68_RUNTIME_ERROR); } if (WRITE_MOOD (file)) { diagnostic (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_VALUE (p, (BOOL_T) ((ch == EOF_CHAR || END_OF_FILE (file)) ? A68_TRUE : A68_FALSE), A68_BOOL); unchar_scanner (p, file, (char) ch); } else { diagnostic (A68_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "undetermined"); exit_genie (p, A68_RUNTIME_ERROR); } } //! @brief PROC (REF FILE) BOOL eoln void genie_eoln (NODE_T * p) { A68_REF ref_file; A68_FILE *file; POP_REF (p, &ref_file); CHECK_REF (p, ref_file, M_REF_FILE); file = FILE_DEREF (&ref_file); CHECK_INIT (p, INITIALISED (file), M_FILE); if (!OPENED (file)) { diagnostic (A68_RUNTIME_ERROR, p, ERROR_FILE_NOT_OPEN); exit_genie (p, A68_RUNTIME_ERROR); } if (DRAW_MOOD (file)) { diagnostic (A68_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "draw"); exit_genie (p, A68_RUNTIME_ERROR); } if (WRITE_MOOD (file)) { diagnostic (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_VALUE (p, (BOOL_T) (ch == NEWLINE_CHAR ? A68_TRUE : A68_FALSE), A68_BOOL); unchar_scanner (p, file, (char) ch); } else { diagnostic (A68_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "undetermined"); exit_genie (p, A68_RUNTIME_ERROR); } } //! @brief PROC (REF FILE) VOID new line void genie_new_line (NODE_T * p) { A68_REF ref_file; A68_FILE *file; POP_REF (p, &ref_file); CHECK_REF (p, ref_file, M_REF_FILE); file = FILE_DEREF (&ref_file); CHECK_INIT (p, INITIALISED (file), M_FILE); if (!OPENED (file)) { diagnostic (A68_RUNTIME_ERROR, p, ERROR_FILE_NOT_OPEN); exit_genie (p, A68_RUNTIME_ERROR); } if (DRAW_MOOD (file)) { diagnostic (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 (A68_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "undetermined"); exit_genie (p, A68_RUNTIME_ERROR); } } //! @brief PROC (REF FILE) VOID new page void genie_new_page (NODE_T * p) { A68_REF ref_file; A68_FILE *file; POP_REF (p, &ref_file); CHECK_REF (p, ref_file, M_REF_FILE); file = FILE_DEREF (&ref_file); CHECK_INIT (p, INITIALISED (file), M_FILE); if (!OPENED (file)) { diagnostic (A68_RUNTIME_ERROR, p, ERROR_FILE_NOT_OPEN); exit_genie (p, A68_RUNTIME_ERROR); } if (DRAW_MOOD (file)) { diagnostic (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 (A68_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "undetermined"); exit_genie (p, A68_RUNTIME_ERROR); } } //! @brief PROC (REF FILE) VOID space void genie_space (NODE_T * p) { A68_REF ref_file; A68_FILE *file; POP_REF (p, &ref_file); CHECK_REF (p, ref_file, M_REF_FILE); file = FILE_DEREF (&ref_file); CHECK_INIT (p, INITIALISED (file), M_FILE); if (!OPENED (file)) { diagnostic (A68_RUNTIME_ERROR, p, ERROR_FILE_NOT_OPEN); exit_genie (p, A68_RUNTIME_ERROR); } if (DRAW_MOOD (file)) { diagnostic (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 (A68_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "undetermined"); exit_genie (p, A68_RUNTIME_ERROR); } } //! @brief Skip new-lines and form-feeds. 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 = A68_SP; unchar_scanner (p, f, (char) (*ch)); if (*ch == NEWLINE_CHAR) { on_event_handler (p, LINE_END_MENDED (f), ref_file); A68_SP = 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); A68_SP = 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. 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 == '-')) { plusab_transput_buffer (p, INPUT_BUFFER, (char) ch); ch = char_scanner (f); } while (ch != EOF_CHAR && IS_DIGIT (ch)) { plusab_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. 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 == '-')) { plusab_transput_buffer (p, INPUT_BUFFER, (char) ch); ch = char_scanner (f); } while (ch != EOF_CHAR && IS_DIGIT (ch)) { plusab_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) { plusab_transput_buffer (p, INPUT_BUFFER, (char) ch); ch = char_scanner (f); while (ch != EOF_CHAR && IS_DIGIT (ch)) { plusab_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)) { plusab_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 == '-')) { plusab_transput_buffer (p, INPUT_BUFFER, (char) ch); ch = char_scanner (f); } while (ch != EOF_CHAR && IS_DIGIT (ch)) { plusab_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. 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)) { plusab_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. 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) { plusab_transput_buffer (p, INPUT_BUFFER, (char) ch); } } //! @brief Scan a string from 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 = A68_SP; 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); } A68_SP = pop_sp; go_on = A68_FALSE; } else if (term != NO_TEXT && strchr (term, ch) != NO_TEXT) { go_on = A68_FALSE; unchar_scanner (p, f, (char) ch); } else { plusab_transput_buffer (p, INPUT_BUFFER, (char) ch); ch = char_scanner (f); } } } } //! @brief Make temp file name. BOOL_T a68_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/a68_", "./a68_", 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) (a68_unif_rand () * len); } while (cindex < 0 || cindex >= len); chars[0] = letters[cindex]; chars[1] = NULL_CHAR; bufcat (tfilename, chars, BUFFER_SIZE); } bufcat (tfilename, ".tmp", BUFFER_SIZE); errno = 0; 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. 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, __func__); CHECK_REF (p, ref_file, M_REF_FILE); file = FILE_DEREF (&ref_file); CHECK_INIT (p, INITIALISED (file), M_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 (!a68_mkstemp (tfilename, flags, permissions)) { diagnostic (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, M_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, M_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. void genie_call_proc_ref_file_void (NODE_T * p, A68_REF ref_file, A68_PROCEDURE z) { ADDR_T pop_sp = A68_SP, pop_fp = A68_FP; MOID_T *u = M_PROC_REF_FILE_VOID; PUSH_REF (p, ref_file); genie_call_procedure (p, MOID (&z), u, u, &z, pop_sp, pop_fp); A68_SP = pop_sp; // Voiding } // Unformatted transput. //! @brief Hexadecimal value of digit. 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 INT value of BITS denotation UNSIGNED_T bits_to_int (NODE_T * p, char *str) { int base = 0; UNSIGNED_T bits = 0; char *radix = NO_TEXT, *end = NO_TEXT; errno = 0; base = (int) a68_strtou (str, &radix, 10); if (radix != NO_TEXT && TO_UPPER (radix[0]) == TO_UPPER (RADIX_CHAR) && errno == 0) { if (base < 2 || base > 16) { diagnostic (A68_RUNTIME_ERROR, p, ERROR_INVALID_RADIX, base); exit_genie (p, A68_RUNTIME_ERROR); } bits = a68_strtou (&(radix[1]), &end, base); if (end != NO_TEXT && end[0] == NULL_CHAR && errno == 0) { return bits; } } diagnostic (A68_RUNTIME_ERROR, p, ERROR_IN_DENOTATION, M_BITS); exit_genie (p, A68_RUNTIME_ERROR); return 0; } //! @brief Convert string to required mode and store. BOOL_T genie_string_to_value_internal (NODE_T * p, MOID_T * m, char *a, BYTE_T * item) { errno = 0; // strto.. does not mind empty strings. if (strlen (a) == 0) { return A68_FALSE; } if (m == M_INT) { A68_INT *z = (A68_INT *) item; char *end; VALUE (z) = (INT_T) a68_strtoi (a, &end, 10); if (end[0] == NULL_CHAR && errno == 0) { STATUS (z) = INIT_MASK; return A68_TRUE; } else { return A68_FALSE; } } if (m == M_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; } } #if (A68_LEVEL >= 3) if (m == M_LONG_INT) { A68_LONG_INT *z = (A68_LONG_INT *) item; if (string_to_int_16 (p, z, a) == A68_FALSE) { return A68_FALSE; } STATUS (z) = INIT_MASK; return A68_TRUE; } if (m == M_LONG_REAL) { A68_LONG_REAL *z = (A68_LONG_REAL *) item; char *end; // VALUE (z).f = strtoflt128 (a, &end); VALUE (z).f = a68_strtoq (a, &end); MATH_RTE (p, errno != 0, M_LONG_REAL, ERROR_MATH); if (end[0] == NULL_CHAR && errno == 0) { STATUS (z) = INIT_MASK; return A68_TRUE; } else { return A68_FALSE; } } if (m == M_LONG_BITS) { A68_LONG_BITS *z = (A68_LONG_BITS *) item; int rc = A68_TRUE; QUAD_WORD_T b; set_lw (b, 0x0); if (a[0] == FLIP_CHAR || a[0] == FLOP_CHAR) { // [] BOOL denotation is "TTFFFFTFT ...". if (strlen (a) > (size_t) LONG_BITS_WIDTH) { errno = ERANGE; rc = A68_FALSE; } else { int j = (int) strlen (a) - 1, n = 1; UNSIGNED_T k = 0x1; for (; j >= 0; j--) { if (a[j] == FLIP_CHAR) { if (n <= LONG_BITS_WIDTH / 2) { LW (b) |= k; } else { HW (b) |= k; } } else if (a[j] != FLOP_CHAR) { rc = A68_FALSE; } k <<= 1; } } VALUE (z) = b; } else { // BITS denotation. VALUE (z) = double_strtou (p, a); } return rc; } #else if (m == M_LONG_BITS || m == M_LONG_LONG_BITS) { int digits = DIGITS (m); int status = A68_TRUE; ADDR_T pop_sp = A68_SP; 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 = lit_mp (p, 1, 0, digits); SET_MP_ZERO (z, 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. mp_strtou (p, z, a, m); } A68_SP = pop_sp; if (errno != 0 || status == A68_FALSE) { return A68_FALSE; } MP_STATUS (z) = (MP_T) INIT_MASK; return A68_TRUE; } #endif if (m == M_LONG_INT || m == M_LONG_LONG_INT) { int digits = DIGITS (m); MP_T *z = (MP_T *) item; if (strtomp (p, z, a, digits) == NaN_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; } if (m == M_LONG_REAL || m == M_LONG_LONG_REAL) { int digits = DIGITS (m); MP_T *z = (MP_T *) item; if (strtomp (p, z, a, digits) == NaN_MP) { return A68_FALSE; } MP_STATUS (z) = (MP_T) INIT_MASK; return A68_TRUE; } if (m == M_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; } } if (m == M_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_T 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; } return A68_FALSE; } //! @brief Convert string in input buffer to value of required mode. 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); errno = 0; // end string, just in case. plusab_transput_buffer (p, INPUT_BUFFER, NULL_CHAR); if (mode == M_INT) { if (genie_string_to_value_internal (p, mode, str, item) == A68_FALSE) { value_error (p, mode, ref_file); } } else if (mode == M_LONG_INT || mode == M_LONG_LONG_INT) { if (genie_string_to_value_internal (p, mode, str, item) == A68_FALSE) { value_error (p, mode, ref_file); } } else if (mode == M_REAL) { if (genie_string_to_value_internal (p, mode, str, item) == A68_FALSE) { value_error (p, mode, ref_file); } } else if (mode == M_LONG_REAL || mode == M_LONG_LONG_REAL) { if (genie_string_to_value_internal (p, mode, str, item) == A68_FALSE) { value_error (p, mode, ref_file); } } else if (mode == M_BOOL) { if (genie_string_to_value_internal (p, mode, str, item) == A68_FALSE) { value_error (p, mode, ref_file); } } else if (mode == M_BITS) { if (genie_string_to_value_internal (p, mode, str, item) == A68_FALSE) { value_error (p, mode, ref_file); } } else if (mode == M_LONG_BITS || mode == M_LONG_LONG_BITS) { if (genie_string_to_value_internal (p, mode, str, item) == A68_FALSE) { value_error (p, mode, ref_file); } } else if (mode == M_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 == M_STRING) { A68_REF z; z = c_to_a_string (p, str, get_transput_buffer_index (INPUT_BUFFER) - 1); *(A68_REF *) item = z; } if (errno != 0) { transput_error (p, ref_file, mode); } } //! @brief Read object from 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); errno = 0; if (END_OF_FILE (f)) { end_of_file_error (p, ref_file); } if (mode == M_PROC_REF_FILE_VOID) { genie_call_proc_ref_file_void (p, ref_file, *(A68_PROCEDURE *) item); } else if (mode == M_FORMAT) { diagnostic (A68_RUNTIME_ERROR, p, ERROR_UNDEFINED_TRANSPUT, M_FORMAT); exit_genie (p, A68_RUNTIME_ERROR); } else if (mode == M_REF_SOUND) { read_sound (p, ref_file, DEREF (A68_SOUND, (A68_REF *) item)); } else if (IS_REF (mode)) { CHECK_REF (p, *(A68_REF *) item, mode); genie_read_standard (p, SUB (mode), ADDRESS ((A68_REF *) item), ref_file); } else if (mode == M_INT || mode == M_LONG_INT || mode == M_LONG_LONG_INT) { scan_integer (p, ref_file); genie_string_to_value (p, mode, item, ref_file); } else if (mode == M_REAL || mode == M_LONG_REAL || mode == M_LONG_LONG_REAL) { scan_real (p, ref_file); genie_string_to_value (p, mode, item, ref_file); } else if (mode == M_BOOL) { scan_char (p, ref_file); genie_string_to_value (p, mode, item, ref_file); } else if (mode == M_CHAR) { scan_char (p, ref_file); genie_string_to_value (p, mode, item, ref_file); } else if (mode == M_BITS || mode == M_LONG_BITS || mode == M_LONG_LONG_BITS) { scan_bits (p, ref_file); genie_string_to_value (p, mode, item, ref_file); } else if (mode == M_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_STRUCT (mode)) { 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_UNION (mode)) { A68_UNION *z = (A68_UNION *) item; if (!(STATUS (z) | INIT_MASK) || VALUE (z) == NULL) { diagnostic (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_ROW (mode) || IS_FLEX (mode)) { 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 a68_index = calculate_internal_index (tup, DIM (arr)); ADDR_T elem_addr = ROW_ELEMENT (arr, a68_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 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. void open_for_reading (NODE_T * p, A68_REF ref_file) { A68_FILE *file = FILE_DEREF (&ref_file); if (!OPENED (file)) { diagnostic (A68_RUNTIME_ERROR, p, ERROR_FILE_NOT_OPEN); exit_genie (p, A68_RUNTIME_ERROR); } if (DRAW_MOOD (file)) { diagnostic (A68_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "draw"); exit_genie (p, A68_RUNTIME_ERROR); } if (WRITE_MOOD (file)) { diagnostic (A68_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "write"); exit_genie (p, A68_RUNTIME_ERROR); } if (!GET (&CHANNEL (file))) { diagnostic (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 (A68_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "binary"); exit_genie (p, A68_RUNTIME_ERROR); } } //! @brief PROC (REF FILE, [] SIMPLIN) VOID get 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, M_ROW_SIMPLIN); GET_DESCRIPTOR (arr, tup, &row); elems = ROW_SIZE (tup); POP_REF (p, &ref_file); CHECK_REF (p, ref_file, M_REF_FILE); file = FILE_DEREF (&ref_file); CHECK_INIT (p, INITIALISED (file), M_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]; genie_read_standard (p, mode, item, ref_file); elem_index += SIZE (M_SIMPLIN); } } //! @brief Convert value to string. void genie_value_to_string (NODE_T * p, MOID_T * moid, BYTE_T * item, int mod) { if (moid == M_INT) { A68_INT *z = (A68_INT *) item; PUSH_UNION (p, M_INT); PUSH_VALUE (p, VALUE (z), A68_INT); INCREMENT_STACK_POINTER (p, SIZE (M_NUMBER) - (A68_UNION_SIZE + SIZE (M_INT))); if (mod == FORMAT_ITEM_G) { PUSH_VALUE (p, INT_WIDTH + 1, A68_INT); genie_whole (p); } else if (mod == FORMAT_ITEM_H) { PUSH_VALUE (p, REAL_WIDTH + EXP_WIDTH + 4, A68_INT); PUSH_VALUE (p, REAL_WIDTH - 1, A68_INT); PUSH_VALUE (p, EXP_WIDTH + 1, A68_INT); PUSH_VALUE (p, 3, A68_INT); genie_real (p); } return; } #if (A68_LEVEL >= 3) if (moid == M_LONG_INT) { A68_LONG_INT *z = (A68_LONG_INT *) item; PUSH_UNION (p, M_LONG_INT); PUSH (p, z, SIZE (M_LONG_INT)); INCREMENT_STACK_POINTER (p, SIZE (M_NUMBER) - (A68_UNION_SIZE + SIZE (M_LONG_INT))); if (mod == FORMAT_ITEM_G) { PUSH_VALUE (p, LONG_WIDTH + 1, A68_INT); genie_whole (p); } else if (mod == FORMAT_ITEM_H) { PUSH_VALUE (p, LONG_REAL_WIDTH + LONG_EXP_WIDTH + 4, A68_INT); PUSH_VALUE (p, LONG_REAL_WIDTH - 1, A68_INT); PUSH_VALUE (p, LONG_EXP_WIDTH + 1, A68_INT); PUSH_VALUE (p, 3, A68_INT); genie_real (p); } return; } if (moid == M_LONG_REAL) { A68_LONG_REAL *z = (A68_LONG_REAL *) item; PUSH_UNION (p, M_LONG_REAL); PUSH_VALUE (p, VALUE (z), A68_LONG_REAL); INCREMENT_STACK_POINTER (p, SIZE (M_NUMBER) - (A68_UNION_SIZE + SIZE (M_LONG_REAL))); PUSH_VALUE (p, LONG_REAL_WIDTH + LONG_EXP_WIDTH + 4, A68_INT); PUSH_VALUE (p, LONG_REAL_WIDTH - 1, A68_INT); PUSH_VALUE (p, LONG_EXP_WIDTH + 1, A68_INT); if (mod == FORMAT_ITEM_G) { genie_float (p); } else if (mod == FORMAT_ITEM_H) { PUSH_VALUE (p, 3, A68_INT); genie_real (p); } return; } if (moid == M_LONG_BITS) { A68_LONG_BITS *z = (A68_LONG_BITS *) item; char *s = stack_string (p, 8 + LONG_BITS_WIDTH); int n = 0, w; for (w = 0; w <= 1; w++) { UNSIGNED_T bit = D_SIGN; int j; for (j = 0; j < BITS_WIDTH; j++) { if (w == 0) { s[n] = (char) ((HW (VALUE (z)) & bit) ? FLIP_CHAR : FLOP_CHAR); } else { s[n] = (char) ((LW (VALUE (z)) & bit) ? FLIP_CHAR : FLOP_CHAR); } bit >>= 1; n++; } } s[n] = NULL_CHAR; return; } #else if (moid == M_LONG_BITS || moid == M_LONG_LONG_BITS) { int bits = get_mp_bits_width (moid), word = get_mp_bits_words (moid); int pos = bits; char *str = stack_string (p, 8 + bits); ADDR_T pop_sp = A68_SP; unt *row = stack_mp_bits (p, (MP_T *) item, moid); str[pos--] = NULL_CHAR; while (pos >= 0) { unt bit = 0x1; int j; for (j = 0; j < MP_BITS_BITS && pos >= 0; j++) { str[pos--] = (char) ((row[word - 1] & bit) ? FLIP_CHAR : FLOP_CHAR); bit <<= 1; } word--; } A68_SP = pop_sp; return; } #endif if (moid == M_LONG_INT) { MP_T *z = (MP_T *) item; PUSH_UNION (p, M_LONG_INT); PUSH (p, z, SIZE (M_LONG_INT)); INCREMENT_STACK_POINTER (p, SIZE (M_NUMBER) - (A68_UNION_SIZE + SIZE (M_LONG_INT))); if (mod == FORMAT_ITEM_G) { PUSH_VALUE (p, LONG_WIDTH + 1, A68_INT); genie_whole (p); } else if (mod == FORMAT_ITEM_H) { PUSH_VALUE (p, LONG_REAL_WIDTH + LONG_EXP_WIDTH + 4, A68_INT); PUSH_VALUE (p, LONG_REAL_WIDTH - 1, A68_INT); PUSH_VALUE (p, LONG_EXP_WIDTH + 1, A68_INT); PUSH_VALUE (p, 3, A68_INT); genie_real (p); } return; } if (moid == M_LONG_LONG_INT) { MP_T *z = (MP_T *) item; PUSH_UNION (p, M_LONG_LONG_INT); PUSH (p, z, SIZE (M_LONG_LONG_INT)); INCREMENT_STACK_POINTER (p, SIZE (M_NUMBER) - (A68_UNION_SIZE + SIZE (M_LONG_LONG_INT))); if (mod == FORMAT_ITEM_G) { PUSH_VALUE (p, LONG_LONG_WIDTH + 1, A68_INT); genie_whole (p); } else if (mod == FORMAT_ITEM_H) { PUSH_VALUE (p, LONG_LONG_REAL_WIDTH + LONG_LONG_EXP_WIDTH + 4, A68_INT); PUSH_VALUE (p, LONG_LONG_REAL_WIDTH - 1, A68_INT); PUSH_VALUE (p, LONG_LONG_EXP_WIDTH + 1, A68_INT); PUSH_VALUE (p, 3, A68_INT); genie_real (p); } return; } if (moid == M_REAL) { A68_REAL *z = (A68_REAL *) item; PUSH_UNION (p, M_REAL); PUSH_VALUE (p, VALUE (z), A68_REAL); INCREMENT_STACK_POINTER (p, SIZE (M_NUMBER) - (A68_UNION_SIZE + SIZE (M_REAL))); PUSH_VALUE (p, REAL_WIDTH + EXP_WIDTH + 4, A68_INT); PUSH_VALUE (p, REAL_WIDTH - 1, A68_INT); PUSH_VALUE (p, EXP_WIDTH + 1, A68_INT); if (mod == FORMAT_ITEM_G) { genie_float (p); } else if (mod == FORMAT_ITEM_H) { PUSH_VALUE (p, 3, A68_INT); genie_real (p); } return; } if (moid == M_LONG_REAL) { MP_T *z = (MP_T *) item; PUSH_UNION (p, M_LONG_REAL); PUSH (p, z, (int) SIZE (M_LONG_REAL)); INCREMENT_STACK_POINTER (p, SIZE (M_NUMBER) - (A68_UNION_SIZE + SIZE (M_LONG_REAL))); PUSH_VALUE (p, LONG_REAL_WIDTH + LONG_EXP_WIDTH + 4, A68_INT); PUSH_VALUE (p, LONG_REAL_WIDTH - 1, A68_INT); PUSH_VALUE (p, LONG_EXP_WIDTH + 1, A68_INT); if (mod == FORMAT_ITEM_G) { genie_float (p); } else if (mod == FORMAT_ITEM_H) { PUSH_VALUE (p, 3, A68_INT); genie_real (p); } return; } if (moid == M_LONG_LONG_REAL) { MP_T *z = (MP_T *) item; PUSH_UNION (p, M_LONG_LONG_REAL); PUSH (p, z, (int) SIZE (M_LONG_LONG_REAL)); INCREMENT_STACK_POINTER (p, SIZE (M_NUMBER) - (A68_UNION_SIZE + SIZE (M_LONG_LONG_REAL))); PUSH_VALUE (p, LONG_LONG_REAL_WIDTH + LONG_LONG_EXP_WIDTH + 4, A68_INT); PUSH_VALUE (p, LONG_LONG_REAL_WIDTH - 1, A68_INT); PUSH_VALUE (p, LONG_LONG_EXP_WIDTH + 1, A68_INT); if (mod == FORMAT_ITEM_G) { genie_float (p); } else if (mod == FORMAT_ITEM_H) { PUSH_VALUE (p, 3, A68_INT); genie_real (p); } return; } if (moid == M_BITS) { A68_BITS *z = (A68_BITS *) item; char *str = stack_string (p, 8 + BITS_WIDTH); UNSIGNED_T 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; return; } } //! @brief Print object to file. void genie_write_standard (NODE_T * p, MOID_T * mode, BYTE_T * item, A68_REF ref_file) { errno = 0; ABEND (mode == NO_MOID, ERROR_INTERNAL_CONSISTENCY, __func__); if (mode == M_PROC_REF_FILE_VOID) { genie_call_proc_ref_file_void (p, ref_file, *(A68_PROCEDURE *) item); } else if (mode == M_FORMAT) { diagnostic (A68_RUNTIME_ERROR, p, ERROR_UNDEFINED_TRANSPUT, M_FORMAT); exit_genie (p, A68_RUNTIME_ERROR); } else if (mode == M_SOUND) { write_sound (p, ref_file, (A68_SOUND *) item); } else if (mode == M_INT || mode == M_LONG_INT || mode == M_LONG_LONG_INT) { genie_value_to_string (p, mode, item, FORMAT_ITEM_G); add_string_from_stack_transput_buffer (p, UNFORMATTED_BUFFER); } else if (mode == M_REAL || mode == M_LONG_REAL || mode == M_LONG_LONG_REAL) { genie_value_to_string (p, mode, item, FORMAT_ITEM_G); add_string_from_stack_transput_buffer (p, UNFORMATTED_BUFFER); } else if (mode == M_BOOL) { A68_BOOL *z = (A68_BOOL *) item; char flipflop = (char) (VALUE (z) == A68_TRUE ? FLIP_CHAR : FLOP_CHAR); plusab_transput_buffer (p, UNFORMATTED_BUFFER, flipflop); } else if (mode == M_CHAR) { A68_CHAR *ch = (A68_CHAR *) item; plusab_transput_buffer (p, UNFORMATTED_BUFFER, (char) VALUE (ch)); } else if (mode == M_BITS || mode == M_LONG_BITS || mode == M_LONG_LONG_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 == M_ROW_CHAR || mode == M_STRING) { // Handle these separately since this is faster than straightening. add_a_string_transput_buffer (p, UNFORMATTED_BUFFER, item); } else if (IS_UNION (mode)) { A68_UNION *z = (A68_UNION *) item; genie_write_standard (p, (MOID_T *) (VALUE (z)), &item[A68_UNION_SIZE], ref_file); } else if (IS_STRUCT (mode)) { 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_ROW (mode) || IS_FLEX (mode)) { MOID_T *deflexed = DEFLEX (mode); A68_ARRAY *arr; A68_TUPLE *tup; CHECK_INIT (p, INITIALISED ((A68_REF *) item), M_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 a68_index = calculate_internal_index (tup, DIM (arr)); ADDR_T elem_addr = ROW_ELEMENT (arr, a68_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), ERROR_ACTION, error_specification ()); transput_error (p, ref_file, mode); } } //! @brief PROC ([] SIMPLOUT) VOID print, write 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. void open_for_writing (NODE_T * p, A68_REF ref_file) { A68_FILE *file = FILE_DEREF (&ref_file); if (!OPENED (file)) { diagnostic (A68_RUNTIME_ERROR, p, ERROR_FILE_NOT_OPEN); exit_genie (p, A68_RUNTIME_ERROR); } if (DRAW_MOOD (file)) { diagnostic (A68_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "draw"); exit_genie (p, A68_RUNTIME_ERROR); } if (READ_MOOD (file)) { diagnostic (A68_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "read"); exit_genie (p, A68_RUNTIME_ERROR); } if (!PUT (&CHANNEL (file))) { diagnostic (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 (A68_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "binary"); exit_genie (p, A68_RUNTIME_ERROR); } } //! @brief PROC (REF FILE, [] SIMPLOUT) VOID put 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, M_ROW_SIMPLOUT); GET_DESCRIPTOR (arr, tup, &row); elems = ROW_SIZE (tup); POP_REF (p, &ref_file); CHECK_REF (p, ref_file, M_REF_FILE); file = FILE_DEREF (&ref_file); CHECK_INIT (p, INITIALISED (file), M_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]; reset_transput_buffer (UNFORMATTED_BUFFER); genie_write_standard (p, mode, item, ref_file); write_purge_buffer (p, ref_file, UNFORMATTED_BUFFER); elem_index += SIZE (M_SIMPLOUT); } } //! @brief Read object binary from file. void genie_read_bin_standard (NODE_T * p, MOID_T * mode, BYTE_T * item, A68_REF ref_file) { A68_FILE *f; CHECK_REF (p, ref_file, M_REF_FILE); f = FILE_DEREF (&ref_file); errno = 0; if (END_OF_FILE (f)) { end_of_file_error (p, ref_file); } if (mode == M_PROC_REF_FILE_VOID) { genie_call_proc_ref_file_void (p, ref_file, *(A68_PROCEDURE *) item); } else if (mode == M_FORMAT) { diagnostic (A68_RUNTIME_ERROR, p, ERROR_UNDEFINED_TRANSPUT, M_FORMAT); exit_genie (p, A68_RUNTIME_ERROR); } else if (mode == M_REF_SOUND) { read_sound (p, ref_file, (A68_SOUND *) ADDRESS ((A68_REF *) item)); } else if (IS_REF (mode)) { CHECK_REF (p, *(A68_REF *) item, mode); genie_read_bin_standard (p, SUB (mode), ADDRESS ((A68_REF *) item), ref_file); } else if (mode == M_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 == M_LONG_INT) { #if (A68_LEVEL >= 3) A68_LONG_INT *z = (A68_LONG_INT *) item; ASSERT (io_read (FD (f), &(VALUE (z)), sizeof (VALUE (z))) != -1); STATUS (z) = INIT_MASK; #else MP_T *z = (MP_T *) item; ASSERT (io_read (FD (f), z, (size_t) SIZE (mode)) != -1); MP_STATUS (z) = (MP_T) INIT_MASK; #endif } else if (mode == M_LONG_LONG_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 == M_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 == M_LONG_REAL) { #if (A68_LEVEL >= 3) A68_LONG_REAL *z = (A68_LONG_REAL *) item; ASSERT (io_read (FD (f), &(VALUE (z)), sizeof (VALUE (z))) != -1); STATUS (z) = INIT_MASK; #else MP_T *z = (MP_T *) item; ASSERT (io_read (FD (f), z, (size_t) SIZE (mode)) != -1); MP_STATUS (z) = (MP_T) INIT_MASK; #endif } else if (mode == M_LONG_LONG_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 == M_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 == M_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 == M_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 == M_LONG_BITS) { #if (A68_LEVEL >= 3) A68_LONG_BITS *z = (A68_LONG_BITS *) item; ASSERT (io_read (FD (f), &(VALUE (z)), sizeof (VALUE (z))) != -1); STATUS (z) = INIT_MASK; #else MP_T *z = (MP_T *) item; ASSERT (io_read (FD (f), z, (size_t) SIZE (mode)) != -1); MP_STATUS (z) = (MP_T) INIT_MASK; #endif } else if (mode == M_LONG_LONG_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 == M_ROW_CHAR || mode == M_STRING) { int len, k; ASSERT (io_read (FD (f), &(len), sizeof (len)) != -1); reset_transput_buffer (UNFORMATTED_BUFFER); for (k = 0; k < len; k++) { char ch; ASSERT (io_read (FD (f), &(ch), sizeof (char)) != -1); plusab_transput_buffer (p, UNFORMATTED_BUFFER, ch); } *(A68_REF *) item = c_to_a_string (p, get_transput_buffer (UNFORMATTED_BUFFER), DEFAULT_WIDTH); } else if (IS_UNION (mode)) { A68_UNION *z = (A68_UNION *) item; if (!(STATUS (z) | INIT_MASK) || VALUE (z) == NULL) { diagnostic (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_STRUCT (mode)) { 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_ROW (mode) || IS_FLEX (mode)) { MOID_T *deflexed = DEFLEX (mode); A68_ARRAY *arr; A68_TUPLE *tup; CHECK_INIT (p, INITIALISED ((A68_REF *) item), M_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 a68_index = calculate_internal_index (tup, DIM (arr)); ADDR_T elem_addr = ROW_ELEMENT (arr, a68_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 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 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, M_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, M_REF_FILE); file = FILE_DEREF (&ref_file); CHECK_INIT (p, INITIALISED (file), M_FILE); if (!OPENED (file)) { diagnostic (A68_RUNTIME_ERROR, p, ERROR_FILE_NOT_OPEN); exit_genie (p, A68_RUNTIME_ERROR); } if (DRAW_MOOD (file)) { diagnostic (A68_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "draw"); exit_genie (p, A68_RUNTIME_ERROR); } if (WRITE_MOOD (file)) { diagnostic (A68_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "write"); exit_genie (p, A68_RUNTIME_ERROR); } if (!GET (&CHANNEL (file))) { diagnostic (A68_RUNTIME_ERROR, p, ERROR_CHANNEL_DOES_NOT_ALLOW, "getting"); exit_genie (p, A68_RUNTIME_ERROR); } if (!BIN (&CHANNEL (file))) { diagnostic (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 (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]; genie_read_bin_standard (p, mode, item, ref_file); elem_index += SIZE (M_SIMPLIN); } } //! @brief Write object binary to file. void genie_write_bin_standard (NODE_T * p, MOID_T * mode, BYTE_T * item, A68_REF ref_file) { A68_FILE *f; CHECK_REF (p, ref_file, M_REF_FILE); f = FILE_DEREF (&ref_file); errno = 0; if (mode == M_PROC_REF_FILE_VOID) { genie_call_proc_ref_file_void (p, ref_file, *(A68_PROCEDURE *) item); } else if (mode == M_FORMAT) { diagnostic (A68_RUNTIME_ERROR, p, ERROR_UNDEFINED_TRANSPUT, M_FORMAT); exit_genie (p, A68_RUNTIME_ERROR); } else if (mode == M_SOUND) { write_sound (p, ref_file, (A68_SOUND *) item); } else if (mode == M_INT) { ASSERT (io_write (FD (f), &(VALUE ((A68_INT *) item)), sizeof (VALUE ((A68_INT *) item))) != -1); } else if (mode == M_LONG_INT) { #if (A68_LEVEL >= 3) ASSERT (io_write (FD (f), &(VALUE ((A68_LONG_INT *) item)), sizeof (VALUE ((A68_LONG_INT *) item))) != -1); #else ASSERT (io_write (FD (f), (MP_T *) item, (size_t) SIZE (mode)) != -1); #endif } else if (mode == M_LONG_LONG_INT) { ASSERT (io_write (FD (f), (MP_T *) item, (size_t) SIZE (mode)) != -1); } else if (mode == M_REAL) { ASSERT (io_write (FD (f), &(VALUE ((A68_REAL *) item)), sizeof (VALUE ((A68_REAL *) item))) != -1); } else if (mode == M_LONG_REAL) { #if (A68_LEVEL >= 3) ASSERT (io_write (FD (f), &(VALUE ((A68_LONG_REAL *) item)), sizeof (VALUE ((A68_LONG_REAL *) item))) != -1); #else ASSERT (io_write (FD (f), (MP_T *) item, (size_t) SIZE (mode)) != -1); #endif } else if (mode == M_LONG_LONG_REAL) { ASSERT (io_write (FD (f), (MP_T *) item, (size_t) SIZE (mode)) != -1); } else if (mode == M_BOOL) { ASSERT (io_write (FD (f), &(VALUE ((A68_BOOL *) item)), sizeof (VALUE ((A68_BOOL *) item))) != -1); } else if (mode == M_CHAR) { ASSERT (io_write (FD (f), &(VALUE ((A68_CHAR *) item)), sizeof (VALUE ((A68_CHAR *) item))) != -1); } else if (mode == M_BITS) { ASSERT (io_write (FD (f), &(VALUE ((A68_BITS *) item)), sizeof (VALUE ((A68_BITS *) item))) != -1); } else if (mode == M_LONG_BITS) { #if (A68_LEVEL >= 3) ASSERT (io_write (FD (f), &(VALUE ((A68_LONG_BITS *) item)), sizeof (VALUE ((A68_LONG_BITS *) item))) != -1); #else ASSERT (io_write (FD (f), (MP_T *) item, (size_t) SIZE (mode)) != -1); #endif } else if (mode == M_LONG_LONG_BITS) { ASSERT (io_write (FD (f), (MP_T *) item, (size_t) SIZE (mode)) != -1); } else if (mode == M_ROW_CHAR || mode == M_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_UNION (mode)) { A68_UNION *z = (A68_UNION *) item; genie_write_bin_standard (p, (MOID_T *) (VALUE (z)), &item[A68_UNION_SIZE], ref_file); } else if (IS_STRUCT (mode)) { 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_ROW (mode) || IS_FLEX (mode)) { MOID_T *deflexed = DEFLEX (mode); A68_ARRAY *arr; A68_TUPLE *tup; CHECK_INIT (p, INITIALISED ((A68_REF *) item), M_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 a68_index = calculate_internal_index (tup, DIM (arr)); ADDR_T elem_addr = ROW_ELEMENT (arr, a68_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 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 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, M_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, M_REF_FILE); file = FILE_DEREF (&ref_file); CHECK_INIT (p, INITIALISED (file), M_FILE); if (!OPENED (file)) { diagnostic (A68_RUNTIME_ERROR, p, ERROR_FILE_NOT_OPEN); exit_genie (p, A68_RUNTIME_ERROR); } if (DRAW_MOOD (file)) { diagnostic (A68_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "draw"); exit_genie (p, A68_RUNTIME_ERROR); } if (READ_MOOD (file)) { diagnostic (A68_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "read"); exit_genie (p, A68_RUNTIME_ERROR); } if (!PUT (&CHANNEL (file))) { diagnostic (A68_RUNTIME_ERROR, p, ERROR_CHANNEL_DOES_NOT_ALLOW, "putting"); exit_genie (p, A68_RUNTIME_ERROR); } if (!BIN (&CHANNEL (file))) { diagnostic (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 (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]; genie_write_bin_standard (p, mode, item, ref_file); elem_index += SIZE (M_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. 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. 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. char *plusto (char c, char *str) { MOVE (&str[1], &str[0], (unt) (strlen (str) + 1)); str[0] = c; return str; } //! @brief Add c to str, assuming that "str" is large enough. 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. 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. char digchar (int k) { char *s = "0123456789abcdefghijklmnopqrstuvwxyz"; if (k >= 0 && k < (int) strlen (s)) { return s[k]; } else { return ERROR_CHAR; } } //! @brief Formatted string for HEX_NUMBER. char *bits (NODE_T * p) { A68_INT width, base; MOID_T *mode; int length, radix; POP_OBJECT (p, &base, A68_INT); POP_OBJECT (p, &width, A68_INT); DECREMENT_STACK_POINTER (p, SIZE (M_HEX_NUMBER)); CHECK_INT_SHORTEN (p, VALUE (&base)); CHECK_INT_SHORTEN (p, VALUE (&width)); mode = (MOID_T *) (VALUE ((A68_UNION *) STACK_TOP)); length = ABS (VALUE (&width)); radix = ABS (VALUE (&base)); if (radix < 2 || radix > 16) { diagnostic (A68_RUNTIME_ERROR, p, ERROR_INVALID_RADIX, radix); exit_genie (p, A68_RUNTIME_ERROR); } reset_transput_buffer (EDIT_BUFFER); #if (A68_LEVEL <= 2) (void) mode; (void) length; (void) error_chars (get_transput_buffer (EDIT_BUFFER), VALUE (&width)); #else { BOOL_T rc = A68_TRUE; if (mode == M_BOOL) { UNSIGNED_T z = VALUE ((A68_BOOL *) (STACK_OFFSET (A68_UNION_SIZE))); rc = convert_radix (p, (UNSIGNED_T) z, radix, length); } else if (mode == M_CHAR) { INT_T z = VALUE ((A68_CHAR *) (STACK_OFFSET (A68_UNION_SIZE))); rc = convert_radix (p, (UNSIGNED_T) z, radix, length); } else if (mode == M_INT) { INT_T z = VALUE ((A68_INT *) (STACK_OFFSET (A68_UNION_SIZE))); rc = convert_radix (p, (UNSIGNED_T) z, radix, length); } else if (mode == M_REAL) { // A trick to copy a REAL into an unt without truncating UNSIGNED_T z; memcpy (&z, (void *) &VALUE ((A68_REAL *) (STACK_OFFSET (A68_UNION_SIZE))), 8); rc = convert_radix (p, z, radix, length); } else if (mode == M_BITS) { UNSIGNED_T z = VALUE ((A68_BITS *) (STACK_OFFSET (A68_UNION_SIZE))); rc = convert_radix (p, (UNSIGNED_T) z, radix, length); } else if (mode == M_LONG_INT) { QUAD_WORD_T z = VALUE ((A68_LONG_INT *) (STACK_OFFSET (A68_UNION_SIZE))); rc = convert_radix_double (p, z, radix, length); } else if (mode == M_LONG_REAL) { QUAD_WORD_T z = VALUE ((A68_LONG_REAL *) (STACK_OFFSET (A68_UNION_SIZE))); rc = convert_radix_double (p, z, radix, length); } else if (mode == M_LONG_BITS) { QUAD_WORD_T z = VALUE ((A68_LONG_BITS *) (STACK_OFFSET (A68_UNION_SIZE))); rc = convert_radix_double (p, z, radix, length); } if (rc == A68_FALSE) { errno = EDOM; PRELUDE_ERROR (A68_TRUE, p, ERROR_OUT_OF_BOUNDS, mode); } } #endif return get_transput_buffer (EDIT_BUFFER); } //! @brief Standard string for LONG INT. #if (A68_LEVEL >= 3) char *long_sub_whole_double (NODE_T * p, QUAD_WORD_T n, int width) { char *s = stack_string (p, 8 + width); int len = 0; QUAD_WORD_T ten; set_lw (ten, 10); s[0] = NULL_CHAR; do { if (len < width) { QUAD_WORD_T w; w = double_udiv (p, M_LONG_INT, n, ten, 1); (void) plusto (digchar (LW (w)), s); } len++; n = double_udiv (p, M_LONG_INT, n, ten, 0); } while (!D_ZERO (n)); if (len > width) { (void) error_chars (s, width); } return s; } #endif char *long_sub_whole (NODE_T * p, MP_T * m, int digits, int width) { char *s; int len = 0; s = stack_string (p, 8 + width); s[0] = NULL_CHAR; ADDR_T pop_sp = A68_SP; MP_T *n = nil_mp (p, digits); (void) move_mp (n, m, digits); do { if (len < width) { // Sic transit gloria mundi. int n_mod_10 = (MP_INT_T) 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); } A68_SP = pop_sp; return s; } //! @brief Standard string for INT. char *sub_whole (NODE_T * p, INT_T 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. char *whole (NODE_T * p) { int arg_sp; A68_INT width; MOID_T *mode; POP_OBJECT (p, &width, A68_INT); CHECK_INT_SHORTEN (p, VALUE (&width)); arg_sp = A68_SP; DECREMENT_STACK_POINTER (p, SIZE (M_NUMBER)); mode = (MOID_T *) (VALUE ((A68_UNION *) STACK_TOP)); if (mode == M_INT) { INT_T x = VALUE ((A68_INT *) (STACK_OFFSET (A68_UNION_SIZE))); INT_T n = ABS (x); int length = ABS (VALUE (&width)) - (x < 0 || VALUE (&width) > 0 ? 1 : 0); int size = (x < 0 ? 1 : (VALUE (&width) > 0 ? 1 : 0)); char *s; if (VALUE (&width) == 0) { INT_T 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 || 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; } #if (A68_LEVEL >= 3) if (mode == M_LONG_INT) { QUAD_WORD_T x = VALUE ((A68_LONG_INT *) (STACK_OFFSET (A68_UNION_SIZE))), n, ten; int length, size; char *s; set_lw (ten, 10); n = abs_int_16 (x); length = ABS (VALUE (&width)) - (D_NEG (x) || VALUE (&width) > 0 ? 1 : 0); size = (D_NEG (x) ? 1 : (VALUE (&width) > 0 ? 1 : 0)); if (VALUE (&width) == 0) { QUAD_WORD_T m = n; length = 0; while ((m = double_udiv (p, M_LONG_INT, m, ten, 0), length++, !D_ZERO (m))) { ; } } size += length; size = 8 + (size > VALUE (&width) ? size : VALUE (&width)); s = stack_string (p, size); bufcpy (s, long_sub_whole_double (p, n, length), size); if (length == 0 || strchr (s, ERROR_CHAR) != NO_TEXT) { (void) error_chars (s, VALUE (&width)); } else { if (D_NEG (x)) { (void) plusto ('-', s); } else if (VALUE (&width) > 0) { (void) plusto ('+', s); } if (VALUE (&width) != 0) { (void) leading_spaces (s, ABS (VALUE (&width))); } } return s; } #endif if (mode == M_LONG_INT || mode == M_LONG_LONG_INT) { int digits = DIGITS (mode); int length, size; char *s; MP_T *n = (MP_T *) (STACK_OFFSET (A68_UNION_SIZE)); BOOL_T ltz; A68_SP = arg_sp; // We keep the mp where it's at if (MP_EXPONENT (n) >= (MP_T) digits) { int max_length = (mode == M_LONG_INT ? LONG_INT_WIDTH : LONG_LONG_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 = nil_mp (p, digits); (void) 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 || 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; } if (mode == M_REAL || mode == M_LONG_REAL || mode == M_LONG_LONG_REAL) { INCREMENT_STACK_POINTER (p, SIZE (M_NUMBER)); PUSH_VALUE (p, VALUE (&width), A68_INT); PUSH_VALUE (p, 0, A68_INT); return fixed (p); } return NO_TEXT; } //! @brief Fetch next digit from LONG. char long_choose_dig (NODE_T * p, MP_T * y, int digits) { // Assuming positive "y". ADDR_T pop_sp = A68_SP; (void) mul_mp_digit (p, y, y, (MP_T) 10, digits); int c = MP_EXPONENT (y) == 0 ? (MP_INT_T) MP_DIGIT (y, 1) : 0; if (c > 9) { c = 9; } MP_T *t = lit_mp (p, c, 0, digits); (void) sub_mp (p, y, y, t, digits); // Reset the stack to prevent overflow, there may be many digits. A68_SP = pop_sp; return digchar (c); } //! @brief Standard string for LONG. char *long_sub_fixed (NODE_T * p, MP_T * x, int digits, int width, int after) { ADDR_T pop_sp = A68_SP; MP_T *y = nil_mp (p, digits); MP_T *s = nil_mp (p, digits); MP_T *t = nil_mp (p, digits); (void) ten_up_mp (p, t, -after, digits); (void) half_mp (p, t, t, digits); (void) add_mp (p, y, x, t, digits); int before = 0; // Not RR - argument reduction. while (MP_EXPONENT (y) > 1) { int k = (int) round (MP_EXPONENT (y) - 1); MP_EXPONENT (y) -= k; before += k * LOG_MP_RADIX; } // Follow RR again. SET_MP_ONE (s, digits); while ((sub_mp (p, t, y, s, digits), MP_DIGIT (t, 1) >= 0)) { before++; (void) div_mp_digit (p, y, y, (MP_T) 10, digits); } // Compose the number. if (before + after + (after > 0 ? 1 : 0) > width) { char *str = stack_string (p, width + 1); (void) error_chars (str, width); A68_SP = pop_sp; return str; } int strwid = 8 + before + after; char *str = stack_string (p, strwid); str[0] = NULL_CHAR; int j, len = 0; for (j = 0; j < before; j++) { char ch = (char) (len < LONG_LONG_REAL_WIDTH ? long_choose_dig (p, y, digits) : '0'); (void) string_plusab_char (str, ch, strwid); len++; } if (after > 0) { (void) string_plusab_char (str, POINT_CHAR, strwid); } for (j = 0; j < after; j++) { char ch = (char) (len < LONG_LONG_REAL_WIDTH ? long_choose_dig (p, y, digits) : '0'); (void) string_plusab_char (str, ch, strwid); len++; } if ((int) strlen (str) > width) { (void) error_chars (str, width); } A68_SP = pop_sp; return str; } #if (A68_LEVEL >= 3) //! @brief Fetch next digit from REAL. char choose_dig_double (DOUBLE_T * y) { // Assuming positive "y". int c = (int) (*y *= 10); if (c > 9) { c = 9; } *y -= c; return digchar (c); } #endif #if (A68_LEVEL >= 3) //! @brief Standard string for REAL. char *sub_fixed_double (NODE_T * p, DOUBLE_T x, int width, int after, int precision) { ABEND (x < 0, ERROR_INTERNAL_CONSISTENCY, __func__); // Round and scale. DOUBLE_T z = x + 0.5q * ten_up_double (-after); DOUBLE_T y = z; int before = 0; // Not according RR - argument reduction to avoid long division loop. if (z >= 1.0e10q) { // Arbitrary, log10 must be worthwhile. before = (int) floorq (log10q (z)) - 1; z /= ten_up_double (before); } // Follow RR again. while (z >= 1.0q) { before++; z /= 10.0q; } // Scale number. y /= ten_up_double (before); // Put digits, prevent garbage from overstretching precision. // Many languages produce garbage when specifying more decimals // than the type actually has. A68G pads '0's in this case. // That is just as arbitrary, but at least recognisable. int strwid = 8 + before + after; // A bit too long. char *str = stack_string (p, strwid); int j, len = 0; for (j = 0; j < before; j++) { char ch = (char) (len < precision ? choose_dig_double (&y) : '0'); (void) string_plusab_char (str, ch, strwid); len++; } if (after > 0) { (void) string_plusab_char (str, POINT_CHAR, strwid); } for (j = 0; j < after; j++) { char ch = (char) (len < precision ? choose_dig_double (&y) : '0'); (void) string_plusab_char (str, ch, strwid); len++; } if ((int) strlen (str) > width) { (void) error_chars (str, width); } return str; } //! @brief Standard string for REAL. char *sub_fixed (NODE_T * p, REAL_T x, int width, int after) { // Better precision than the REAL only routine return sub_fixed_double (p, (DOUBLE_T) x, width, after, REAL_WIDTH); } #else //! @brief Fetch next digit from REAL. char choose_dig (REAL_T * y) { // Assuming positive "y". int c = (int) (*y *= 10); if (c > 9) { c = 9; } *y -= c; return digchar (c); } //! @brief Standard string for REAL. char *sub_fixed (NODE_T * p, REAL_T x, int width, int after) { ABEND (x < 0, ERROR_INTERNAL_CONSISTENCY, __func__); // Round and scale. REAL_T z = x + 0.5 * ten_up (-after); REAL_T y = z; int before = 0; // Not according RR - argument reduction to avoid long division loop. if (z >= 1.0e10) { // Arbitrary, log10 must be worthwhile. before = (int) floor (log10 (z)) - 1; z /= ten_up (before); } // Follow RR again. while (z >= 1.0) { before++; z /= 10.0; } // Scale number. y /= ten_up (before); // Put digits, prevent garbage from overstretching precision. // Many languages produce garbage when specifying more decimals // than the type actually has. A68G pads '0's in this case. // That is just as arbitrary, but at least recognisable. int strwid = 8 + before + after; // A bit too long. char *str = stack_string (p, strwid); int j, len = 0; for (j = 0; j < before; j++) { char ch = (char) (len < REAL_WIDTH ? choose_dig (&y) : '0'); (void) string_plusab_char (str, ch, strwid); len++; } if (after > 0) { (void) string_plusab_char (str, POINT_CHAR, strwid); } for (j = 0; j < after; j++) { char ch = (char) (len < REAL_WIDTH ? choose_dig (&y) : '0'); (void) string_plusab_char (str, ch, strwid); len++; } if ((int) strlen (str) > width) { (void) error_chars (str, width); } return str; } #endif //! @brief Formatted string for NUMBER. char *fixed (NODE_T * p) { A68_INT width, after; MOID_T *mode; ADDR_T pop_sp, arg_sp; POP_OBJECT (p, &after, A68_INT); POP_OBJECT (p, &width, A68_INT); CHECK_INT_SHORTEN (p, VALUE (&after)); CHECK_INT_SHORTEN (p, VALUE (&width)); arg_sp = A68_SP; DECREMENT_STACK_POINTER (p, SIZE (M_NUMBER)); mode = (MOID_T *) (VALUE ((A68_UNION *) STACK_TOP)); pop_sp = A68_SP; if (mode == M_REAL) { REAL_T 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 (p, x); A68_SP = arg_sp; if (VALUE (&after) >= 0 && (length > VALUE (&after) || VALUE (&width) == 0)) { REAL_T 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 = sub_fixed (p, y, length, VALUE (&after)); if (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) { A68_SP = arg_sp; PUSH_VALUE (p, VALUE (&width), A68_INT); PUSH_VALUE (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)); } } #if (A68_LEVEL >= 3) if (mode == M_LONG_REAL) { DOUBLE_T x = VALUE ((A68_LONG_REAL *) (STACK_OFFSET (A68_UNION_SIZE))).f; int length = ABS (VALUE (&width)) - (x < 0 || VALUE (&width) > 0 ? 1 : 0); char *s; CHECK_DOUBLE_REAL (p, x); A68_SP = arg_sp; if (VALUE (&after) >= 0 && (length > VALUE (&after) || VALUE (&width) == 0)) { DOUBLE_T y = ABS (x), z0, z1; if (VALUE (&width) == 0) { length = (VALUE (&after) == 0 ? 1 : 0); z0 = ten_up_double (-VALUE (&after)); z1 = ten_up_double (length); while (y + 0.5 * z0 > z1) { length++; z1 *= 10.0; } length += (VALUE (&after) == 0 ? 0 : VALUE (&after) + 1); } s = sub_fixed_double (p, y, length, VALUE (&after), LONG_REAL_WIDTH); if (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) { A68_SP = arg_sp; PUSH_VALUE (p, VALUE (&width), A68_INT); PUSH_VALUE (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)); } } #endif if (mode == M_LONG_REAL || mode == M_LONG_LONG_REAL) { int digits = DIGITS (mode); int length; BOOL_T ltz; char *s; MP_T *x = (MP_T *) (STACK_OFFSET (A68_UNION_SIZE)); A68_SP = 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 = nil_mp (p, digits); MP_T *z1 = nil_mp (p, digits); MP_T *t = nil_mp (p, digits); if (VALUE (&width) == 0) { length = (VALUE (&after) == 0 ? 1 : 0); (void) set_mp (z0, (MP_T) (MP_RADIX / 10), -1, digits); (void) set_mp (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 (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) { A68_SP = arg_sp; MP_DIGIT (x, 1) = ltz ? -ABS (MP_DIGIT (x, 1)) : ABS (MP_DIGIT (x, 1)); PUSH_VALUE (p, VALUE (&width), A68_INT); PUSH_VALUE (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)); } } if (mode == M_INT) { int x = VALUE ((A68_INT *) (STACK_OFFSET (A68_UNION_SIZE))); PUSH_UNION (p, M_REAL); PUSH_VALUE (p, (REAL_T) x, A68_REAL); INCREMENT_STACK_POINTER (p, SIZE (M_NUMBER) - (A68_UNION_SIZE + SIZE (M_REAL))); PUSH_VALUE (p, VALUE (&width), A68_INT); PUSH_VALUE (p, VALUE (&after), A68_INT); return fixed (p); } if (mode == M_LONG_INT || mode == M_LONG_LONG_INT) { A68_SP = pop_sp; if (mode == M_LONG_INT) { VALUE ((A68_UNION *) STACK_TOP) = (void *) M_LONG_REAL; } else { VALUE ((A68_UNION *) STACK_TOP) = (void *) M_LONG_LONG_REAL; } INCREMENT_STACK_POINTER (p, SIZE (M_NUMBER)); PUSH_VALUE (p, VALUE (&width), A68_INT); PUSH_VALUE (p, VALUE (&after), A68_INT); return fixed (p); } return NO_TEXT; } //! @brief Scale LONG for formatting. void long_standardise (NODE_T * p, MP_T * y, int digits, int before, int after, int *q) { ADDR_T pop_sp = A68_SP; MP_T *f = nil_mp (p, digits); MP_T *g = nil_mp (p, digits); MP_T *h = nil_mp (p, digits); MP_T *t = nil_mp (p, digits); ten_up_mp (p, g, before, 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_RADIX * ((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_RADIX * ((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)--; } } ten_up_mp (p, f, -after, 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) { (void) move_mp (y, h, digits); (*q)++; } A68_SP = pop_sp; } #if (A68_LEVEL >= 3) //! @brief Scale REAL for formatting. void standardise_double (DOUBLE_T * y, int before, int after, int *p) { DOUBLE_T f, g, h; //int j; //g = 1.0q; //for (j = 0; j < before; j++) { // g *= 10.0q; //} g = ten_up_double (before); h = g / 10.0q; while (*y >= g) { *y *= 0.1q; (*p)++; } if (*y != 0.0q) { while (*y < h) { *y *= 10.0q; (*p)--; } } //f = 1.0q; //for (j = 0; j < after; j++) { // f *= 0.1q; //} f = ten_up_double (-after); if (*y + 0.5q * f >= g) { *y = h; (*p)++; } } //! @brief Scale REAL for formatting. void standardise (REAL_T * y, int before, int after, int *p) { // Better precision than the REAL only routine DOUBLE_T z = (DOUBLE_T) * y; standardise_double (&z, before, after, p); *y = (REAL_T) z; } #else //! @brief Scale REAL for formatting. void standardise (REAL_T * y, int before, int after, int *p) { // This according RR, but for REAL the last digits are approximate. // A68G 3 uses DOUBLE precision version. // REAL_T f, g, h; //int j; //g = 1.0; //for (j = 0; j < before; j++) { // g *= 10.0; //} g = ten_up (before); 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; //} f = ten_up (-after); if (*y + 0.5 * f >= g) { *y = h; (*p)++; } } #endif //! @brief Formatted string for NUMBER. char *real (NODE_T * p) { ADDR_T 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); CHECK_INT_SHORTEN (p, VALUE (&frmt)); CHECK_INT_SHORTEN (p, VALUE (&expo)); CHECK_INT_SHORTEN (p, VALUE (&after)); CHECK_INT_SHORTEN (p, VALUE (&width)); arg_sp = A68_SP; DECREMENT_STACK_POINTER (p, SIZE (M_NUMBER)); mode = (MOID_T *) (VALUE ((A68_UNION *) STACK_TOP)); pop_sp = A68_SP; if (mode == M_REAL) { REAL_T 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; A68_SP = arg_sp; CHECK_REAL (p, x); if (SIGN (before) + SIGN (VALUE (&after)) > 0) { int strwid; char *s, *t1, *t2; REAL_T 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 { REAL_T 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, M_REAL); PUSH_VALUE (p, SIGN (x) * y, A68_REAL); INCREMENT_STACK_POINTER (p, SIZE (M_NUMBER) - (A68_UNION_SIZE + SIZE (M_REAL))); PUSH_VALUE (p, SIGN (VALUE (&width)) * (ABS (VALUE (&width)) - ABS (VALUE (&expo)) - 1), A68_INT); PUSH_VALUE (p, VALUE (&after), A68_INT); t1 = fixed (p); PUSH_UNION (p, M_INT); PUSH_VALUE (p, q, A68_INT); INCREMENT_STACK_POINTER (p, SIZE (M_NUMBER) - (A68_UNION_SIZE + SIZE (M_INT))); PUSH_VALUE (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 || strchr (s, ERROR_CHAR) != NO_TEXT) { A68_SP = arg_sp; PUSH_VALUE (p, VALUE (&width), A68_INT); PUSH_VALUE (p, VALUE (&after) != 0 ? VALUE (&after) - 1 : 0, A68_INT); PUSH_VALUE (p, VALUE (&expo) > 0 ? VALUE (&expo) + 1 : VALUE (&expo) - 1, A68_INT); PUSH_VALUE (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)); } } #if (A68_LEVEL >= 3) if (mode == M_LONG_REAL) { DOUBLE_T x = VALUE ((A68_LONG_REAL *) (STACK_OFFSET (A68_UNION_SIZE))).f; int before = ABS (VALUE (&width)) - ABS (VALUE (&expo)) - (VALUE (&after) != 0 ? VALUE (&after) + 1 : 0) - 2; CHECK_DOUBLE_REAL (p, x); A68_SP = arg_sp; if (SIGN (before) + SIGN (VALUE (&after)) > 0) { int strwid; char *s, *t1, *t2; DOUBLE_T y = (x >= 0.0q ? x : -x); int q = 0; standardise_double (&y, before, VALUE (&after), &q); if (VALUE (&frmt) > 0) { while (q % VALUE (&frmt) != 0) { y *= 10.0q; q--; if (VALUE (&after) > 0) { VALUE (&after)--; } } } else { DOUBLE_T upb = ten_up_double (-VALUE (&frmt)), lwb = ten_up_double (-VALUE (&frmt) - 1); while (y < lwb) { y *= 10.0q; q--; if (VALUE (&after) > 0) { VALUE (&after)--; } } while (y > upb) { y /= 10.0q; q++; if (VALUE (&after) > 0) { VALUE (&after)++; } } } PUSH_UNION (p, M_LONG_REAL); { QUAD_WORD_T d; d.f = (x >= 0.0q ? y : -y); PUSH_VALUE (p, d, A68_LONG_REAL); } INCREMENT_STACK_POINTER (p, SIZE (M_NUMBER) - (A68_UNION_SIZE + SIZE (M_LONG_REAL))); PUSH_VALUE (p, SIGN (VALUE (&width)) * (ABS (VALUE (&width)) - ABS (VALUE (&expo)) - 1), A68_INT); PUSH_VALUE (p, VALUE (&after), A68_INT); t1 = fixed (p); PUSH_UNION (p, M_INT); PUSH_VALUE (p, q, A68_INT); INCREMENT_STACK_POINTER (p, SIZE (M_NUMBER) - (A68_UNION_SIZE + SIZE (M_INT))); PUSH_VALUE (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 || strchr (s, ERROR_CHAR) != NO_TEXT) { A68_SP = arg_sp; PUSH_VALUE (p, VALUE (&width), A68_INT); PUSH_VALUE (p, VALUE (&after) != 0 ? VALUE (&after) - 1 : 0, A68_INT); PUSH_VALUE (p, VALUE (&expo) > 0 ? VALUE (&expo) + 1 : VALUE (&expo) - 1, A68_INT); PUSH_VALUE (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)); } } #endif if (mode == M_LONG_REAL || mode == M_LONG_LONG_REAL) { int digits = DIGITS (mode); int before; MP_T *x = (MP_T *) (STACK_OFFSET (A68_UNION_SIZE)); CHECK_LONG_REAL (p, x, mode); BOOL_T ltz = (BOOL_T) (MP_DIGIT (x, 1) < 0); A68_SP = 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; int q = 0; size_t N_mp = SIZE_MP (digits); MP_T *z = nil_mp (p, digits); (void) 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 { ADDR_T sp1 = A68_SP; MP_T *dif = nil_mp (p, digits); MP_T *lim = nil_mp (p, digits); (void) ten_up_mp (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); } A68_SP = sp1; } PUSH_UNION (p, mode); MP_DIGIT (z, 1) = (ltz ? -MP_DIGIT (z, 1) : MP_DIGIT (z, 1)); PUSH (p, z, N_mp); INCREMENT_STACK_POINTER (p, SIZE (M_NUMBER) - (A68_UNION_SIZE + SIZE_MP (digits))); PUSH_VALUE (p, SIGN (VALUE (&width)) * (ABS (VALUE (&width)) - ABS (VALUE (&expo)) - 1), A68_INT); PUSH_VALUE (p, VALUE (&after), A68_INT); t1 = fixed (p); PUSH_UNION (p, M_INT); PUSH_VALUE (p, q, A68_INT); INCREMENT_STACK_POINTER (p, SIZE (M_NUMBER) - (A68_UNION_SIZE + SIZE (M_INT))); PUSH_VALUE (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 || strchr (s, ERROR_CHAR) != NO_TEXT) { A68_SP = arg_sp; PUSH_VALUE (p, VALUE (&width), A68_INT); PUSH_VALUE (p, VALUE (&after) != 0 ? VALUE (&after) - 1 : 0, A68_INT); PUSH_VALUE (p, VALUE (&expo) > 0 ? VALUE (&expo) + 1 : VALUE (&expo) - 1, A68_INT); PUSH_VALUE (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)); } } if (mode == M_INT) { int x = VALUE ((A68_INT *) (STACK_OFFSET (A68_UNION_SIZE))); PUSH_UNION (p, M_REAL); PUSH_VALUE (p, (REAL_T) x, A68_REAL); INCREMENT_STACK_POINTER (p, SIZE (M_NUMBER) - (A68_UNION_SIZE + SIZE (M_REAL))); PUSH_VALUE (p, VALUE (&width), A68_INT); PUSH_VALUE (p, VALUE (&after), A68_INT); PUSH_VALUE (p, VALUE (&expo), A68_INT); PUSH_VALUE (p, VALUE (&frmt), A68_INT); return real (p); } if (mode == M_LONG_INT || mode == M_LONG_LONG_INT) { A68_SP = pop_sp; if (mode == M_LONG_INT) { VALUE ((A68_UNION *) STACK_TOP) = (void *) M_LONG_REAL; } else { VALUE ((A68_UNION *) STACK_TOP) = (void *) M_LONG_LONG_REAL; } INCREMENT_STACK_POINTER (p, SIZE (M_NUMBER)); PUSH_VALUE (p, VALUE (&width), A68_INT); PUSH_VALUE (p, VALUE (&after), A68_INT); PUSH_VALUE (p, VALUE (&expo), A68_INT); PUSH_VALUE (p, VALUE (&frmt), A68_INT); return real (p); } return NO_TEXT; } //! @brief PROC (NUMBER, INT) STRING whole void genie_whole (NODE_T * p) { ADDR_T pop_sp = A68_SP; A68_REF ref; char *str = whole (p); A68_SP = pop_sp - SIZE (M_INT) - SIZE (M_NUMBER); ref = tmp_to_a68_string (p, str); PUSH_REF (p, ref); } //! @brief PROC (NUMBER, INT, INT) STRING bits void genie_bits (NODE_T * p) { ADDR_T pop_sp = A68_SP; A68_REF ref; char *str = bits (p); A68_SP = pop_sp - 2 * SIZE (M_INT) - SIZE (M_HEX_NUMBER); ref = tmp_to_a68_string (p, str); PUSH_REF (p, ref); } //! @brief PROC (NUMBER, INT, INT) STRING fixed void genie_fixed (NODE_T * p) { ADDR_T pop_sp = A68_SP; A68_REF ref; char *str = fixed (p); A68_SP = pop_sp - 2 * SIZE (M_INT) - SIZE (M_NUMBER); ref = tmp_to_a68_string (p, str); PUSH_REF (p, ref); } //! @brief PROC (NUMBER, INT, INT, INT) STRING eng void genie_real (NODE_T * p) { ADDR_T pop_sp = A68_SP; A68_REF ref; char *str = real (p); A68_SP = pop_sp - 4 * SIZE (M_INT) - SIZE (M_NUMBER); ref = tmp_to_a68_string (p, str); PUSH_REF (p, ref); } //! @brief PROC (NUMBER, INT, INT, INT) STRING float void genie_float (NODE_T * p) { PUSH_VALUE (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, M_REF_FILE);\ z = STACK_TOP;\ INCREMENT_STACK_POINTER (p, SIZE (MODE (m)));\ pop_sp = A68_SP;\ open_for_reading (p, ref_file);\ genie_read_standard (p, MODE (m), z, ref_file);\ A68_SP = pop_sp;\ }\ \ void genie_put_##n (NODE_T * p)\ {\ int size = SIZE (MODE (m)), sizf = SIZE (M_REF_FILE);\ A68_REF ref_file = * (A68_REF *) STACK_OFFSET (- (size + sizf));\ CHECK_REF (p, ref_file, M_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 = A68_SP;\ open_for_reading (p, A68 (stand_in));\ genie_read_standard (p, MODE (m), z, A68 (stand_in));\ A68_SP = pop_sp;\ }\ \ void genie_print_##n (NODE_T * p)\ {\ int size = SIZE (MODE (m));\ reset_transput_buffer (UNFORMATTED_BUFFER);\ open_for_writing (p, A68 (stand_out));\ genie_write_standard (p, MODE (m), STACK_OFFSET (-size), A68 (stand_out));\ write_purge_buffer (p, A68 (stand_out), UNFORMATTED_BUFFER);\ DECREMENT_STACK_POINTER (p, size);\ } A68C_TRANSPUT (int, INT); A68C_TRANSPUT (long_int, LONG_INT); A68C_TRANSPUT (long_mp_int, LONG_LONG_INT); A68C_TRANSPUT (real, REAL); A68C_TRANSPUT (long_real, LONG_REAL); A68C_TRANSPUT (long_mp_real, LONG_LONG_REAL); A68C_TRANSPUT (bits, BITS); A68C_TRANSPUT (long_bits, LONG_BITS); A68C_TRANSPUT (long_mp_bits, LONG_LONG_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, M_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 (M_REF_FILE);\ A68_REF ref_file = * (A68_REF *) STACK_OFFSET (- (size + sizf));\ CHECK_REF (p, ref_file, M_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, A68 (stand_out));\ genie_write_standard (p, MODE (m), STACK_OFFSET (-size), A68 (stand_out));\ write_purge_buffer (p, A68 (stand_out), UNFORMATTED_BUFFER);\ DECREMENT_STACK_POINTER (p, size);\ } A68C_TRANSPUT (complex, real, COMPLEX); A68C_TRANSPUT (mp_complex, long_real, LONG_COMPLEX); A68C_TRANSPUT (long_mp_complex, long_mp_real, LONG_LONG_COMPLEX); #undef A68C_TRANSPUT //! @brief PROC STRING read line 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)); a68_free (line); #else genie_read_string (p); genie_stand_in (p); genie_new_line (p); #endif } algol68g-3.1.2/src/a68g/mp-genie.c0000644000175000017500000010361214361065320013265 00000000000000//! @file mp-genie.c //! @author J. Marcel van der Veer // //! @section Copyright // // This file is part of Algol68G - an Algol 68 compiler-interpreter. // Copyright 2001-2023 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" #include "a68g-genie.h" #include "a68g-prelude.h" #include "a68g-double.h" #include "a68g-mp.h" //! brief LONG REAL long infinity void genie_infinity_mp (NODE_T *p) { int digs = DIGITS (MOID (p)); MP_T *z = nil_mp (p, digs); MP_STATUS (z) = (PLUS_INF_MASK | INIT_MASK); } //! brief LONG REAL long minus infinity void genie_minus_infinity_mp (NODE_T *p) { int digs = DIGITS (MOID (p)); MP_T *z = nil_mp (p, digs); MP_STATUS (z) = (MINUS_INF_MASK | INIT_MASK); } //! @brief LONG INT long max int void genie_long_max_int (NODE_T * p) { int digs = DIGITS (M_LONG_INT); int k; MP_T *z = nil_mp (p, digs); MP_STATUS (z) = (MP_T) INIT_MASK; MP_EXPONENT (z) = (MP_T) (digs - 1); for (k = 1; k <= digs; k++) { MP_DIGIT (z, k) = (MP_T) (MP_RADIX - 1); } } //! @brief LONG LONG INT long long max int void genie_long_mp_max_int (NODE_T * p) { int digs = DIGITS (M_LONG_LONG_INT); int k; MP_T *z = nil_mp (p, digs); MP_STATUS (z) = (MP_T) INIT_MASK; MP_EXPONENT (z) = (MP_T) (digs - 1); for (k = 1; k <= digs; k++) { MP_DIGIT (z, k) = (MP_T) (MP_RADIX - 1); } } //! @brief LONG REAL long max real void genie_long_max_real (NODE_T * p) { int k, digs = DIGITS (M_LONG_REAL); MP_T *z = nil_mp (p, digs); MP_STATUS (z) = (MP_T) INIT_MASK; MP_EXPONENT (z) = (MP_T) (MAX_MP_EXPONENT - 1); for (k = 1; k <= digs; k++) { MP_DIGIT (z, k) = (MP_T) (MP_RADIX - 1); } } //! @brief LONG LONG REAL long long max real void genie_long_mp_max_real (NODE_T * p) { int k, digs = DIGITS (M_LONG_LONG_REAL); MP_T *z = nil_mp (p, digs); MP_STATUS (z) = (MP_T) INIT_MASK; MP_EXPONENT (z) = (MP_T) (MAX_MP_EXPONENT - 1); for (k = 1; k <= digs; k++) { MP_DIGIT (z, k) = (MP_T) (MP_RADIX - 1); } } //! @brief LONG REAL min long real void genie_long_min_real (NODE_T * p) { (void) lit_mp (p, 1, -MAX_MP_EXPONENT, DIGITS (M_LONG_REAL)); } //! @brief LONG LONG REAL min long long real void genie_long_mp_min_real (NODE_T * p) { (void) lit_mp (p, 1, -MAX_MP_EXPONENT, DIGITS (M_LONG_LONG_REAL)); } //! @brief LONG REAL small long real void genie_long_small_real (NODE_T * p) { int digs = DIGITS (M_LONG_REAL); (void) lit_mp (p, 1, 1 - digs, digs); } //! @brief LONG LONG REAL small long long real void genie_long_mp_small_real (NODE_T * p) { int digs = DIGITS (M_LONG_LONG_REAL); (void) lit_mp (p, 1, 1 - digs, digs); } //! @brief OP LENG = (INT) LONG INT void genie_lengthen_int_to_mp (NODE_T * p) { int digs = DIGITS (M_LONG_INT); A68_INT k; POP_OBJECT (p, &k, A68_INT); MP_T *z = nil_mp (p, digs); (void) int_to_mp (p, z, VALUE (&k), digs); MP_STATUS (z) = (MP_T) INIT_MASK; } //! @brief OP SHORTEN = (LONG INT) INT void genie_shorten_mp_to_int (NODE_T * p) { MOID_T *mode = LHS_MODE (p); int digs = 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_VALUE (p, mp_to_int (p, z, digs), A68_INT); } //! @brief OP LENG = (REAL) LONG REAL void genie_lengthen_real_to_mp (NODE_T * p) { int digs = DIGITS (M_LONG_REAL); A68_REAL x; POP_OBJECT (p, &x, A68_REAL); MP_T *z = nil_mp (p, digs); (void) real_to_mp (p, z, VALUE (&x), digs); MP_STATUS (z) = (MP_T) INIT_MASK; } //! @brief OP SHORTEN = (LONG REAL) REAL void genie_shorten_mp_to_real (NODE_T * p) { MOID_T *mode = LHS_MODE (p); int digs = 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_VALUE (p, mp_to_real (p, z, digs), A68_REAL); } //! @brief OP ENTIER = (LONG REAL) LONG INT void genie_entier_mp (NODE_T * p) { int digs = DIGITS (LHS_MODE (p)), size = SIZE (LHS_MODE (p)); ADDR_T pop_sp = A68_SP; MP_T *z = (MP_T *) STACK_OFFSET (-size); (void) entier_mp (p, z, z, digs); A68_SP = pop_sp; } #define C_L_FUNCTION(p, f)\ int digs = DIGITS (MOID (p)), size = SIZE (MOID (p));\ ADDR_T pop_sp = A68_SP;\ MP_T *x = (MP_T *) STACK_OFFSET (-size);\ errno = 0;\ PRELUDE_ERROR (f (p, x, x, digs) == NaN_MP || errno != 0, p, ERROR_INVALID_ARGUMENT, MOID (p));\ MP_STATUS (x) = (MP_T) INIT_MASK;\ A68_SP = pop_sp; //! @brief PROC (LONG REAL) LONG REAL long sqrt void genie_sqrt_mp (NODE_T * p) { C_L_FUNCTION (p, sqrt_mp); } //! @brief PROC (LONG REAL) LONG REAL long curt void genie_curt_mp (NODE_T * p) { C_L_FUNCTION (p, curt_mp); } //! @brief PROC (LONG REAL) LONG REAL long exp void genie_exp_mp (NODE_T * p) { C_L_FUNCTION (p, exp_mp); } //! @brief PROC (LONG REAL) LONG REAL long erf void genie_erf_mp (NODE_T * p) { C_L_FUNCTION (p, erf_mp); } //! @brief PROC (LONG REAL) LONG REAL long inverf void genie_inverf_mp (NODE_T * p) { C_L_FUNCTION (p, inverf_mp); } //! @brief PROC (LONG REAL) LONG REAL long erfc void genie_erfc_mp (NODE_T * p) { C_L_FUNCTION (p, erfc_mp); } //! @brief PROC (LONG REAL) LONG REAL long inverfc void genie_inverfc_mp (NODE_T * p) { C_L_FUNCTION (p, inverfc_mp); } //! @brief PROC (LONG REAL) LONG REAL long gamma void genie_gamma_mp (NODE_T * p) { C_L_FUNCTION (p, gamma_mp); } //! @brief PROC (LONG REAL) LONG REAL long ln gamma void genie_lngamma_mp (NODE_T * p) { C_L_FUNCTION (p, lngamma_mp); } //! @brief PROC (LONG REAL) LONG REAL long beta void genie_beta_mp (NODE_T * p) { int digs = DIGITS (MOID (p)), size = SIZE (MOID (p)); MP_T *b = (MP_T *) STACK_OFFSET (-size); MP_T *a = (MP_T *) STACK_OFFSET (-2 * size); PRELUDE_ERROR (beta_mp (p, a, a, b, digs) == NaN_MP, p, ERROR_INVALID_ARGUMENT, MOID (p)); A68_SP -= size; MP_STATUS (a) = (MP_T) INIT_MASK; } //! @brief PROC (LONG REAL) LONG REAL long ln beta void genie_lnbeta_mp (NODE_T * p) { int digs = DIGITS (MOID (p)), size = SIZE (MOID (p)); MP_T *b = (MP_T *) STACK_OFFSET (-size); MP_T *a = (MP_T *) STACK_OFFSET (-2 * size); PRELUDE_ERROR (lnbeta_mp (p, a, a, b, digs) == NaN_MP, p, ERROR_INVALID_ARGUMENT, MOID (p)); A68_SP -= size; MP_STATUS (a) = (MP_T) INIT_MASK; } //! @brief PROC (LONG REAL) LONG REAL long beta void genie_beta_inc_mp (NODE_T * p) { int digs = DIGITS (MOID (p)), size = SIZE (MOID (p)); MP_T *x = (MP_T *) STACK_OFFSET (-size); MP_T *t = (MP_T *) STACK_OFFSET (-2 * size); MP_T *s = (MP_T *) STACK_OFFSET (-3 * size); PRELUDE_ERROR (beta_inc_mp (p, s, s, t, x, digs) == NaN_MP, p, ERROR_INVALID_ARGUMENT, MOID (p)); A68_SP -= 2 * size; MP_STATUS (s) = (MP_T) INIT_MASK; } //! @brief PROC (LONG REAL) LONG REAL long ln void genie_ln_mp (NODE_T * p) { C_L_FUNCTION (p, ln_mp); } //! @brief PROC (LONG REAL) LONG REAL long log void genie_log_mp (NODE_T * p) { C_L_FUNCTION (p, log_mp); } //! @brief PROC (LONG REAL) LONG REAL long sinh void genie_sinh_mp (NODE_T * p) { C_L_FUNCTION (p, sinh_mp); } //! @brief PROC (LONG REAL) LONG REAL long cosh void genie_cosh_mp (NODE_T * p) { C_L_FUNCTION (p, cosh_mp); } //! @brief PROC (LONG REAL) LONG REAL long tanh void genie_tanh_mp (NODE_T * p) { C_L_FUNCTION (p, tanh_mp); } //! @brief PROC (LONG REAL) LONG REAL long arcsinh void genie_asinh_mp (NODE_T * p) { C_L_FUNCTION (p, asinh_mp); } //! @brief PROC (LONG REAL) LONG REAL long arccosh void genie_acosh_mp (NODE_T * p) { C_L_FUNCTION (p, acosh_mp); } //! @brief PROC (LONG REAL) LONG REAL long arctanh void genie_atanh_mp (NODE_T * p) { C_L_FUNCTION (p, atanh_mp); } //! @brief PROC (LONG REAL) LONG REAL long sin void genie_sin_mp (NODE_T * p) { C_L_FUNCTION (p, sin_mp); } //! @brief PROC (LONG REAL) LONG REAL long cos void genie_cos_mp (NODE_T * p) { C_L_FUNCTION (p, cos_mp); } //! @brief PROC (LONG REAL) LONG REAL long tan void genie_tan_mp (NODE_T * p) { C_L_FUNCTION (p, tan_mp); } //! @brief PROC (LONG REAL) LONG REAL long arcsin void genie_asin_mp (NODE_T * p) { C_L_FUNCTION (p, asin_mp); } //! @brief PROC (LONG REAL) LONG REAL long arccos void genie_acos_mp (NODE_T * p) { C_L_FUNCTION (p, acos_mp); } //! @brief PROC (LONG REAL) LONG REAL long arctan void genie_atan_mp (NODE_T * p) { C_L_FUNCTION (p, atan_mp); } //! @brief PROC (LONG REAL, LONG REAL) LONG REAL long arctan2 void genie_atan2_mp (NODE_T * p) { int digs = DIGITS (MOID (p)), size = SIZE (MOID (p)); MP_T *y = (MP_T *) STACK_OFFSET (-size); MP_T *x = (MP_T *) STACK_OFFSET (-2 * size); PRELUDE_ERROR (atan2_mp (p, x, y, x, digs) == NaN_MP, p, ERROR_INVALID_ARGUMENT, MOID (p)); A68_SP -= size; MP_STATUS (x) = (MP_T) INIT_MASK; } // Arithmetic operations. //! @brief OP LENG = (LONG MODE) LONG LONG MODE void genie_lengthen_mp_to_long_mp (NODE_T * p) { DECREMENT_STACK_POINTER (p, (int) size_mp ()); MP_T *z = (MP_T *) STACK_ADDRESS (A68_SP); z = len_mp (p, z, mp_digits (), long_mp_digits ()); MP_STATUS (z) = (MP_T) INIT_MASK; } //! @brief OP SHORTEN = (LONG LONG MODE) LONG MODE void genie_shorten_long_mp_to_mp (NODE_T * p) { MOID_T *m = SUB_MOID (p); DECREMENT_STACK_POINTER (p, (int) size_long_mp ()); MP_T *z = empty_mp (p, mp_digits ()); if (m == M_LONG_INT) { PRELUDE_ERROR (MP_EXPONENT (z) > LONG_MP_DIGITS - 1, p, ERROR_OUT_OF_BOUNDS, m); } (void) shorten_mp (p, z, mp_digits (), z, long_mp_digits ()); MP_STATUS (z) = (MP_T) INIT_MASK; } //! @brief OP - = (LONG MODE) LONG MODE void genie_minus_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 void genie_abs_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 void genie_sign_mp (NODE_T * p) { int size = SIZE (LHS_MODE (p)); MP_T *z = (MP_T *) STACK_OFFSET (-size); DECREMENT_STACK_POINTER (p, size); PUSH_VALUE (p, SIGN (MP_DIGIT (z, 1)), A68_INT); } //! @brief OP + = (LONG MODE, LONG MODE) LONG MODE void genie_add_mp (NODE_T * p) { MOID_T *mode = RHS_MODE (p); int digs = 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, digs); MP_STATUS (x) = (MP_T) INIT_MASK; DECREMENT_STACK_POINTER (p, size); } //! @brief OP - = (LONG MODE, LONG MODE) LONG MODE void genie_sub_mp (NODE_T * p) { MOID_T *mode = RHS_MODE (p); int digs = 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, digs); MP_STATUS (x) = (MP_T) INIT_MASK; DECREMENT_STACK_POINTER (p, size); } //! @brief OP * = (LONG MODE, LONG MODE) LONG MODE void genie_mul_mp (NODE_T * p) { MOID_T *mode = RHS_MODE (p); int digs = 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, digs); MP_STATUS (x) = (MP_T) INIT_MASK; DECREMENT_STACK_POINTER (p, size); } //! @brief OP / = (LONG MODE, LONG MODE) LONG MODE void genie_div_mp (NODE_T * p) { MOID_T *mode = RHS_MODE (p); int digs = 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, digs) == NaN_MP, p, ERROR_DIVISION_BY_ZERO, mode); MP_STATUS (x) = (MP_T) INIT_MASK; DECREMENT_STACK_POINTER (p, size); } //! @brief OP % = (LONG MODE, LONG MODE) LONG MODE void genie_over_mp (NODE_T * p) { MOID_T *mode = RHS_MODE (p); int digs = 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, digs) == NaN_MP, p, ERROR_DIVISION_BY_ZERO, mode); MP_STATUS (x) = (MP_T) INIT_MASK; DECREMENT_STACK_POINTER (p, size); } //! @brief OP %* = (LONG MODE, LONG MODE) LONG MODE void genie_mod_mp (NODE_T * p) { MOID_T *mode = RHS_MODE (p); int digs = 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, digs) == NaN_MP, p, ERROR_DIVISION_BY_ZERO, mode); if (MP_DIGIT (x, 1) < 0) { MP_DIGIT (y, 1) = ABS (MP_DIGIT (y, 1)); (void) add_mp (p, x, x, y, digs); } MP_STATUS (x) = (MP_T) INIT_MASK; DECREMENT_STACK_POINTER (p, size); } //! @brief OP +:= = (REF LONG MODE, LONG MODE) REF LONG MODE void genie_plusab_mp (NODE_T * p) { MOID_T *mode = LHS_MODE (p); genie_f_and_becomes (p, mode, genie_add_mp); } //! @brief OP -:= = (REF LONG MODE, LONG MODE) REF LONG MODE void genie_minusab_mp (NODE_T * p) { MOID_T *mode = LHS_MODE (p); genie_f_and_becomes (p, mode, genie_sub_mp); } //! @brief OP *:= = (REF LONG MODE, LONG MODE) REF LONG MODE void genie_timesab_mp (NODE_T * p) { MOID_T *mode = LHS_MODE (p); genie_f_and_becomes (p, mode, genie_mul_mp); } //! @brief OP /:= = (REF LONG MODE, LONG MODE) REF LONG MODE void genie_divab_mp (NODE_T * p) { MOID_T *mode = LHS_MODE (p); genie_f_and_becomes (p, mode, genie_div_mp); } //! @brief OP %:= = (REF LONG MODE, LONG MODE) REF LONG MODE void genie_overab_mp (NODE_T * p) { MOID_T *mode = LHS_MODE (p); genie_f_and_becomes (p, mode, genie_over_mp); } //! @brief OP %*:= = (REF LONG MODE, LONG MODE) REF LONG MODE void genie_modab_mp (NODE_T * p) { MOID_T *mode = LHS_MODE (p); genie_f_and_becomes (p, mode, genie_mod_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 digs = 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, digs);\ DECREMENT_STACK_POINTER (p, 2 * size);\ PUSH_VALUE (p, VALUE (&z), A68_BOOL);\ } A68_CMP_LONG (genie_eq_mp, eq_mp); A68_CMP_LONG (genie_ne_mp, ne_mp); A68_CMP_LONG (genie_lt_mp, lt_mp); A68_CMP_LONG (genie_gt_mp, gt_mp); A68_CMP_LONG (genie_le_mp, le_mp); A68_CMP_LONG (genie_ge_mp, ge_mp); //! @brief OP ** = (LONG MODE, INT) LONG MODE void genie_pow_mp_int (NODE_T * p) { MOID_T *mode = LHS_MODE (p); int digs = 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), digs); MP_STATUS (x) = (MP_T) INIT_MASK; } //! @brief OP ** = (LONG MODE, LONG MODE) LONG MODE void genie_pow_mp (NODE_T * p) { MOID_T *mode = LHS_MODE (p); int digs = DIGITS (mode), size = SIZE (mode); ADDR_T pop_sp = A68_SP; MP_T *x = (MP_T *) STACK_OFFSET (-2 * size); MP_T *y = (MP_T *) STACK_OFFSET (-size); 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)) { SET_MP_ONE (x, digs); } } else { (void) pow_mp (p, x, x, y, digs); } A68_SP = pop_sp - size; MP_STATUS (x) = (MP_T) INIT_MASK; } //! @brief OP ODD = (LONG INT) BOOL void genie_odd_mp (NODE_T * p) { MOID_T *mode = LHS_MODE (p); int digs = DIGITS (mode), size = SIZE (mode); MP_T *z = (MP_T *) STACK_OFFSET (-size); DECREMENT_STACK_POINTER (p, size); if (MP_EXPONENT (z) <= (MP_T) (digs - 1)) { PUSH_VALUE (p, (BOOL_T) ! EVEN ((MP_INT_T) (z[(int) (2 + MP_EXPONENT (z))])), A68_BOOL); } else { PUSH_VALUE (p, A68_FALSE, A68_BOOL); } } //! @brief Test whether z is a valid LONG INT. 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 void genie_add_long_int (NODE_T * p) { MOID_T *m = RHS_MODE (p); int digs = 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, digs); 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 void genie_sub_long_int (NODE_T * p) { MOID_T *m = RHS_MODE (p); int digs = 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, digs); 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 void genie_mul_long_int (NODE_T * p) { MOID_T *m = RHS_MODE (p); int digs = 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, digs); 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 void genie_pow_mp_int_int (NODE_T * p) { MOID_T *m = LHS_MODE (p); int digs = 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), digs); test_long_int_range (p, x, m); MP_STATUS (x) = (MP_T) INIT_MASK; } //! @brief OP +:= = (REF LONG INT, LONG INT) REF LONG INT 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 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 void genie_timesab_long_int (NODE_T * p) { MOID_T *mode = LHS_MODE (p); genie_f_and_becomes (p, mode, genie_mul_long_int); } //! @brief OP ROUND = (LONG REAL) LONG INT void genie_round_mp (NODE_T * p) { MOID_T *mode = LHS_MODE (p); int digs = DIGITS (mode), size = SIZE (mode); ADDR_T pop_sp = A68_SP; MP_T *z = (MP_T *) STACK_OFFSET (-size); (void) round_mp (p, z, z, digs); A68_SP = pop_sp; } #define C_CL_FUNCTION(p, f)\ MOID_T *mode = MOID (p);\ int digs = DIGITSC (mode), size = SIZEC (mode);\ ADDR_T pop_sp = A68_SP;\ MP_T *im = (MP_T *) STACK_OFFSET (-size);\ MP_T *re = (MP_T *) STACK_OFFSET (-2 * size);\ errno = 0;\ (void) f(p, re, im, digs);\ A68_SP = 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 (LONG COMPLEX) LONG COMPLEX long csqrt void genie_sqrt_mp_complex (NODE_T * p) { C_CL_FUNCTION (p, csqrt_mp); } //! @brief PROC (LONG COMPLEX) LONG COMPLEX long cexp void genie_exp_mp_complex (NODE_T * p) { C_CL_FUNCTION (p, cexp_mp); } //! @brief PROC (LONG COMPLEX) LONG COMPLEX long cln void genie_ln_mp_complex (NODE_T * p) { C_CL_FUNCTION (p, cln_mp); } //! @brief PROC (LONG COMPLEX) LONG COMPLEX long csin void genie_sin_mp_complex (NODE_T * p) { C_CL_FUNCTION (p, csin_mp); } //! @brief PROC (LONG COMPLEX) LONG COMPLEX long ccos void genie_cos_mp_complex (NODE_T * p) { C_CL_FUNCTION (p, ccos_mp); } //! @brief PROC (LONG COMPLEX) LONG COMPLEX long ctan void genie_tan_mp_complex (NODE_T * p) { C_CL_FUNCTION (p, ctan_mp); } //! @brief PROC (LONG COMPLEX) LONG COMPLEX long arcsin void genie_asin_mp_complex (NODE_T * p) { C_CL_FUNCTION (p, casin_mp); } //! @brief PROC (LONG COMPLEX) LONG COMPLEX long carccos void genie_acos_mp_complex (NODE_T * p) { C_CL_FUNCTION (p, cacos_mp); } //! @brief PROC (LONG COMPLEX) LONG COMPLEX long catan void genie_atan_mp_complex (NODE_T * p) { C_CL_FUNCTION (p, catan_mp); } //! @brief PROC (LONG COMPLEX) LONG COMPLEX long csinh void genie_sinh_mp_complex (NODE_T * p) { C_CL_FUNCTION (p, csinh_mp); } //! @brief PROC (LONG COMPLEX) LONG COMPLEX long ccosh void genie_cosh_mp_complex (NODE_T * p) { C_CL_FUNCTION (p, ccosh_mp); } //! @brief PROC (LONG COMPLEX) LONG COMPLEX long ctanh void genie_tanh_mp_complex (NODE_T * p) { C_CL_FUNCTION (p, ctanh_mp); } //! @brief PROC (LONG COMPLEX) LONG COMPLEX long carcsinh void genie_asinh_mp_complex (NODE_T * p) { C_CL_FUNCTION (p, casinh_mp); } //! @brief PROC (LONG COMPLEX) LONG COMPLEX long carccosh void genie_acosh_mp_complex (NODE_T * p) { C_CL_FUNCTION (p, cacosh_mp); } //! @brief PROC (LONG COMPLEX) LONG COMPLEX long carctanh void genie_atanh_mp_complex (NODE_T * p) { C_CL_FUNCTION (p, catanh_mp); } //! @brief OP LENG = (COMPLEX) LONG COMPLEX void genie_lengthen_complex_to_mp_complex (NODE_T * p) { int digs = DIGITS (M_LONG_REAL); A68_REAL a, b; POP_OBJECT (p, &b, A68_REAL); POP_OBJECT (p, &a, A68_REAL); MP_T *z = nil_mp (p, digs); (void) real_to_mp (p, z, VALUE (&a), digs); MP_STATUS (z) = (MP_T) INIT_MASK; z = nil_mp (p, digs); (void) real_to_mp (p, z, VALUE (&b), digs); MP_STATUS (z) = (MP_T) INIT_MASK; } //! @brief OP SHORTEN = (LONG COMPLEX) COMPLEX void genie_shorten_mp_complex_to_complex (NODE_T * p) { int digs = DIGITS (M_LONG_REAL), size = SIZE (M_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_VALUE (p, mp_to_real (p, a, digs), A68_REAL); PUSH_VALUE (p, mp_to_real (p, b, digs), A68_REAL); } //! @brief OP LENG = (LONG COMPLEX) LONG LONG COMPLEX void genie_lengthen_mp_complex_to_long_mp_complex (NODE_T * p) { int digs = DIGITS (M_LONG_REAL), size = SIZE (M_LONG_REAL); int gdigs = DIGITS (M_LONG_LONG_REAL), size_g = SIZE (M_LONG_LONG_REAL); ADDR_T pop_sp = A68_SP; MP_T *a = (MP_T *) STACK_OFFSET (-2 * size); MP_T *b = (MP_T *) STACK_OFFSET (-size); MP_T *c = len_mp (p, a, digs, gdigs); MP_T *d = len_mp (p, b, digs, gdigs); (void) move_mp (a, c, gdigs); (void) move_mp (&a[LEN_MP (gdigs)], d, gdigs); A68_SP = pop_sp; INCREMENT_STACK_POINTER (p, 2 * (size_g - size)); } //! @brief OP SHORTEN = (LONG LONG COMPLEX) LONG COMPLEX void genie_shorten_long_mp_complex_to_mp_complex (NODE_T * p) { int digs = DIGITS (M_LONG_REAL), size = SIZE (M_LONG_REAL); int gdigs = DIGITS (M_LONG_LONG_REAL), size_g = SIZE (M_LONG_LONG_REAL); ADDR_T pop_sp = A68_SP; MP_T *a, *b; b = (MP_T *) STACK_OFFSET (-size_g); a = (MP_T *) STACK_OFFSET (-2 * size_g); (void) shorten_mp (p, a, digs, a, gdigs); (void) shorten_mp (p, &a[LEN_MP (digs)], digs, b, gdigs); A68_SP = pop_sp; MP_STATUS (a) = (MP_T) INIT_MASK; MP_STATUS (&a[LEN_MP (digs)]) = (MP_T) INIT_MASK; DECREMENT_STACK_POINTER (p, 2 * (size_g - size)); } //! @brief OP RE = (LONG COMPLEX) LONG REAL void genie_re_mp_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, size); } //! @brief OP IM = (LONG COMPLEX) LONG REAL void genie_im_mp_complex (NODE_T * p) { MOID_T *mode = SUB_MOID (p); int digs = DIGITS (mode), size = SIZE (mode); MP_T *b = (MP_T *) STACK_OFFSET (-size); MP_T *a = (MP_T *) STACK_OFFSET (-2 * size); (void) move_mp (a, b, digs); MP_STATUS (a) = (MP_T) INIT_MASK; DECREMENT_STACK_POINTER (p, size); } //! @brief OP - = (LONG COMPLEX) LONG COMPLEX void genie_minus_mp_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 void genie_conj_mp_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 void genie_abs_mp_complex (NODE_T * p) { MOID_T *mode = SUB_MOID (p); int digs = DIGITS (mode), size = SIZE (mode); ADDR_T pop_sp = A68_SP; MP_T *b = (MP_T *) STACK_OFFSET (-size); MP_T *a = (MP_T *) STACK_OFFSET (-2 * size); MP_T *z = nil_mp (p, digs); errno = 0; (void) hypot_mp (p, z, a, b, digs); A68_SP = pop_sp; DECREMENT_STACK_POINTER (p, size); (void) move_mp (a, z, digs); MP_STATUS (a) = (MP_T) INIT_MASK; MATH_RTE (p, errno != 0, mode, NO_TEXT); } //! @brief OP ARG = (LONG COMPLEX) LONG REAL void genie_arg_mp_complex (NODE_T * p) { MOID_T *mode = SUB_MOID (p); int digs = DIGITS (mode), size = SIZE (mode); ADDR_T pop_sp = A68_SP; MP_T *b = (MP_T *) STACK_OFFSET (-size); MP_T *a = (MP_T *) STACK_OFFSET (-2 * size); MP_T *z = nil_mp (p, digs); errno = 0; (void) atan2_mp (p, z, a, b, digs); A68_SP = pop_sp; DECREMENT_STACK_POINTER (p, size); (void) move_mp (a, z, digs); MP_STATUS (a) = (MP_T) INIT_MASK; MATH_RTE (p, errno != 0, mode, NO_TEXT); } //! @brief OP + = (LONG COMPLEX, LONG COMPLEX) LONG COMPLEX void genie_add_mp_complex (NODE_T * p) { MOID_T *mode = SUB_MOID (p); int digs = DIGITSC (mode), size = SIZEC (mode); ADDR_T pop_sp = A68_SP; 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, digs); (void) add_mp (p, a, a, c, digs); MP_STATUS (a) = (MP_T) INIT_MASK; MP_STATUS (b) = (MP_T) INIT_MASK; A68_SP = pop_sp; DECREMENT_STACK_POINTER (p, 2 * size); } //! @brief OP - = (LONG COMPLEX, LONG COMPLEX) LONG COMPLEX void genie_sub_mp_complex (NODE_T * p) { MOID_T *mode = SUB_MOID (p); int digs = DIGITSC (mode), size = SIZEC (mode); ADDR_T pop_sp = A68_SP; 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, digs); (void) sub_mp (p, a, a, c, digs); MP_STATUS (a) = (MP_T) INIT_MASK; MP_STATUS (b) = (MP_T) INIT_MASK; A68_SP = pop_sp; DECREMENT_STACK_POINTER (p, 2 * size); } //! @brief OP * = (LONG COMPLEX, LONG COMPLEX) LONG COMPLEX void genie_mul_mp_complex (NODE_T * p) { MOID_T *mode = SUB_MOID (p); int digs = DIGITSC (mode), size = SIZEC (mode); ADDR_T pop_sp = A68_SP; 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, digs); MP_STATUS (a) = (MP_T) INIT_MASK; MP_STATUS (b) = (MP_T) INIT_MASK; A68_SP = pop_sp; DECREMENT_STACK_POINTER (p, 2 * size); } //! @brief OP / = (LONG COMPLEX, LONG COMPLEX) LONG COMPLEX void genie_div_mp_complex (NODE_T * p) { MOID_T *mode = SUB_MOID (p); int digs = DIGITSC (mode), size = SIZEC (mode); ADDR_T pop_sp = A68_SP; 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, digs) == NaN_MP, p, ERROR_DIVISION_BY_ZERO, mode); MP_STATUS (a) = (MP_T) INIT_MASK; MP_STATUS (b) = (MP_T) INIT_MASK; A68_SP = pop_sp; DECREMENT_STACK_POINTER (p, 2 * size); } //! @brief OP ** = (LONG COMPLEX, INT) LONG COMPLEX void genie_pow_mp_complex_int (NODE_T * p) { MOID_T *mode = SUB_MOID (p); int digs = DIGITSC (mode), size = SIZEC (mode); ADDR_T pop_sp; A68_INT j; int expo; BOOL_T negative; POP_OBJECT (p, &j, A68_INT); pop_sp = A68_SP; MP_T *im_x = (MP_T *) STACK_OFFSET (-size); MP_T *re_x = (MP_T *) STACK_OFFSET (-2 * size); MP_T *re_z = lit_mp (p, 1, 0, digs); MP_T *im_z = nil_mp (p, digs); MP_T *re_y = nil_mp (p, digs); MP_T *im_y = nil_mp (p, digs); (void) move_mp (re_y, re_x, digs); (void) move_mp (im_y, im_x, digs); MP_T *rea = nil_mp (p, digs); MP_T *acc = nil_mp (p, digs); expo = 1; negative = (BOOL_T) (VALUE (&j) < 0); if (negative) { VALUE (&j) = -VALUE (&j); } while ((unt) expo <= (unt) (VALUE (&j))) { if (expo & VALUE (&j)) { (void) mul_mp (p, acc, im_z, im_y, digs); (void) mul_mp (p, rea, re_z, re_y, digs); (void) sub_mp (p, rea, rea, acc, digs); (void) mul_mp (p, acc, im_z, re_y, digs); (void) mul_mp (p, im_z, re_z, im_y, digs); (void) add_mp (p, im_z, im_z, acc, digs); (void) move_mp (re_z, rea, digs); } (void) mul_mp (p, acc, im_y, im_y, digs); (void) mul_mp (p, rea, re_y, re_y, digs); (void) sub_mp (p, rea, rea, acc, digs); (void) mul_mp (p, acc, im_y, re_y, digs); (void) mul_mp (p, im_y, re_y, im_y, digs); (void) add_mp (p, im_y, im_y, acc, digs); (void) move_mp (re_y, rea, digs); expo <<= 1; } A68_SP = pop_sp; if (negative) { SET_MP_ONE (re_x, digs); SET_MP_ZERO (im_x, digs); INCREMENT_STACK_POINTER (p, 2 * size); genie_div_mp_complex (p); } else { (void) move_mp (re_x, re_z, digs); (void) move_mp (im_x, im_z, digs); } MP_STATUS (re_x) = (MP_T) INIT_MASK; MP_STATUS (im_x) = (MP_T) INIT_MASK; } //! @brief OP = = (LONG COMPLEX, LONG COMPLEX) BOOL void genie_eq_mp_complex (NODE_T * p) { int digs = DIGITSC (LHS_MODE (p)), size = SIZEC (LHS_MODE (p)); ADDR_T pop_sp = A68_SP; 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, digs); (void) sub_mp (p, a, a, c, digs); A68_SP = pop_sp; DECREMENT_STACK_POINTER (p, 4 * size); PUSH_VALUE (p, (BOOL_T) (MP_DIGIT (a, 1) == 0 && MP_DIGIT (b, 1) == 0), A68_BOOL); } //! @brief OP /= = (LONG COMPLEX, LONG COMPLEX) BOOL void genie_ne_mp_complex (NODE_T * p) { int digs = DIGITSC (LHS_MODE (p)), size = SIZEC (LHS_MODE (p)); ADDR_T pop_sp = A68_SP; 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, digs); (void) sub_mp (p, a, a, c, digs); A68_SP = pop_sp; DECREMENT_STACK_POINTER (p, 4 * size); PUSH_VALUE (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 void genie_plusab_mp_complex (NODE_T * p) { MOID_T *mode = LHS_MODE (p); genie_f_and_becomes (p, mode, genie_add_mp_complex); } //! @brief OP -:= = (REF LONG COMPLEX, LONG COMPLEX) REF LONG COMPLEX void genie_minusab_mp_complex (NODE_T * p) { MOID_T *mode = LHS_MODE (p); genie_f_and_becomes (p, mode, genie_sub_mp_complex); } //! @brief OP *:= = (REF LONG COMPLEX, LONG COMPLEX) REF LONG COMPLEX void genie_timesab_mp_complex (NODE_T * p) { MOID_T *mode = LHS_MODE (p); genie_f_and_becomes (p, mode, genie_mul_mp_complex); } //! @brief OP /:= = (REF LONG COMPLEX, LONG COMPLEX) REF LONG COMPLEX void genie_divab_mp_complex (NODE_T * p) { MOID_T *mode = LHS_MODE (p); genie_f_and_becomes (p, mode, genie_div_mp_complex); } //! @brief PROC LONG REAL next long random void genie_long_next_random (NODE_T * p) { // This is 'real width' precision only. genie_next_random (p); genie_lengthen_real_to_mp (p); if (MOID (p) == M_LONG_LONG_REAL) { genie_lengthen_mp_to_long_mp (p); } } //! @brief PROC (LONG REAL) LONG REAL long void genie_csc_mp (NODE_T * p) { C_L_FUNCTION (p, csc_mp); } //! @brief PROC (LONG REAL) LONG REAL long void genie_acsc_mp (NODE_T * p) { C_L_FUNCTION (p, acsc_mp); } //! @brief PROC (LONG REAL) LONG REAL long void genie_sec_mp (NODE_T * p) { C_L_FUNCTION (p, sec_mp); } //! @brief PROC (LONG REAL) LONG REAL long void genie_asec_mp (NODE_T * p) { C_L_FUNCTION (p, asec_mp); } //! @brief PROC (LONG REAL) LONG REAL long void genie_cot_mp (NODE_T * p) { C_L_FUNCTION (p, cot_mp); } //! @brief PROC (LONG REAL) LONG REAL long void genie_acot_mp (NODE_T * p) { C_L_FUNCTION (p, acot_mp); } //! @brief PROC (LONG REAL) LONG REAL long void genie_sindg_mp (NODE_T * p) { C_L_FUNCTION (p, sindg_mp); } //! @brief PROC (LONG REAL) LONG REAL long void genie_cosdg_mp (NODE_T * p) { C_L_FUNCTION (p, cosdg_mp); } //! @brief PROC (LONG REAL) LONG REAL long void genie_tandg_mp (NODE_T * p) { C_L_FUNCTION (p, tandg_mp); } //! @brief PROC (LONG REAL) LONG REAL long void genie_cotdg_mp (NODE_T * p) { C_L_FUNCTION (p, cotdg_mp); } //! @brief PROC (LONG REAL) LONG REAL long void genie_asindg_mp (NODE_T * p) { C_L_FUNCTION (p, asindg_mp); } //! @brief PROC (LONG REAL) LONG REAL long void genie_acosdg_mp (NODE_T * p) { C_L_FUNCTION (p, acosdg_mp); } //! @brief PROC (LONG REAL) LONG REAL long void genie_atandg_mp (NODE_T * p) { C_L_FUNCTION (p, atandg_mp); } //! @brief PROC (LONG REAL) LONG REAL long void genie_acotdg_mp (NODE_T * p) { C_L_FUNCTION (p, acotdg_mp); } //! @brief PROC (LONG REAL, LONG REAL) LONG REAL long arctan2 void genie_atan2dg_mp (NODE_T * p) { int digs = DIGITS (MOID (p)), size = SIZE (MOID (p)); MP_T *y = (MP_T *) STACK_OFFSET (-size); MP_T *x = (MP_T *) STACK_OFFSET (-2 * size); PRELUDE_ERROR (atan2dg_mp (p, x, y, x, digs) == NaN_MP, p, ERROR_INVALID_ARGUMENT, MOID (p)); A68_SP -= size; MP_STATUS (x) = (MP_T) INIT_MASK; } //! @brief PROC (LONG REAL) LONG REAL long void genie_sinpi_mp (NODE_T * p) { C_L_FUNCTION (p, sinpi_mp); } //! @brief PROC (LONG REAL) LONG REAL long void genie_cospi_mp (NODE_T * p) { C_L_FUNCTION (p, cospi_mp); } //! @brief PROC (LONG REAL) LONG REAL long void genie_cotpi_mp (NODE_T * p) { C_L_FUNCTION (p, cotpi_mp); } //! @brief PROC (LONG REAL) LONG REAL long void genie_tanpi_mp (NODE_T * p) { C_L_FUNCTION (p, tanpi_mp); } algol68g-3.1.2/src/a68g/heap.c0000644000175000017500000005531614361065320012510 00000000000000//! @file heap.c //! @author J. Marcel van der Veer // //! @section Copyright // // This file is part of Algol68G - an Algol 68 compiler-interpreter. // Copyright 2001-2023 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 . // 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-collect is simple but since it walks recursive structures, it could // exhaust the C-stack (segment violation). A rough check is in place. // // 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. // // 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 A68G's approach differs from the // CDC ALGOL 68 approach that put all generators in the heap. // // Note that part of memory is called 'COMMON'. This is meant for future extension // where a68g would need to point to external objects. The adressing scheme is that // of a HEAP pointer - handle pointer + offset. #include "a68g.h" #include "a68g-genie.h" #include "a68g-frames.h" #include "a68g-prelude.h" #include "a68g-mp.h" #include "a68g-double.h" #include "a68g-parser.h" #include "a68g-transput.h" #define DEF_NODE(p) (NEXT_NEXT (NODE (TAX (p)))) //! @brief PROC VOID gc heap void genie_gc_heap (NODE_T * p) { gc_heap (p, A68_FP); } //! @brief PROC VOID preemptive gc heap void genie_preemptive_gc_heap (NODE_T * p) { if (A68_GC (preemptive)) { gc_heap ((NODE_T *) (p), A68_FP); } } //! @brief INT blocks void genie_block (NODE_T * p) { PUSH_VALUE (p, 0, A68_INT); } //! @brief INT garbage collections void genie_garbage_collections (NODE_T * p) { PUSH_VALUE (p, A68_GC (sweeps), A68_INT); } //! @brief INT garbage refused void genie_garbage_refused (NODE_T * p) { PUSH_VALUE (p, A68_GC (refused), A68_INT); } //! @brief LONG INT garbage freed void genie_garbage_freed (NODE_T * p) { PUSH_VALUE (p, A68_GC (total), A68_INT); } //! @brief REAL garbage seconds void genie_garbage_seconds (NODE_T * p) { // Note that this timing is a rough cut. PUSH_VALUE (p, A68_GC (seconds), A68_REAL); } //! @brief Size available for an object in the heap. unt heap_available (void) { return A68 (heap_size) - A68_HP; } //! @brief Initialise heap management. void genie_init_heap (NODE_T * p) { (void) p; if (A68_HEAP == NO_BYTE) { diagnostic (A68_RUNTIME_ERROR, TOP_NODE (&A68_JOB), ERROR_OUT_OF_CORE); exit_genie (TOP_NODE (&A68_JOB), A68_RUNTIME_ERROR); } if (A68_HANDLES == NO_BYTE) { diagnostic (A68_RUNTIME_ERROR, TOP_NODE (&A68_JOB), ERROR_OUT_OF_CORE); exit_genie (TOP_NODE (&A68_JOB), A68_RUNTIME_ERROR); } A68_GC (seconds) = 0; A68_GC (total) = 0; A68_GC (sweeps) = 0; A68_GC (refused) = 0; A68_GC (preemptive) = A68_FALSE; ABEND (A68 (fixed_heap_pointer) >= (A68 (heap_size) - MIN_MEM_SIZE), ERROR_OUT_OF_CORE, __func__); A68_HP = A68 (fixed_heap_pointer); A68 (heap_is_fluid) = A68_FALSE; // Assign handle space. A68_HANDLE *z = (A68_HANDLE *) A68_HANDLES; A68_GC (available_handles) = z; A68_GC (busy_handles) = NO_HANDLE; int N = (unt) A68 (handle_pool_size) / SIZE_ALIGNED (A68_HANDLE); A68_GC (free_handles) = N; A68_GC (max_handles) = N; for (int k = 0; k < N; k++) { STATUS (&(z[k])) = NULL_MASK; POINTER (&(z[k])) = NO_BYTE; SIZE (&(z[k])) = 0; NEXT (&z[k]) = (k == N - 1 ? NO_HANDLE : &z[k + 1]); PREVIOUS (&z[k]) = (k == 0 ? NO_HANDLE : &z[k - 1]); } } //! @brief Whether mode must be coloured. BOOL_T moid_needs_colouring (MOID_T * m) { if (IS_REF (m)) { return A68_TRUE; } else if (IS (m, PROC_SYMBOL)) { return A68_TRUE; } else if (IS_FLEX (m) || IS_ROW (m)) { return A68_TRUE; } else if (IS_STRUCT (m) || IS_UNION (m)) { 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. 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. 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_REF (m)) { // 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 (IF_ROW (m)) { // 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);. (void) tup; } } else if (IS_STRUCT (m)) { // STRUCTures - colour fields. PACK_T *p = PACK (m); for (; p != NO_PACK; FORWARD (p)) { colour_object (&item[OFFSET (p)], MOID (p)); } } else if (IS_UNION (m)) { // 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 (M_BOOL)], MOID (s)); } u = &(u[SIZE (M_BOOL) + SIZE (MOID (s))]); } // STATUS_CLEAR (LOCALE (z), COOKIE_MASK);. } } else if (m == M_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. 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. void defragment_heap (void) { A68_HANDLE *z; // Free handles. z = A68_GC (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) { A68_GC (busy_handles) = NEXT (z); } else { NEXT (PREVIOUS (z)) = NEXT (z); } if (NEXT (z) != NO_HANDLE) { PREVIOUS (NEXT (z)) = PREVIOUS (z); } NEXT (z) = A68_GC (available_handles); PREVIOUS (z) = NO_HANDLE; if (NEXT (z) != NO_HANDLE) { PREVIOUS (NEXT (z)) = z; } A68_GC (available_handles) = z; STATUS_CLEAR (z, ALLOCATED_MASK); A68_GC (freed) += SIZE (z); A68_GC (free_handles)++; z = y; } else { FORWARD (z); } } // There can be no uncoloured allocated handle. for (z = A68_GC (busy_handles); z != NO_HANDLE; FORWARD (z)) { ABEND (!(STATUS_TEST (z, COLOUR_MASK)) && !(STATUS_TEST (z, BLOCK_GC_MASK)), ERROR_INTERNAL_CONSISTENCY, __func__); } // Defragment the heap. A68_HP = A68 (fixed_heap_pointer); for (z = A68_GC (busy_handles); z != NO_HANDLE && NEXT (z) != NO_HANDLE; FORWARD (z)) { ; } for (; z != NO_HANDLE; BACKWARD (z)) { BYTE_T *dst = HEAP_ADDRESS (A68_HP); if (dst != POINTER (z)) { MOVE (dst, POINTER (z), (unt) SIZE (z)); } STATUS_CLEAR (z, (COLOUR_MASK | COOKIE_MASK)); POINTER (z) = dst; A68_HP += (SIZE (z)); ABEND (A68_HP % A68_ALIGNMENT != 0, ERROR_ALIGNMENT, __func__); } } //! @brief Clean up garbage and defragment the heap. void gc_heap (NODE_T * p, ADDR_T fp) { // Must start with fp = current frame_pointer. A68_HANDLE *z; REAL_T t0, t1; #if defined (BUILD_PARALLEL_CLAUSE) if (OTHER_THREAD (FRAME_THREAD_ID (A68_FP), A68_PAR (main_thread_id))) { A68_GC (refused)++; return; } #endif // Take no risk when intermediate results are on the stack. if (A68_SP != A68 (stack_start)) { A68_GC (refused)++; return; } // Give it a whirl then. t0 = seconds (); // Unfree handles are subject to inspection. // Release them all before colouring. for (z = A68_GC (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. A68_GC (freed) = 0; defragment_heap (); // Stats and logging. A68_GC (total) += A68_GC (freed); A68_GC (sweeps)++; A68_GC (preemptive) = A68_FALSE; t1 = seconds (); // C optimiser can make last digit differ, so next condition is // needed to determine a positive time difference if ((t1 - t0) > ((REAL_T) A68 (clock_res) / 2.0)) { A68_GC (seconds) += (t1 - t0); } else { A68_GC (seconds) += ((REAL_T) A68 (clock_res) / 2.0); } // Call the event handler. genie_call_event_routine (p, M_PROC_VOID, &A68 (on_gc_event), A68_SP, A68_FP); } //! @brief Yield a handle that will point to a block in the heap. A68_HANDLE *give_handle (NODE_T * p, MOID_T * a68m) { if (A68_GC (available_handles) != NO_HANDLE) { A68_HANDLE *x = A68_GC (available_handles); A68_GC (available_handles) = NEXT (x); if (A68_GC (available_handles) != NO_HANDLE) { PREVIOUS (A68_GC (available_handles)) = NO_HANDLE; } STATUS (x) = ALLOCATED_MASK; POINTER (x) = NO_BYTE; SIZE (x) = 0; MOID (x) = a68m; NEXT (x) = A68_GC (busy_handles); PREVIOUS (x) = NO_HANDLE; if (NEXT (x) != NO_HANDLE) { PREVIOUS (NEXT (x)) = x; } A68_GC (busy_handles) = x; A68_GC (free_handles)--; return x; } else { // Do not auto-GC!. diagnostic (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. A68_REF heap_generator (NODE_T * p, MOID_T * mode, int size) { // Align. ABEND (size < 0, ERROR_INVALID_SIZE, __func__); size = A68_ALIGN (size); // Now give it. if (heap_available () >= size) { A68_HANDLE *x; A68_REF z; STATUS (&z) = (STATUS_MASK_T) (INIT_MASK | IN_HEAP_MASK); OFFSET (&z) = 0; x = give_handle (p, mode); SIZE (x) = size; POINTER (x) = HEAP_ADDRESS (A68_HP); FILL (POINTER (x), 0, size); REF_SCOPE (&z) = PRIMAL_SCOPE; REF_HANDLE (&z) = x; ABEND (((long) ADDRESS (&z)) % A68_ALIGNMENT != 0, ERROR_ALIGNMENT, __func__); A68_HP += size; REAL_T _f_ = (REAL_T) A68_HP / (REAL_T) A68 (heap_size); REAL_T _g_ = (REAL_T) (A68_GC (max_handles) - A68_GC (free_handles)) / (REAL_T) A68_GC (max_handles); if (_f_ > DEFAULT_PREEMPTIVE || _g_ > DEFAULT_PREEMPTIVE) { A68_GC (preemptive) = A68_TRUE; } return z; } else { // Do not auto-GC!. diagnostic (A68_RUNTIME_ERROR, p, ERROR_OUT_OF_CORE); exit_genie (p, A68_RUNTIME_ERROR); return nil_ref; } } // Following implements the generator. //! @brief Whether a moid needs work in allocation. BOOL_T mode_needs_allocation (MOID_T * m) { if (IS_UNION (m)) { return A68_FALSE; } else { return HAS_ROWS (m); } } //! @brief Prepare bounds. 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_VALUE (p, 1, A68_INT); } EXECUTE_UNIT (p); } } } //! @brief Prepare bounds for a row. 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. 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. 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. 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_STRUCT (p)) { BYTE_T *faddr = addr; genie_generator_struct (SUB_NEXT (p), &faddr, cur_sp); return; } else if (IS_FLEX (p)) { 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, DESCRIPTOR_SIZE (dim)); GET_DESCRIPTOR (arr, tup, &desc); for (k = 0; k < dim; k++) { CHECK_INIT (p, INITIALISED ((A68_INT *) bounds), M_INT); LWB (&tup[k]) = VALUE ((A68_INT *) bounds); bounds += SIZE (M_INT); CHECK_INIT (p, INITIALISED ((A68_INT *) bounds), M_INT); UPB (&tup[k]) = VALUE ((A68_INT *) bounds); bounds += SIZE (M_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 (M_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. void genie_generator_internal (NODE_T * p, MOID_T * ref_mode, TAG_T * tag, LEAP_T leap, ADDR_T sp) { // Set up a REF MODE object, either in the stack or in the heap. MOID_T *mode = SUB (ref_mode); A68_REF name = nil_ref; if (leap == LOC_SYMBOL) { STATUS (&name) = (STATUS_MASK_T) (INIT_MASK | IN_FRAME_MASK); REF_HANDLE (&name) = (A68_HANDLE *) & nil_handle; OFFSET (&name) = A68_FP + FRAME_INFO_SIZE + OFFSET (tag); REF_SCOPE (&name) = A68_FP; } 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) = A68_FP; } 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, __func__); } 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. PROP_T genie_generator (NODE_T * p) { PROP_T self; ADDR_T pop_sp = A68_SP; 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); A68_SP = pop_sp; PUSH_REF (p, z); UNIT (&self) = genie_generator; SOURCE (&self) = p; return self; } // Control of C heap //! @brief Discard_heap. void discard_heap (void) { if (A68_HEAP != NO_BYTE) { a68_free (A68_HEAP); } A68 (fixed_heap_pointer) = 0; A68 (temp_heap_pointer) = 0; } algol68g-3.1.2/src/a68g/sounds.c0000644000175000017500000004667414361065320013115 00000000000000//! @file sounds.c //! @author J. Marcel van der Veer // //! @section Copyright // // This file is part of Algol68G - an Algol 68 compiler-interpreter. // Copyright 2001-2023 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" #include "a68g-genie.h" #include "a68g-prelude.h" #include "a68g-mp.h" #include "a68g-physics.h" #include "a68g-numbers.h" #include "a68g-optimiser.h" #include "a68g-double.h" // Implementation of 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 unt pow256[] = { 1, 256, 65536, 16777216 }; //! @brief Test bits per sample. void test_bits_per_sample (NODE_T * p, unt bps) { if (bps <= 0 || bps > 24) { diagnostic (A68_RUNTIME_ERROR, p, ERROR_SOUND_INTERNAL, M_SOUND, "unsupported number of bits per sample"); exit_genie (p, A68_RUNTIME_ERROR); } } //! @brief Code string into big-endian unt. unt code_string (NODE_T * p, char *s, int n) { unt v; int k, m; if (n > MAX_BYTES) { diagnostic (A68_RUNTIME_ERROR, p, ERROR_SOUND_INTERNAL, M_SOUND, "too long word length"); exit_genie (p, A68_RUNTIME_ERROR); } for (k = 0, m = n - 1, v = 0; k < n; k++, m--) { v += ((unt) s[k]) * pow256[m]; } return v; } //! @brief Code unt into string. char *code_unt (NODE_T * p, unt 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 char *format_category (unt 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. unt read_riff_item (NODE_T * p, FILE_T fd, int n, BOOL_T little) { unt v, z; int k, m, r; if (n > MAX_BYTES) { diagnostic (A68_RUNTIME_ERROR, p, ERROR_SOUND_INTERNAL, M_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; errno = 0; r = (int) io_read (fd, &z, (size_t) 1); if (r != 1 || errno != 0) { diagnostic (A68_RUNTIME_ERROR, p, ERROR_SOUND_INTERNAL, M_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; errno = 0; r = (int) io_read (fd, &z, (size_t) 1); if (r != 1 || errno != 0) { diagnostic (A68_RUNTIME_ERROR, p, ERROR_SOUND_INTERNAL, M_SOUND, "error while reading file"); exit_genie (p, A68_RUNTIME_ERROR); } v += z * pow256[m]; } } return v; } //! @brief Read sound from file. void read_sound (NODE_T * p, A68_REF ref_file, A68_SOUND * w) { A68_FILE *f = FILE_DEREF (&ref_file); int r; unt fmt_cat; unt 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 (A68_RUNTIME_ERROR, p, ERROR_SOUND_INTERNAL, M_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 (A68_RUNTIME_ERROR, p, ERROR_SOUND_INTERNAL_STRING, M_SOUND, "file format is not \"WAVE\" but", code_unt (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 (A68_RUNTIME_ERROR, p, ERROR_SOUND_INTERNAL_STRING, M_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) / (unt) A68_SOUND_BYTES (w); DATA (w) = heap_generator (p, M_SOUND_DATA, (int) subchunk2size); r = (int) io_read (FD (f), ADDRESS (&(DATA (w))), subchunk2size); if (r != (int) subchunk2size) { diagnostic (A68_RUNTIME_ERROR, p, ERROR_SOUND_INTERNAL, M_SOUND, "cannot read all of the data"); exit_genie (p, A68_RUNTIME_ERROR); } data_read = A68_TRUE; } else { diagnostic (A68_RUNTIME_ERROR, p, ERROR_SOUND_INTERNAL_STRING, M_SOUND, "chunk is", code_unt (p, z)); exit_genie (p, A68_RUNTIME_ERROR); } } (void) blockalign; (void) byterate; (void) chunksize; (void) subchunk2size; STATUS (w) = INIT_MASK; } //! @brief Write RIFF item. void write_riff_item (NODE_T * p, FILE_T fd, unt z, int n, BOOL_T little) { int k, r; unt char y[MAX_BYTES]; if (n > MAX_BYTES) { diagnostic (A68_RUNTIME_ERROR, p, ERROR_SOUND_INTERNAL, M_SOUND, "too long word length"); exit_genie (p, A68_RUNTIME_ERROR); } for (k = 0; k < n; k++) { y[k] = (unt 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 (A68_RUNTIME_ERROR, p, ERROR_SOUND_INTERNAL, M_SOUND, "error while writing file"); exit_genie (p, A68_RUNTIME_ERROR); } } } } //! @brief Write sound to file. void write_sound (NODE_T * p, A68_REF ref_file, A68_SOUND * w) { A68_FILE *f = FILE_DEREF (&ref_file); int r; unt blockalign = NUM_CHANNELS (w) * (unt) (A68_SOUND_BYTES (w)); unt byterate = SAMPLE_RATE (w) * blockalign; unt subchunk2size = NUM_SAMPLES (w) * blockalign; unt 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 (A68_RUNTIME_ERROR, p, ERROR_SOUND_INTERNAL, M_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 (A68_RUNTIME_ERROR, p, ERROR_SOUND_INTERNAL, M_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 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) = (unt) (VALUE (&num_samples)); NUM_CHANNELS (&w) = (unt) (VALUE (&num_channels)); SAMPLE_RATE (&w) = (unt) (VALUE (&sample_rate)); BITS_PER_SAMPLE (&w) = (unt) (VALUE (&bits_per_sample)); test_bits_per_sample (p, BITS_PER_SAMPLE (&w)); DATA_SIZE (&w) = (unt) A68_SOUND_DATA_SIZE (&w); DATA (&w) = heap_generator (p, M_SOUND_DATA, (int) DATA_SIZE (&w) * sizeof (unt)); STATUS (&w) = INIT_MASK; PUSH_OBJECT (p, w, A68_SOUND); } //! @brief PROC get sound = (SOUND w, INT channel, sample) INT 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 (A68_RUNTIME_ERROR, p, ERROR_SOUND_INTERNAL, M_SOUND, "channel index out of range"); exit_genie (p, A68_RUNTIME_ERROR); } if (!(VALUE (&sample) >= 1 && VALUE (&sample) <= (int) NUM_SAMPLES (&w))) { diagnostic (A68_RUNTIME_ERROR, p, ERROR_SOUND_INTERNAL, M_SOUND, "sample index out of range"); exit_genie (p, A68_RUNTIME_ERROR); } if (IS_NIL (DATA (&w))) { diagnostic (A68_RUNTIME_ERROR, p, ERROR_SOUND_INTERNAL, M_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, __func__); 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_VALUE (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 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 (A68_RUNTIME_ERROR, p, ERROR_SOUND_INTERNAL, M_SOUND, "channel index out of range"); exit_genie (p, A68_RUNTIME_ERROR); } if (!(VALUE (&sample) >= 1 && VALUE (&sample) <= (int) NUM_SAMPLES (&w))) { diagnostic (A68_RUNTIME_ERROR, p, ERROR_SOUND_INTERNAL, M_SOUND, "sample index out of range"); exit_genie (p, A68_RUNTIME_ERROR); } if (IS_NIL (DATA (&w))) { diagnostic (A68_RUNTIME_ERROR, p, ERROR_SOUND_INTERNAL, M_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, __func__); 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 void genie_sound_samples (NODE_T * p) { A68_SOUND w; POP_OBJECT (p, &w, A68_SOUND); PUSH_VALUE (p, (int) (NUM_SAMPLES (&w)), A68_INT); } //! @brief OP RATE = (SOUND) INT void genie_sound_rate (NODE_T * p) { A68_SOUND w; POP_OBJECT (p, &w, A68_SOUND); PUSH_VALUE (p, (int) (SAMPLE_RATE (&w)), A68_INT); } //! @brief OP CHANNELS = (SOUND) INT void genie_sound_channels (NODE_T * p) { A68_SOUND w; POP_OBJECT (p, &w, A68_SOUND); PUSH_VALUE (p, (int) (NUM_CHANNELS (&w)), A68_INT); } //! @brief OP RESOLUTION = (SOUND) INT void genie_sound_resolution (NODE_T * p) { A68_SOUND w; POP_OBJECT (p, &w, A68_SOUND); PUSH_VALUE (p, (int) (BITS_PER_SAMPLE (&w)), A68_INT); } algol68g-3.1.2/src/a68g/torrix.c0000644000175000017500000017275614361065320013132 00000000000000//! @file torrix.c //! @author J. Marcel van der Veer // //! @section Copyright // // This file is part of Algol68G - an Algol 68 compiler-interpreter. // Copyright 2001-2023 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" #include "a68g-genie.h" #include "a68g-prelude.h" //! @brief Push description for diagonal of square matrix. 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_REF (MOID (p))); 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 (A68_RUNTIME_ERROR, p, ERROR_NO_SQUARE_MATRIX, m); exit_genie (p, A68_RUNTIME_ERROR); } if (ABS (k) >= ROW_SIZE (tup1)) { diagnostic (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, DESCRIPTOR_SIZE (1)); 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. 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_REF (MOID (p))); 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, DESCRIPTOR_SIZE (2)); 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. 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_REF (MOID (p))); 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 (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, DESCRIPTOR_SIZE (2)); 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. 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_REF (MOID (p))); 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, DESCRIPTOR_SIZE (2)); 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; } #if defined (HAVE_GSL) static NODE_T *error_node = NO_NODE; //! @brief Set permutation vector element - function fails in gsl. 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. void torrix_error_handler (const char *reason, const char *file, int line, int gsl_errno) { if (line != 0) { ASSERT (snprintf (A68 (edit_line), SNPRINTF_SIZE, "%s in line %d of file %s", reason, line, file) >= 0); } else { ASSERT (snprintf (A68 (edit_line), SNPRINTF_SIZE, "%s", reason) >= 0); } diagnostic (A68_RUNTIME_ERROR, error_node, ERROR_TORRIX, A68 (edit_line), gsl_strerror (gsl_errno)); exit_genie (error_node, A68_RUNTIME_ERROR); } //! @brief Detect math errors, mainly in BLAS functions. 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. 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, M_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), M_INT); gsl_permutation_set (v, (size_t) k, (size_t) VALUE (x)); } } return v; } //! @brief Push gsl_permutation on the stack as [] INT. 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)); NEW_ROW_1D (desc, row, arr, tup, M_ROW_INT, M_INT, len); 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. 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, M_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), M_REAL); gsl_vector_set (v, (size_t) k, VALUE (x)); } } return v; } //! @brief Push gsl_vector on the stack as [] REAL. 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)); NEW_ROW_1D (desc, row, arr, tup, M_ROW_REAL, M_REAL, len); 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 (p, VALUE (x)); } PUSH_REF (p, desc); } //! @brief Pop [,] REAL on the stack as gsl_matrix. 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, M_ROW_ROW_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), M_REAL); gsl_matrix_set (a, (size_t) k1, (size_t) k2, VALUE (x)); } } } return a; } //! @brief Push gsl_matrix on the stack as [,] REAL. 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, M_ROW_ROW_REAL, DESCRIPTOR_SIZE (2)); row = heap_generator (p, M_ROW_ROW_REAL, len1 * len2 * SIZE (M_REAL)); DIM (&arr) = 2; MOID (&arr) = M_REAL; ELEM_SIZE (&arr) = SIZE (M_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 (p, VALUE (x)); } } PUSH_REF (p, desc); } //! @brief Pop [] COMPLEX on the stack as gsl_vector_complex. 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, M_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 (M_REAL)); gsl_complex z; CHECK_INIT (p, INITIALISED (re), M_COMPLEX); CHECK_INIT (p, INITIALISED (im), M_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. 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)); NEW_ROW_1D (desc, row, arr, tup, M_ROW_COMPLEX, M_COMPLEX, len); 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 (M_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 (p, VALUE (re), VALUE (im)); } PUSH_REF (p, desc); } //! @brief Pop [,] COMPLEX on the stack as gsl_matrix_complex. 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, M_ROW_ROW_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 (M_REAL)); gsl_complex z; CHECK_INIT (p, INITIALISED (re), M_COMPLEX); CHECK_INIT (p, INITIALISED (im), M_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. 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, M_ROW_ROW_COMPLEX, DESCRIPTOR_SIZE (2)); row = heap_generator (p, M_ROW_ROW_COMPLEX, len1 * len2 * 2 * SIZE (M_REAL)); DIM (&arr) = 2; MOID (&arr) = M_COMPLEX; ELEM_SIZE (&arr) = 2 * SIZE (M_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 (M_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 (p, VALUE (re), VALUE (im)); } } PUSH_REF (p, desc); } //! @brief Generically perform operation and assign result (+:=, -:=, ...) . void op_ab_torrix (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_T) (INIT_MASK | IN_STACK_MASK); OFFSET (&src) = A68_SP - parm_size; (*op) (p); if (IS_REF (m)) { genie_store (p, SUB (m), &dst, &src); } else { ABEND (A68_TRUE, ERROR_INTERNAL_CONSISTENCY, __func__); } *save = dst; } //! @brief PROC vector echo = ([] REAL) [] REAL 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 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 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 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 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 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 void genie_matrix_transpose (NODE_T * p) { gsl_error_handler_t *save_handler = gsl_set_error_handler (torrix_error_handler); gsl_matrix *a, *t; int rc; error_node = p; a = pop_matrix (p, A68_TRUE); t = gsl_matrix_alloc (SIZE2(a), SIZE1(a)); rc = gsl_matrix_transpose_memcpy (t, a); torrix_test_error (rc); push_matrix (p, t); gsl_matrix_free (a); gsl_matrix_free (t); (void) gsl_set_error_handler (save_handler); } //! @brief OP T = ([,] COMPLEX) [,] COMPLEX 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, *t; int rc; error_node = p; a = pop_matrix_complex (p, A68_TRUE); t = gsl_matrix_complex_alloc (SIZE2(a), SIZE1(a)); rc = gsl_matrix_complex_transpose_memcpy (t, a); torrix_test_error (rc); push_matrix_complex (p, a); gsl_matrix_complex_free (a); gsl_matrix_complex_free (t); (void) gsl_set_error_handler (save_handler); } //! @brief OP INV = ([,] REAL) [,] REAL 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, sign; error_node = p; u = pop_matrix (p, A68_TRUE); q = gsl_permutation_alloc (SIZE1 (u)); rc = gsl_linalg_LU_decomp (u, q, &sign); 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 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, sign; error_node = p; u = pop_matrix_complex (p, A68_TRUE); q = gsl_permutation_alloc (SIZE1 (u)); rc = gsl_linalg_complex_LU_decomp (u, q, &sign); 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 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, sign; error_node = p; u = pop_matrix (p, A68_TRUE); q = gsl_permutation_alloc (SIZE1 (u)); rc = gsl_linalg_LU_decomp (u, q, &sign); torrix_test_error (rc); PUSH_VALUE (p, gsl_linalg_LU_det (u, sign), A68_REAL); gsl_matrix_free (u); gsl_permutation_free (q); (void) gsl_set_error_handler (save_handler); } //! @brief OP DET = ([,] COMPLEX) COMPLEX 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, sign; 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, &sign); torrix_test_error (rc); det = gsl_linalg_complex_LU_det (u, sign); PUSH_VALUE (p, GSL_REAL (det), A68_REAL); PUSH_VALUE (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 void genie_matrix_trace (NODE_T * p) { gsl_error_handler_t *save_handler = gsl_set_error_handler (torrix_error_handler); gsl_matrix *a; REAL_T 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_VALUE (p, sum, A68_REAL); gsl_matrix_free (a); (void) gsl_set_error_handler (save_handler); } //! @brief OP TRACE = ([,] COMPLEX) COMPLEX 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_VALUE (p, GSL_REAL (sum), A68_REAL); PUSH_VALUE (p, GSL_IMAG (sum), A68_REAL); gsl_matrix_complex_free (a); (void) gsl_set_error_handler (save_handler); } //! @brief OP - = ([] COMPLEX) [] COMPLEX 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 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 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 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 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_VALUE (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 void genie_vector_ne (NODE_T * p) { genie_vector_eq (p); genie_not_bool (p); } //! @brief OP +:= = (REF [] REAL, [] REAL) REF [] REAL void genie_vector_plusab (NODE_T * p) { op_ab_torrix (p, M_REF_ROW_REAL, M_ROW_REAL, genie_vector_add); } //! @brief OP -:= = (REF [] REAL, [] REAL) REF [] REAL void genie_vector_minusab (NODE_T * p) { op_ab_torrix (p, M_REF_ROW_REAL, M_ROW_REAL, genie_vector_sub); } //! @brief OP + = ([, ] REAL, [, ] REAL) [, ] REAL 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 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 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_VALUE (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 void genie_matrix_ne (NODE_T * p) { genie_matrix_eq (p); genie_not_bool (p); } //! @brief OP +:= = (REF [, ] REAL, [, ] REAL) [, ] REAL void genie_matrix_plusab (NODE_T * p) { op_ab_torrix (p, M_REF_ROW_ROW_REAL, M_ROW_ROW_REAL, genie_matrix_add); } //! @brief OP -:= = (REF [, ] REAL, [, ] REAL) [, ] REAL void genie_matrix_minusab (NODE_T * p) { op_ab_torrix (p, M_REF_ROW_ROW_REAL, M_ROW_ROW_REAL, genie_matrix_sub); } //! @brief OP + = ([] COMPLEX, [] COMPLEX) [] COMPLEX 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 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 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_VALUE (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 void genie_vector_complex_ne (NODE_T * p) { genie_vector_complex_eq (p); genie_not_bool (p); } //! @brief OP +:= = (REF [] COMPLEX, [] COMPLEX) [] COMPLEX void genie_vector_complex_plusab (NODE_T * p) { op_ab_torrix (p, M_REF_ROW_COMPLEX, M_ROW_COMPLEX, genie_vector_complex_add); } //! @brief OP -:= = (REF [] COMPLEX, [] COMPLEX) [] COMPLEX void genie_vector_complex_minusab (NODE_T * p) { op_ab_torrix (p, M_REF_ROW_COMPLEX, M_ROW_COMPLEX, genie_vector_complex_sub); } //! @brief OP + = ([, ] COMPLEX, [, ] COMPLEX) [, ] COMPLEX 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 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 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_VALUE (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 void genie_matrix_complex_ne (NODE_T * p) { genie_matrix_complex_eq (p); genie_not_bool (p); } //! @brief OP +:= = (REF [, ] COMPLEX, [, ] COMPLEX) [, ] COMPLEX void genie_matrix_complex_plusab (NODE_T * p) { op_ab_torrix (p, M_REF_ROW_ROW_COMPLEX, M_ROW_ROW_COMPLEX, genie_matrix_complex_add); } //! @brief OP -:= = (REF [, ] COMPLEX, [, ] COMPLEX) [, ] COMPLEX void genie_matrix_complex_minusab (NODE_T * p) { op_ab_torrix (p, M_REF_ROW_ROW_COMPLEX, M_ROW_ROW_COMPLEX, genie_matrix_complex_sub); } //! @brief OP * = ([] REAL, REAL) [] REAL 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 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 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 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 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 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 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 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 void genie_vector_scale_real_ab (NODE_T * p) { op_ab_torrix (p, M_REF_ROW_REAL, M_REAL, genie_vector_scale_real); } //! @brief OP *:= (REF [, ] REAL, REAL) REF [, ] REAL void genie_matrix_scale_real_ab (NODE_T * p) { op_ab_torrix (p, M_REF_ROW_ROW_REAL, M_REAL, genie_matrix_scale_real); } //! @brief OP *:= (REF [] COMPLEX, COMPLEX) REF [] COMPLEX void genie_vector_complex_scale_complex_ab (NODE_T * p) { op_ab_torrix (p, M_REF_ROW_COMPLEX, M_COMPLEX, genie_vector_complex_scale_complex); } //! @brief OP *:= (REF [, ] COMPLEX, COMPLEX) REF [, ] COMPLEX void genie_matrix_complex_scale_complex_ab (NODE_T * p) { op_ab_torrix (p, M_REF_ROW_ROW_COMPLEX, M_COMPLEX, genie_matrix_complex_scale_complex); } //! @brief OP / = ([] REAL, REAL) [] REAL 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 (A68_RUNTIME_ERROR, p, ERROR_DIVISION_BY_ZERO, M_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 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 (A68_RUNTIME_ERROR, p, ERROR_DIVISION_BY_ZERO, M_ROW_ROW_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 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 (A68_RUNTIME_ERROR, p, ERROR_DIVISION_BY_ZERO, M_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 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 (A68_RUNTIME_ERROR, p, ERROR_DIVISION_BY_ZERO, M_ROW_ROW_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 void genie_vector_div_real_ab (NODE_T * p) { op_ab_torrix (p, M_REF_ROW_REAL, M_REAL, genie_vector_div_real); } //! @brief OP /:= (REF [, ] REAL, REAL) REF [, ] REAL void genie_matrix_div_real_ab (NODE_T * p) { op_ab_torrix (p, M_REF_ROW_ROW_REAL, M_REAL, genie_matrix_div_real); } //! @brief OP /:= (REF [] COMPLEX, COMPLEX) REF [] COMPLEX void genie_vector_complex_div_complex_ab (NODE_T * p) { op_ab_torrix (p, M_REF_ROW_COMPLEX, M_COMPLEX, genie_vector_complex_div_complex); } //! @brief OP /:= (REF [, ] COMPLEX, COMPLEX) REF [, ] COMPLEX void genie_matrix_complex_div_complex_ab (NODE_T * p) { op_ab_torrix (p, M_REF_ROW_ROW_COMPLEX, M_COMPLEX, genie_matrix_complex_div_complex); } //! @brief OP * = ([] REAL, [] REAL) REAL void genie_vector_dot (NODE_T * p) { gsl_error_handler_t *save_handler = gsl_set_error_handler (torrix_error_handler); gsl_vector *u, *v; REAL_T 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_VALUE (p, w, A68_REAL); gsl_vector_free (u); gsl_vector_free (v); (void) gsl_set_error_handler (save_handler); } //! @brief OP * = ([] COMPLEX, [] COMPLEX) COMPLEX 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_VALUE (p, GSL_REAL (w), A68_REAL); PUSH_VALUE (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 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_VALUE (p, gsl_blas_dnrm2 (u), A68_REAL); gsl_vector_free (u); (void) gsl_set_error_handler (save_handler); } //! @brief OP NORM = ([] COMPLEX) COMPLEX 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_VALUE (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 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++) { REAL_T uj = gsl_vector_get (u, (size_t) j); for (k = 0; k < len2; k++) { REAL_T 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 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 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 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 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 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 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 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 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, sign; A68_INT signum; error_node = p; POP_REF (p, &ref_signum); CHECK_REF (p, ref_signum, M_REF_INT); POP_REF (p, &ref_q); CHECK_REF (p, ref_q, M_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, &sign); torrix_test_error (rc); VALUE (&signum) = sign; 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 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_VALUE (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 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 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 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, sign; A68_INT signum; error_node = p; POP_REF (p, &ref_signum); CHECK_REF (p, ref_signum, M_REF_INT); POP_REF (p, &ref_q); CHECK_REF (p, ref_q, M_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, &sign); torrix_test_error (rc); VALUE (&signum) = sign; 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 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_VALUE (p, GSL_REAL (det), A68_REAL); PUSH_VALUE (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 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 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 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, M_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, M_REF_ROW_ROW_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 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) rc; (void) gsl_set_error_handler (save_handler); } //! @brief PROC qr decomp = ([, ] REAL, [] REAL) [, ] REAL 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, M_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 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) rc; (void) gsl_set_error_handler (save_handler); } //! @brief PROC qr ls solve = ([, ] REAL, [] REAL, [] REAL) [] REAL 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) rc; (void) gsl_set_error_handler (save_handler); } //! @brief PROC cholesky decomp = ([, ] REAL) [, ] REAL 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 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) rc; (void) gsl_set_error_handler (save_handler); } #endif algol68g-3.1.2/src/a68g/compiler-inline.c0000644000175000017500000013620114361065320014652 00000000000000//! @file compiler.c //! @author J. Marcel van der Veer // //! @section Copyright // // This file is part of Algol68G - an Algol 68 compiler-interpreter. // Copyright 2001-2023 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" #include "a68g-prelude.h" #include "a68g-genie.h" #include "a68g-listing.h" #include "a68g-mp.h" #include "a68g-optimiser.h" #include "a68g-compiler.h" #include "a68g-parser.h" #include "a68g-transput.h" //! @brief Code an A68 mode. char *inline_mode (MOID_T * m) { if (m == M_INT) { return "A68_INT"; } else if (m == M_REAL) { return "A68_REAL"; } else if (m == M_BOOL) { return "A68_BOOL"; } else if (m == M_CHAR) { return "A68_CHAR"; } else if (m == M_BITS) { return "A68_BITS"; } else if (m == M_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 Compile inline arguments. 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 (A68 (edit_line), SNPRINTF_SIZE, "EXECUTE_UNIT_TRACE (_NODE_ (%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 (&A68_OPT (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 (A68 (edit_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 (A68 (edit_line), SNPRINTF_SIZE, "_STATUS_ (%s) = INIT_MASK;\n", arg)); indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "_VALUE_ (%s) = ", arg)); inline_unit (p, out, L_YIELD); undent (out, ";\n"); } else if (phase == L_YIELD && basic_mode (MOID (p))) { indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "MOVE ((void *) %s, (void *) ", arg)); inline_unit (p, out, L_YIELD); undentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, ", %d);\n", SIZE (MOID (p)))); } } else { inline_arguments (SUB (p), out, phase, size); inline_arguments (NEXT (p), out, phase, size); } } //! @brief Code denotation. void inline_denotation (NODE_T * p, FILE_T out, int phase) { if (phase == L_YIELD) { if (MOID (p) == M_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, M_INT, den, (BYTE_T *) & z) == A68_FALSE) { diagnostic (A68_SYNTAX_ERROR, p, ERROR_IN_DENOTATION, M_INT); } undentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, A68_LD, VALUE (&z))); } else if (MOID (p) == M_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, M_REAL, den, (BYTE_T *) & z) == A68_FALSE) { diagnostic (A68_SYNTAX_ERROR, p, ERROR_IN_DENOTATION, M_REAL); } if (strchr (den, '.') == NO_TEXT && strchr (den, 'e') == NO_TEXT && strchr (den, 'E') == NO_TEXT) { undentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "(REAL_T) %s", den)); } else { undentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "%s", den)); } } else if (MOID (p) == M_BOOL) { undent (out, "(BOOL_T) A68_"); undent (out, NSYMBOL (p)); } else if (MOID (p) == M_CHAR) { if (NSYMBOL (p)[0] == '\'') { undentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "'\\''")); } else if (NSYMBOL (p)[0] == NULL_CHAR) { undentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "NULL_CHAR")); } else if (NSYMBOL (p)[0] == '\\') { undentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "'\\\\'")); } else { undentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "'%c'", (NSYMBOL (p))[0])); } } else if (MOID (p) == M_BITS) { A68_BITS z; NODE_T *s = IS (SUB (p), SHORTETY) ? NEXT_SUB (p) : SUB (p); if (genie_string_to_value_internal (p, M_BITS, NSYMBOL (s), (BYTE_T *) & z) == A68_FALSE) { diagnostic (A68_SYNTAX_ERROR, p, ERROR_IN_DENOTATION, M_BITS); } ASSERT (snprintf (A68 (edit_line), SNPRINTF_SIZE, "(UNSIGNED_T) 0x" A68_LX, VALUE (&z)) >= 0); undent (out, A68 (edit_line)); } } } //! @brief Code widening. 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, "(REAL_T) ("); 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 (&A68_OPT (root_idf), inline_mode (M_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 (A68 (edit_line), SNPRINTF_SIZE, "STATUS_RE (%s) = INIT_MASK;\n", acc)); indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "STATUS_IM (%s) = INIT_MASK;\n", acc)); indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "RE (%s) = (REAL_T) (", acc)); inline_unit (SUB (p), out, L_YIELD); undent (out, ");\n"); indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "IM (%s) = 0.0;\n", acc)); } else if (phase == L_YIELD) { undentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "(A68_REAL *) %s", acc)); } } } //! @brief Code dereferencing of identifier. void inline_dereference_identifier (NODE_T * p, FILE_T out, int phase) { NODE_T *q = stems_from (SUB (p), IDENTIFIER); ABEND (q == NO_NODE, ERROR_INTERNAL_CONSISTENCY, __func__); 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 (&A68_OPT (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 (A68 (edit_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 (A68 (edit_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"); } gen_check_init (p, out, idf); } } 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 (A68 (edit_line), SNPRINTF_SIZE, "_VALUE_ (%s)", idf)); } else if (MOID (p) == M_COMPLEX) { undentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "(A68_REAL *) (%s)", idf)); } else if (basic_mode (MOID (p))) { undent (out, idf); } } } //! @brief Code identifier. 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 = stems_from (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 (A68_STANDENV_PROC (TAX (p))) { return; } else { char idf[NAME_SIZE]; (void) make_name (idf, NSYMBOL (p), "", NUMBER (p)); (void) add_declaration (&A68_OPT (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 (A68_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)); gen_check_init (p, out, idf); } } else if (phase == L_YIELD) { if (A68_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 (A68 (edit_line), SNPRINTF_SIZE, "_VALUE_ (%s)", idf)); } else if (MOID (p) == M_COMPLEX) { undentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "(A68_REAL *) (%s)", idf)); } else if (basic_mode (MOID (p))) { undent (out, idf); } } } } //! @brief Code indexer. void inline_indexer (NODE_T * p, FILE_T out, int phase, INT_T * 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 (A68 (edit_line), SNPRINTF_SIZE, "(SPAN (&%s[" A68_LD "]) * (", tup, (*k))); } else { undentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, " + (SPAN (&%s[" A68_LD "]) * (", tup, (*k))); } inline_unit (p, out, L_YIELD); undentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, ") - SHIFT (&%s[" A68_LD "]))", 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. 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_T 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 (&A68_OPT (root_idf), "A68_REF", 1, idf); (void) add_declaration (&A68_OPT (root_idf), "A68_REF", 0, elm); (void) add_declaration (&A68_OPT (root_idf), "A68_ARRAY", 1, arr); (void) add_declaration (&A68_OPT (root_idf), "A68_TUPLE", 1, tup); (void) add_declaration (&A68_OPT (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 (&A68_OPT (root_idf), "A68_REF", 0, elm); (void) add_declaration (&A68_OPT (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 = stems_from (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 (A68 (edit_line), SNPRINTF_SIZE, "GET_DESCRIPTOR (%s, %s, DEREF (A68_ROW, %s));\n", arr, tup, idf)); } else { ABEND (A68_TRUE, ERROR_INTERNAL_CONSISTENCY, __func__); } 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 (A68 (edit_line), SNPRINTF_SIZE, "%s = ARRAY (%s);\n", elm, arr)); k = 0; inline_indexer (indx, out, L_EXECUTE, &k, NO_TEXT); indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "OFFSET (& %s) += ROW_ELEMENT (%s, ", elm, arr)); k = 0; inline_indexer (indx, out, L_YIELD, &k, tup); undentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, ");\n")); indentf (out, snprintf (A68 (edit_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 (A68 (edit_line), SNPRINTF_SIZE, "_VALUE_ (%s)", drf)); } else if (mode == M_COMPLEX) { undentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "(A68_REAL *) (%s)", drf)); } else if (basic_mode (mode)) { undent (out, drf); } else { ABEND (A68_TRUE, ERROR_INTERNAL_CONSISTENCY, __func__); } } } //! @brief Code slice REF [] MODE -> REF MODE. 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_T 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 (&A68_OPT (root_idf), "A68_REF", 1, idf); (void) add_declaration (&A68_OPT (root_idf), "A68_REF", 0, elm); (void) add_declaration (&A68_OPT (root_idf), "A68_ARRAY", 1, arr); (void) add_declaration (&A68_OPT (root_idf), "A68_TUPLE", 1, tup); (void) add_declaration (&A68_OPT (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 (&A68_OPT (root_idf), "A68_REF", 0, elm); (void) add_declaration (&A68_OPT (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 = stems_from (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 (A68 (edit_line), SNPRINTF_SIZE, "GET_DESCRIPTOR (%s, %s, DEREF (A68_ROW, %s));\n", arr, tup, idf)); } else { ABEND (A68_TRUE, ERROR_INTERNAL_CONSISTENCY, __func__); } 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 (A68 (edit_line), SNPRINTF_SIZE, "%s = ARRAY (%s);\n", elm, arr)); k = 0; inline_indexer (indx, out, L_EXECUTE, &k, NO_TEXT); indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "OFFSET (& %s) += ROW_ELEMENT (%s, ", elm, arr)); k = 0; inline_indexer (indx, out, L_YIELD, &k, tup); undentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, ");\n")); indentf (out, snprintf (A68 (edit_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 (A68 (edit_line), SNPRINTF_SIZE, "(&%s)", elm)); } } //! @brief Code slice [] MODE -> MODE. 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_T 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 (A68 (edit_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 (A68 (edit_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 = stems_from (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 (A68 (edit_line), SNPRINTF_SIZE, "GET_DESCRIPTOR (%s, %s, DEREF (A68_ROW, %s));\n", arr, tup, idf)); } else { indentf (out, snprintf (A68 (edit_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 (A68 (edit_line), SNPRINTF_SIZE, "%s = ARRAY (%s);\n", elm, arr)); k = 0; inline_indexer (indx, out, L_EXECUTE, &k, NO_TEXT); indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "OFFSET (& %s) += ROW_ELEMENT (%s, ", elm, arr)); k = 0; inline_indexer (indx, out, L_YIELD, &k, tup); undentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, ");\n")); indentf (out, snprintf (A68 (edit_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 (A68 (edit_line), SNPRINTF_SIZE, "_VALUE_ (%s)", drf)); } else if (mode == M_COMPLEX) { undentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "(A68_REAL *) (%s)", drf)); } else if (basic_mode (mode)) { undentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "%s", drf)); } else { ABEND (A68_TRUE, ERROR_INTERNAL_CONSISTENCY, __func__); } } } //! @brief Code monadic formula. 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) == M_COMPLEX) { char acc[NAME_SIZE]; (void) make_name (acc, TMP, "", NUMBER (p)); if (phase == L_DECLARE) { (void) add_declaration (&A68_OPT (root_idf), inline_mode (M_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 (A68 (edit_line), SNPRINTF_SIZE, "%s (%s, ", CODE (&monadics[k]), acc)); inline_unit (rhs, out, L_YIELD); undentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, ");\n")); } } } else if (phase == L_YIELD) { undentf (out, snprintf (A68 (edit_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. 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) == M_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 (&A68_OPT (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) == M_COMPLEX) { indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "%s (%s, ", CODE (&dyadics[k]), acc)); } else { indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "%s (& %s, ", CODE (&dyadics[k]), acc)); } inline_unit (lhs, out, L_YIELD); undentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, ", ")); inline_unit (rhs, out, L_YIELD); undentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, ");\n")); } } } else if (phase == L_YIELD) { char acc[NAME_SIZE]; (void) make_name (acc, TMP, "", NUMBER (p)); if (MOID (p) == M_COMPLEX) { undentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "%s", acc)); } else { undentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "_VALUE_ (& %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. 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. void inline_call (NODE_T * p, FILE_T out, int phase) { NODE_T *prim = SUB (p); NODE_T *args = NEXT (prim); NODE_T *idf = stems_from (prim, IDENTIFIER); if (MOID (p) == M_COMPLEX) { char acc[NAME_SIZE]; (void) make_name (acc, TMP, "", NUMBER (p)); if (phase == L_DECLARE) { (void) add_declaration (&A68_OPT (root_idf), inline_mode (M_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 (A68 (edit_line), SNPRINTF_SIZE, "%s (%s, ", CODE (&functions[k]), acc)); inline_single_argument (args, out, L_YIELD); undentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, ");\n")); } } } else if (phase == L_YIELD) { undentf (out, snprintf (A68 (edit_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. 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 (A68 (edit_line), SNPRINTF_SIZE, "PUSH_VALUE (p, ")); inline_unit (SUB (p), out, L_YIELD); undentf (out, snprintf (A68 (edit_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. 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) == M_COMPLEX) { (void) add_declaration (&A68_OPT (root_idf), inline_mode (M_REAL), 1, dsp); } else { (void) add_declaration (&A68_OPT (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) == M_COMPLEX) { indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "%s = (%s *) STACK_TOP;\n", dsp, inline_mode (M_REAL))); } else { indentf (out, snprintf (A68 (edit_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 (A68 (edit_line), SNPRINTF_SIZE, "%s", dsp)); } } //! @brief Code basic closed clause. 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. 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, ERROR_INTERNAL_CONSISTENCY, __func__); } FORWARD (p); if (IS (p, THEN_PART) || IS (p, CHOICE)) { then_part = p; } else { ABEND (A68_TRUE, ERROR_INTERNAL_CONSISTENCY, __func__); } 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. 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 = stems_from (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 (&A68_OPT (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 (&A68_OPT (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 (A68 (edit_line), SNPRINTF_SIZE, "%s = (%s *) & (ADDRESS (%s)[" A68_LU "]);\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 (A68 (edit_line), SNPRINTF_SIZE, "%s = (%s *) & (ADDRESS (%s)[" A68_LU "]);\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 (A68 (edit_line), SNPRINTF_SIZE, "_VALUE_ (%s)", sel)); } else if (SUB_MOID (p) == M_COMPLEX) { undentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "(A68_REAL *) (%s)", sel)); } else if (basic_mode (SUB_MOID (p))) { undent (out, sel); } else { ABEND (A68_TRUE, ERROR_INTERNAL_CONSISTENCY, __func__); } } } //! @brief Code selection. void inline_selection (NODE_T * p, FILE_T out, int phase) { NODE_T *field = SUB (p); NODE_T *sec = NEXT (field); NODE_T *idf = stems_from (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 (&A68_OPT (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 (&A68_OPT (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 (A68 (edit_line), SNPRINTF_SIZE, "%s = (%s *) & (%s[" A68_LU "]);\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 (A68 (edit_line), SNPRINTF_SIZE, "%s = (%s *) & (%s[" A68_LU "]);\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 (A68 (edit_line), SNPRINTF_SIZE, "_VALUE_ (%s)", sel)); } else { ABEND (A68_TRUE, ERROR_INTERNAL_CONSISTENCY, __func__); } } } //! @brief Code selection. 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 = stems_from (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 (&A68_OPT (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 (&A68_OPT (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 (A68 (edit_line), SNPRINTF_SIZE, "%s = *%s;\n", sel, ref)); indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "OFFSET (&%s) += " A68_LU ";\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 (A68 (edit_line), SNPRINTF_SIZE, "(&%s)", sel)); } else { ABEND (A68_TRUE, ERROR_INTERNAL_CONSISTENCY, __func__); } } } //! @brief Code identifier. 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 (&A68_OPT (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. void inline_identity_relation (NODE_T * p, FILE_T out, int phase) { #define GOOD(p) (stems_from (p, IDENTIFIER) != NO_NODE && IS (MOID (stems_from ((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 = stems_from (lhs, IDENTIFIER); NODE_T *ridf = stems_from (rhs, IDENTIFIER); inline_ref_identifier (lidf, out, L_DECLARE); inline_ref_identifier (ridf, out, L_DECLARE); } else if (phase == L_EXECUTE) { NODE_T *lidf = stems_from (lhs, IDENTIFIER); NODE_T *ridf = stems_from (rhs, IDENTIFIER); inline_ref_identifier (lidf, out, L_EXECUTE); inline_ref_identifier (ridf, out, L_EXECUTE); } else if (phase == L_YIELD) { NODE_T *lidf = stems_from (lhs, IDENTIFIER); NODE_T *ridf = stems_from (rhs, IDENTIFIER); if (IS (op, IS_SYMBOL)) { undentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "ADDRESS (")); inline_ref_identifier (lidf, out, L_YIELD); undentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, ") == ADDRESS (")); inline_ref_identifier (ridf, out, L_YIELD); undentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, ")")); } else { undentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "ADDRESS (")); inline_ref_identifier (lidf, out, L_YIELD); undentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, ") != ADDRESS (")); inline_ref_identifier (ridf, out, L_YIELD); undentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, ")")); } } } else if (GOOD (lhs) && stems_from (rhs, NIHIL) != NO_NODE) { if (phase == L_DECLARE) { NODE_T *lidf = stems_from (lhs, IDENTIFIER); inline_ref_identifier (lidf, out, L_DECLARE); } else if (phase == L_EXECUTE) { NODE_T *lidf = stems_from (lhs, IDENTIFIER); inline_ref_identifier (lidf, out, L_EXECUTE); } else if (phase == L_YIELD) { NODE_T *lidf = stems_from (lhs, IDENTIFIER); if (IS (op, IS_SYMBOL)) { indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "IS_NIL (*")); inline_ref_identifier (lidf, out, L_YIELD); undentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, ")")); } else { indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "!IS_NIL (*")); inline_ref_identifier (lidf, out, L_YIELD); undentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, ")")); } } } #undef GOOD } //! @brief Code unit. void inline_unit (NODE_T * p, FILE_T out, int phase) { if (p == NO_NODE) { return; } else if (constant_unit (p) && stems_from (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) && stems_from (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, ERROR_INTERNAL_CONSISTENCY, __func__); } } else if (IS (p, DEREFERENCING) && stems_from (SUB (p), SLICE) != NO_NODE) { inline_dereference_slice (SUB (p), out, phase); } else if (IS (p, DEREFERENCING) && stems_from (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, ERROR_INTERNAL_CONSISTENCY, __func__); } } 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); } } algol68g-3.1.2/src/a68g/single-gsl.c0000644000175000017500000005640214361065320013634 00000000000000//! @file single-gsl.c //! @author J. Marcel van der Veer // //! @section Copyright // // This file is part of Algol68G - an Algol 68 compiler-interpreter. // Copyright 2001-2023 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" #include "a68g-genie.h" #include "a68g-prelude.h" #include "a68g-prelude-gsl.h" #include "a68g-double.h" #include "a68g-numbers.h" #if defined (HAVE_GSL) #define PROC_RR_R(p, g, f)\ void g (NODE_T *p) {\ A68 (f_entry) = p;\ A68_REAL *x;\ int status;\ POP_OPERAND_ADDRESS (p, x, A68_REAL);\ (void) gsl_set_error_handler_off ();\ status = f (& (VALUE (x)));\ MATH_RTE (p, status != 0, M_REAL, (char *) gsl_strerror (status));\ } #define PROC_R_R(p, g, f)\ void g (NODE_T *p) {\ A68 (f_entry) = p;\ 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, M_REAL, (char *) gsl_strerror (status));\ VALUE (x) = VAL (&y);\ } #define PROC_R_R_DBL(p, g, f)\ void g (NODE_T *p) {\ A68 (f_entry) = p;\ 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, M_REAL, (char *) gsl_strerror (status));\ VALUE (x) = VAL (&y);\ } #define PROC_I_R(p, g, f)\ void g (NODE_T *p) {\ A68 (f_entry) = p;\ A68_INT s;\ gsl_sf_result y;\ int status;\ POP_OBJECT (p, &s, A68_INT);\ (void) gsl_set_error_handler_off ();\ status = f (VALUE (&s), &y);\ MATH_RTE (p, status != 0, M_REAL, (char *) gsl_strerror (status));\ PUSH_VALUE (p, VAL (&y), A68_REAL);\ } #define PROC_R_R_R(p, g, f)\ void g (NODE_T *p) {\ A68 (f_entry) = p;\ 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, M_REAL, (char *) gsl_strerror (status));\ VALUE (x) = VAL (&r);\ } #define PROC_I_R_R(p, g, f)\ void g (NODE_T *p) {\ A68 (f_entry) = p;\ A68_INT s;\ A68_REAL x;\ gsl_sf_result r;\ int status;\ POP_OBJECT (p, &x, A68_REAL);\ POP_OBJECT (p, &s, A68_INT);\ (void) gsl_set_error_handler_off ();\ status = f (VALUE (&s), VALUE (&x), &r);\ MATH_RTE (p, status != 0, M_REAL, (char *) gsl_strerror (status));\ PUSH_VALUE (p, VAL (&r), A68_REAL);\ } #define PROC_I_R_R_REVERSED(p, g, f)\ void g (NODE_T *p) {\ A68 (f_entry) = p;\ A68_INT s;\ A68_REAL x;\ gsl_sf_result r;\ int status;\ POP_OBJECT (p, &x, A68_REAL);\ POP_OBJECT (p, &s, A68_INT);\ (void) gsl_set_error_handler_off ();\ status = f (VALUE (&x), VALUE (&s), &r);\ MATH_RTE (p, status != 0, M_REAL, (char *) gsl_strerror (status));\ PUSH_VALUE (p, VAL (&r), A68_REAL);\ } #define PROC_R_R_R_DBL(p, g, f)\ void g (NODE_T *p) {\ A68 (f_entry) = p;\ 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, M_REAL, (char *) gsl_strerror (status));\ VALUE (x) = VAL (&r);\ } #define PROC_R_R_R_R(p, g, f)\ void g (NODE_T *p) {\ A68 (f_entry) = p;\ 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, M_REAL, (char *) gsl_strerror (status));\ VALUE (x) = VAL (&r);\ } #define PROC_I_R_R_R(p, g, f)\ void g (NODE_T *p) {\ A68 (f_entry) = p;\ A68_INT s;\ A68_REAL x, y;\ gsl_sf_result r;\ int status;\ POP_OBJECT (p, &y, A68_REAL);\ POP_OBJECT (p, &x, A68_REAL);\ POP_OBJECT (p, &s, A68_INT);\ (void) gsl_set_error_handler_off ();\ status = f (VALUE (&s), VALUE (&x), VALUE (&y), &r);\ MATH_RTE (p, status != 0, M_REAL, (char *) gsl_strerror (status));\ PUSH_VALUE (p, VAL (&r), A68_REAL);\ } #define PROC_R_R_R_R_DBL(p, g, f)\ void g (NODE_T *p) {\ A68 (f_entry) = p;\ 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, M_REAL, (char *) gsl_strerror (status));\ VALUE (x) = VAL (&r);\ } #define PROC_R_R_R_R_R_DBL(p, g, f)\ void g (NODE_T *p) {\ A68 (f_entry) = p;\ 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, M_REAL, (char *) gsl_strerror (status));\ VALUE (x) = VAL (&r);\ } //! @brief PROC airy ai = (REAL x) REAL PROC_R_R_DBL (p, genie_airy_ai_real, gsl_sf_airy_Ai_e); //! @brief PROC airy bi = (REAL x) REAL PROC_R_R_DBL (p, genie_airy_bi_real, gsl_sf_airy_Bi_e); //! @brief PROC airy ai scaled = (REAL x) REAL PROC_R_R_DBL (p, genie_airy_ai_scaled_real, gsl_sf_airy_Ai_scaled_e); //! @brief PROC airy bi scaled = (REAL x) REAL PROC_R_R_DBL (p, genie_airy_bi_scaled_real, gsl_sf_airy_Bi_scaled_e); //! @brief PROC airy ai deriv = (REAL x) REAL PROC_R_R_DBL (p, genie_airy_ai_deriv_real, gsl_sf_airy_Ai_deriv_e); //! @brief PROC airy bi deriv = (REAL x) REAL PROC_R_R_DBL (p, genie_airy_bi_deriv_real, gsl_sf_airy_Bi_deriv_e); //! @brief PROC airy ai deriv scaled = (REAL x) REAL PROC_R_R_DBL (p, genie_airy_ai_deriv_scaled_real, gsl_sf_airy_Ai_deriv_scaled_e); //! @brief PROC airy bi deriv scaled = (REAL x) REAL PROC_R_R_DBL (p, genie_airy_bi_deriv_scaled_real, gsl_sf_airy_Bi_deriv_scaled_e); //! @brief PROC airy zero ai = (INT s) REAL PROC_I_R (p, genie_airy_zero_ai_real, gsl_sf_airy_zero_Ai_e); //! @brief PROC airy zero bi = (INT s) REAL PROC_I_R (p, genie_airy_zero_bi_real, gsl_sf_airy_zero_Bi_e); //! @brief PROC airy zero ai deriv = (INT s) REAL PROC_I_R (p, genie_airy_zero_ai_deriv_real, gsl_sf_airy_zero_Ai_deriv_e); //! @brief PROC airy zero bi deriv = (INT s) REAL PROC_I_R (p, genie_airy_zero_bi_deriv_real, gsl_sf_airy_zero_Bi_deriv_e); //! @brief PROC clausen = (REAL x) REAL PROC_R_R (p, genie_clausen_real, gsl_sf_clausen_e); //! @brief PROC bessel jn0 = (REAL x) REAL PROC_R_R (p, genie_bessel_jn0_real, gsl_sf_bessel_J0_e); //! @brief PROC bessel jn1 = (REAL x) REAL PROC_R_R (p, genie_bessel_jn1_real, gsl_sf_bessel_J1_e); //! @brief PROC bessel jn = (INT n, REAL x) REAL PROC_I_R_R (p, genie_bessel_jn_real, gsl_sf_bessel_Jn_e); //! @brief PROC bessel yn0 = (REAL x) REAL PROC_R_R (p, genie_bessel_yn0_real, gsl_sf_bessel_Y0_e); //! @brief PROC bessel yn1 = (REAL x) REAL PROC_R_R (p, genie_bessel_yn1_real, gsl_sf_bessel_Y1_e); //! @brief PROC bessel yn = (INT n, REAL x) REAL PROC_I_R_R (p, genie_bessel_yn_real, gsl_sf_bessel_Yn_e); //! @brief PROC bessel in0 = (REAL x) REAL PROC_R_R (p, genie_bessel_in0_real, gsl_sf_bessel_I0_e); //! @brief PROC bessel in1 = (REAL x) REAL PROC_R_R (p, genie_bessel_in1_real, gsl_sf_bessel_I1_e); //! @brief PROC bessel in = (INT n, REAL x) REAL PROC_I_R_R (p, genie_bessel_in_real, gsl_sf_bessel_In_e); //! @brief PROC bessel in0 scaled = (REAL x) REAL PROC_R_R (p, genie_bessel_in0_scaled_real, gsl_sf_bessel_I0_scaled_e); //! @brief PROC bessel in1 scaled = (REAL x) REAL PROC_R_R (p, genie_bessel_in1_scaled_real, gsl_sf_bessel_I1_scaled_e); //! @brief PROC bessel in scaled = (INT n, REAL x) REAL PROC_I_R_R (p, genie_bessel_in_scaled_real, gsl_sf_bessel_In_scaled_e); //! @brief PROC bessel kn0 = (REAL x) REAL PROC_R_R (p, genie_bessel_kn0_real, gsl_sf_bessel_K0_e); //! @brief PROC bessel kn1 = (REAL x) REAL PROC_R_R (p, genie_bessel_kn1_real, gsl_sf_bessel_K1_e); //! @brief PROC bessel kn = (INT n, REAL x) REAL PROC_I_R_R (p, genie_bessel_kn_real, gsl_sf_bessel_Kn_e); //! @brief PROC bessel kn0 scaled = (REAL x) REAL PROC_R_R (p, genie_bessel_kn0_scaled_real, gsl_sf_bessel_K0_scaled_e); //! @brief PROC bessel kn1 scaled = (REAL x) REAL PROC_R_R (p, genie_bessel_kn1_scaled_real, gsl_sf_bessel_K1_scaled_e); //! @brief PROC bessel kn scaled = (INT n, REAL x) REAL PROC_I_R_R (p, genie_bessel_kn_scaled_real, gsl_sf_bessel_Kn_scaled_e); //! @brief PROC bessel jl0 = (REAL x) REAL PROC_R_R (p, genie_bessel_jl0_real, gsl_sf_bessel_j0_e); //! @brief PROC bessel jl1 = (REAL x) REAL PROC_R_R (p, genie_bessel_jl1_real, gsl_sf_bessel_j1_e); //! @brief PROC bessel jl2 = (REAL x) REAL PROC_R_R (p, genie_bessel_jl2_real, gsl_sf_bessel_j2_e); //! @brief PROC bessel jl = (INT l, REAL x) REAL PROC_I_R_R (p, genie_bessel_jl_real, gsl_sf_bessel_jl_e); //! @brief PROC bessel yl0 = (REAL x) REAL PROC_R_R (p, genie_bessel_yl0_real, gsl_sf_bessel_y0_e); //! @brief PROC bessel yl1 = (REAL x) REAL PROC_R_R (p, genie_bessel_yl1_real, gsl_sf_bessel_y1_e); //! @brief PROC bessel yl2 = (REAL x) REAL PROC_R_R (p, genie_bessel_yl2_real, gsl_sf_bessel_y2_e); //! @brief PROC bessel yl = (INT l, REAL x) REAL PROC_I_R_R (p, genie_bessel_yl_real, gsl_sf_bessel_yl_e); //! @brief PROC bessel il0 scaled = (REAL x) REAL PROC_R_R (p, genie_bessel_il0_scaled_real, gsl_sf_bessel_i0_scaled_e); //! @brief PROC bessel il1 scaled = (REAL x) REAL PROC_R_R (p, genie_bessel_il1_scaled_real, gsl_sf_bessel_i1_scaled_e); //! @brief PROC bessel il2 scaled = (REAL x) REAL PROC_R_R (p, genie_bessel_il2_scaled_real, gsl_sf_bessel_i2_scaled_e); //! @brief PROC bessel il scaled = (INT l, REAL x) REAL PROC_I_R_R (p, genie_bessel_il_scaled_real, gsl_sf_bessel_il_scaled_e); //! @brief PROC bessel kl0 scaled = (REAL x) REAL PROC_R_R (p, genie_bessel_kl0_scaled_real, gsl_sf_bessel_k0_scaled_e); //! @brief PROC bessel kl1 scaled = (REAL x) REAL PROC_R_R (p, genie_bessel_kl1_scaled_real, gsl_sf_bessel_k1_scaled_e); //! @brief PROC bessel kl2 scaled = (REAL x) REAL PROC_R_R (p, genie_bessel_kl2_scaled_real, gsl_sf_bessel_k2_scaled_e); //! @brief PROC bessel kl scaled = (INT l, REAL x) REAL PROC_I_R_R (p, genie_bessel_kl_scaled_real, gsl_sf_bessel_kl_scaled_e); //! @brief PROC bessel jnu = (REAL nu, REAL x) REAL PROC_R_R_R (p, genie_bessel_jnu_real, gsl_sf_bessel_Jnu_e); //! @brief PROC bessel ynu = (REAL nu, x) REAL PROC_R_R_R (p, genie_bessel_ynu_real, gsl_sf_bessel_Ynu_e); //! @brief PROC bessel inu = (REAL nu, x) REAL PROC_R_R_R (p, genie_bessel_inu_real, gsl_sf_bessel_Inu_e); //! @brief PROC bessel inu scaled = (REAL nu, x) REAL PROC_R_R_R (p, genie_bessel_inu_scaled_real, gsl_sf_bessel_Inu_scaled_e); //! @brief PROC bessel knu = (REAL nu, x) REAL PROC_R_R_R (p, genie_bessel_knu_real, gsl_sf_bessel_Knu_e); //! @brief PROC bessel ln knu = (REAL nu, x) REAL PROC_R_R_R (p, genie_bessel_ln_knu_real, gsl_sf_bessel_lnKnu_e); //! @brief PROC bessel knu scaled = (REAL nu, x) REAL PROC_R_R_R (p, genie_bessel_knu_scaled_real, gsl_sf_bessel_Knu_scaled_e); //! @brief PROC bessel zero jnu0 = (INT s) REAL PROC_I_R (p, genie_bessel_zero_jnu0_real, gsl_sf_bessel_zero_J0_e); //! @brief PROC bessel zero jnu1 = (INT s) REAL PROC_I_R (p, genie_bessel_zero_jnu1_real, gsl_sf_bessel_zero_J1_e); //! @brief PROC bessel zero jnu = (INT s, REAL nu) REAL PROC_I_R_R_REVERSED (p, genie_bessel_zero_jnu_real, gsl_sf_bessel_zero_Jnu_e); //! @brief PROC dawson = (REAL x) REAL PROC_R_R (p, genie_dawson_real, gsl_sf_dawson_e); //! @brief PROC debye 1 = (REAL x) REAL PROC_R_R (p, genie_debye_1_real, gsl_sf_debye_1_e); //! @brief PROC debye 2 = (REAL x) REAL PROC_R_R (p, genie_debye_2_real, gsl_sf_debye_2_e); //! @brief PROC debye 3 = (REAL x) REAL PROC_R_R (p, genie_debye_3_real, gsl_sf_debye_3_e); //! @brief PROC debye 4 = (REAL x) REAL PROC_R_R (p, genie_debye_4_real, gsl_sf_debye_4_e); //! @brief PROC debye 5 = (REAL x) REAL PROC_R_R (p, genie_debye_5_real, gsl_sf_debye_5_e); //! @brief PROC debye 6 = (REAL x) REAL PROC_R_R (p, genie_debye_6_real, gsl_sf_debye_6_e); //! @brief PROC dilog = (REAL x) REAL PROC_R_R (p, genie_dilog_real, gsl_sf_dilog_e); //! @brief PROC ellint k comp = (REAL k) REAL PROC_R_R_DBL (p, genie_ellint_k_comp_real, gsl_sf_ellint_Kcomp_e); //! @brief PROC ellint e comp = (REAL k) REAL PROC_R_R_DBL (p, genie_ellint_e_comp_real, gsl_sf_ellint_Ecomp_e); //! @brief PROC ellint p comp = (REAL k, n) REAL PROC_R_R_R_DBL (p, genie_ellint_p_comp_real, gsl_sf_ellint_Pcomp_e); //! @brief PROC ellint d = (REAL phi, k) REAL PROC_R_R_R_DBL (p, genie_ellint_d_real, gsl_sf_ellint_D_e); //! @brief PROC ellint e = (REAL phi, k) REAL PROC_R_R_R_DBL (p, genie_ellint_e_real, gsl_sf_ellint_E_e); //! @brief PROC ellint f = (REAL phi, k) REAL PROC_R_R_R_DBL (p, genie_ellint_f_real, gsl_sf_ellint_F_e); //! @brief PROC ellint p = (REAL phi, k, n) REAL PROC_R_R_R_R_DBL (p, genie_ellint_p_real, gsl_sf_ellint_P_e); //! @brief PROC ellint rc = (REAL x, y) REAL PROC_R_R_R_DBL (p, genie_ellint_rc_real, gsl_sf_ellint_RC_e); //! @brief PROC ellint rf = (REAL x, y, z) REAL PROC_R_R_R_R_DBL (p, genie_ellint_rf_real, gsl_sf_ellint_RF_e); //! @brief PROC ellint rd = (REAL x, y, z) REAL PROC_R_R_R_R_DBL (p, genie_ellint_rd_real, gsl_sf_ellint_RD_e); //! @brief PROC ellint rj = (REAL x, y, z, p) REAL PROC_R_R_R_R_R_DBL (p, genie_ellint_rj_real, gsl_sf_ellint_RJ_e); //! @brief PROC expint e1 = (REAL x) REAL PROC_R_R (p, genie_expint_e1_real, gsl_sf_expint_E1_e); //! @brief PROC expint e2 = (REAL x) REAL PROC_R_R (p, genie_expint_e2_real, gsl_sf_expint_E2_e); //! @brief PROC expint en = (INT n, REAL x) REAL PROC_I_R_R (p, genie_expint_en_real, gsl_sf_expint_En_e); //! @brief PROC expint ei = (REAL x) REAL PROC_R_R (p, genie_expint_ei_real, gsl_sf_expint_Ei_e); //! @brief PROC shi = (REAL x) REAL PROC_R_R (p, genie_shi_real, gsl_sf_Shi_e); //! @brief PROC chi = (REAL x) REAL PROC_R_R (p, genie_chi_real, gsl_sf_Chi_e); //! @brief PROC expint 3 = (REAL x) REAL PROC_R_R (p, genie_expint_3_real, gsl_sf_expint_3_e); //! @brief PROC si = (REAL x) REAL PROC_R_R (p, genie_si_real, gsl_sf_Si_e); //! @brief PROC ci = (REAL x) REAL PROC_R_R (p, genie_ci_real, gsl_sf_Ci_e); //! @brief PROC atanint = (REAL x) REAL PROC_R_R (p, genie_atanint_real, gsl_sf_atanint_e); //! @brief PROC fermi dirac m1 = (REAL x) REAL PROC_R_R (p, genie_fermi_dirac_m1_real, gsl_sf_fermi_dirac_m1_e); //! @brief PROC fermi dirac 0 = (REAL x) REAL PROC_R_R (p, genie_fermi_dirac_0_real, gsl_sf_fermi_dirac_0_e); //! @brief PROC fermi dirac 1 = (REAL x) REAL PROC_R_R (p, genie_fermi_dirac_1_real, gsl_sf_fermi_dirac_1_e); //! @brief PROC fermi dirac 2 = (REAL x) REAL PROC_R_R (p, genie_fermi_dirac_2_real, gsl_sf_fermi_dirac_2_e); //! @brief PROC fermi dirac int = (INT n, REAL x) REAL PROC_I_R_R (p, genie_fermi_dirac_int_real, gsl_sf_fermi_dirac_int_e); //! @brief PROC fermi dirac m half = (REAL x) REAL PROC_R_R (p, genie_fermi_dirac_mhalf_real, gsl_sf_fermi_dirac_mhalf_e); //! @brief PROC fermi dirac half = (REAL x) REAL PROC_R_R (p, genie_fermi_dirac_half_real, gsl_sf_fermi_dirac_half_e); //! @brief PROC fermi dirac 3 half = (REAL x) REAL PROC_R_R (p, genie_fermi_dirac_3half_real, gsl_sf_fermi_dirac_3half_e); //! @brief PROC fermi dirac inc0 = (REAL x, b) REAL PROC_R_R_R (p, genie_fermi_dirac_inc_0_real, gsl_sf_fermi_dirac_inc_0_e); //! @brief PROC digamma = (REAL x) REAL PROC_R_R (p, genie_digamma_real, gsl_sf_psi_e); //! @brief PROC gamma star = (REAL x) REAL PROC_R_R (p, genie_gammastar_real, gsl_sf_gammastar_e); //! @brief PROC gamma inv = (REAL x) REAL PROC_R_R (p, genie_gammainv_real, gsl_sf_gammainv_e); //! @brief PROC double fact = (INT n) REAL PROC_I_R (p, genie_doublefact_real, gsl_sf_doublefact_e); //! @brief PROC ln double fact = (INT n) REAL PROC_I_R (p, genie_lndoublefact_real, gsl_sf_lndoublefact_e); //! @brief PROC taylor coeff = (INT n, REAL x) REAL PROC_I_R_R (p, genie_taylorcoeff_real, gsl_sf_taylorcoeff_e); //! @brief PROC poch = (REAL a, x) REAL PROC_R_R_R (p, genie_poch_real, gsl_sf_poch_e); //! @brief PROC lnpoch = (REAL a, x) REAL PROC_R_R_R (p, genie_lnpoch_real, gsl_sf_lnpoch_e); //! @brief PROC pochrel = (REAL a, x) REAL PROC_R_R_R (p, genie_pochrel_real, gsl_sf_pochrel_e); //! @brief PROC beta inc = (REAL a, b, x) REAL PROC_R_R_R_R (p, genie_beta_inc_real, gsl_sf_beta_inc_e); //! @brief PROC gamma inc = (REAL a, x) REAL PROC_R_R_R (p, genie_gamma_inc_real, gsl_sf_gamma_inc_e); //! @brief PROC gamma inc q = (REAL a, x) REAL PROC_R_R_R (p, genie_gamma_inc_q_real, gsl_sf_gamma_inc_Q_e); //! @brief PROC gamma inc p = (REAL a, x) REAL PROC_R_R_R (p, genie_gamma_inc_p_real, gsl_sf_gamma_inc_P_e); //! @brief PROC gegenpoly 1 = (REAL lambda, x) REAL PROC_R_R_R (p, genie_gegenpoly_1_real, gsl_sf_gegenpoly_1_e); //! @brief PROC gegenpoly 2 = (REAL lambda, x) REAL PROC_R_R_R (p, genie_gegenpoly_2_real, gsl_sf_gegenpoly_2_e); //! @brief PROC gegenpoly 3 = (REAL lambda, x) REAL PROC_R_R_R (p, genie_gegenpoly_3_real, gsl_sf_gegenpoly_3_e); //! @brief PROC gegenpoly n = (INT n, REAL lambda, x) REAL PROC_I_R_R_R (p, genie_gegenpoly_n_real, gsl_sf_gegenpoly_n_e); //! @brief PROC laguerre 1 = (REAL a, x) REAL PROC_R_R_R (p, genie_laguerre_1_real, gsl_sf_laguerre_1_e); //! @brief PROC laguerre 2 = (REAL a, x) REAL PROC_R_R_R (p, genie_laguerre_2_real, gsl_sf_laguerre_2_e); //! @brief PROC laguerre 3 = (REAL a, x) REAL PROC_R_R_R (p, genie_laguerre_3_real, gsl_sf_laguerre_3_e); //! @brief PROC laguerre n = (INT n, REAL a, x) REAL PROC_I_R_R_R (p, genie_laguerre_n_real, gsl_sf_laguerre_n_e); //! @brief PROC lambert w0 = (REAL x) REAL PROC_R_R (p, genie_lambert_w0_real, gsl_sf_lambert_W0_e); //! @brief PROC lambert wm1 = (REAL x) REAL PROC_R_R (p, genie_lambert_wm1_real, gsl_sf_lambert_Wm1_e); //! @brief PROC legendre p1 = (REAL x) REAL PROC_R_R (p, genie_legendre_p1_real, gsl_sf_legendre_P1_e); //! @brief PROC legendre p2 = (REAL x) REAL PROC_R_R (p, genie_legendre_p2_real, gsl_sf_legendre_P2_e); //! @brief PROC legendre p3 = (REAL x) REAL PROC_R_R (p, genie_legendre_p3_real, gsl_sf_legendre_P3_e); //! @brief PROC legendre pl = (INT l, REAL x) REAL PROC_I_R_R (p, genie_legendre_pl_real, gsl_sf_legendre_Pl_e); //! @brief PROC legendre q0 = (REAL x) REAL PROC_R_R (p, genie_legendre_q0_real, gsl_sf_legendre_Q0_e); //! @brief PROC legendre q1 = (REAL x) REAL PROC_R_R (p, genie_legendre_q1_real, gsl_sf_legendre_Q1_e); //! @brief PROC legendre ql = (INT l, REAL x) REAL PROC_I_R_R (p, genie_legendre_ql_real, gsl_sf_legendre_Ql_e); //! @brief PROC conicalp half = (REAL lambda, x) REAL PROC_R_R_R (p, genie_conicalp_half_real, gsl_sf_conicalP_half_e); //! @brief PROC conicalp mhalf = (REAL lambda, x) REAL PROC_R_R_R (p, genie_conicalp_mhalf_real, gsl_sf_conicalP_mhalf_e); //! @brief PROC conicalp 0 = (REAL lambda, x) REAL PROC_R_R_R (p, genie_conicalp_0_real, gsl_sf_conicalP_0_e); //! @brief PROC conicalp 1 = (REAL lambda, x) REAL PROC_R_R_R (p, genie_conicalp_1_real, gsl_sf_conicalP_1_e); //! @brief PROC conicalp sph reg = (INT n, REAL lambda, x) REAL PROC_I_R_R_R (p, genie_conicalp_sph_reg_real, gsl_sf_conicalP_sph_reg_e); //! @brief PROC conicalp cyl reg = (INT n, REAL lambda, x) REAL PROC_I_R_R_R (p, genie_conicalp_cyl_reg_real, gsl_sf_conicalP_cyl_reg_e); //! @brief PROC legendre h3d 0 = (REAL lambda, x) REAL PROC_R_R_R (p, genie_legendre_h3d_0_real, gsl_sf_legendre_H3d_0_e); //! @brief PROC legendre h3d 1 = (REAL lambda, x) REAL PROC_R_R_R (p, genie_legendre_h3d_1_real, gsl_sf_legendre_H3d_1_e); //! @brief PROC legendre h3d = (INT l, REAL lambda, x) REAL PROC_I_R_R_R (p, genie_legendre_H3d_real, gsl_sf_legendre_H3d_e); //! @brief PROC psi int = (INT n) REAL PROC_I_R (p, genie_psi_int_real, gsl_sf_psi_int_e); //! @brief PROC psi = (INT n) REAL PROC_R_R (p, genie_psi_real, gsl_sf_psi_e); //! @brief PROC psi 1piy = (INT n) REAL PROC_R_R (p, genie_psi_1piy_real, gsl_sf_psi_1piy_e); //! @brief PROC psi 1 = (INT n) REAL PROC_I_R (p, genie_psi_1_int_real, gsl_sf_psi_1_int_e); //! @brief PROC psi 1 = (REAL x) REAL PROC_R_R (p, genie_psi_1_real, gsl_sf_psi_1_e); //! @brief PROC psi n = (INT n, REAL x) REAL PROC_I_R_R (p, genie_psi_n_real, gsl_sf_psi_n_e); //! @brief PROC synchrotron 1 = (REAL x) REAL PROC_R_R (p, genie_synchrotron_1_real, gsl_sf_synchrotron_1_e); //! @brief PROC synchrotron 2 = (REAL x) REAL PROC_R_R (p, genie_synchrotron_2_real, gsl_sf_synchrotron_2_e); //! @brief PROC transport 2 = (REAL x) REAL PROC_R_R (p, genie_transport_2_real, gsl_sf_transport_2_e); //! @brief PROC transport 3 = (REAL x) REAL PROC_R_R (p, genie_transport_3_real, gsl_sf_transport_3_e); //! @brief PROC transport 4 = (REAL x) REAL PROC_R_R (p, genie_transport_4_real, gsl_sf_transport_4_e); //! @brief PROC transport 5 = (REAL x) REAL PROC_R_R (p, genie_transport_5_real, gsl_sf_transport_5_e); //! @brief PROC hypot = (REAL x) REAL PROC_R_R_R (p, genie_hypot_real, gsl_sf_hypot_e); //! @brief PROC sinc = (REAL x) REAL PROC_R_R (p, genie_sinc_real, gsl_sf_sinc_e); //! @brief PROC lnsinh = (REAL x) REAL PROC_R_R (p, genie_lnsinh_real, gsl_sf_lnsinh_e); //! @brief PROC lncosh = (REAL x) REAL PROC_R_R (p, genie_lncosh_real, gsl_sf_lncosh_e); //! @brief PROC angle restrict symm = (REAL theta) REAL PROC_RR_R (p, genie_angle_restrict_symm_real, gsl_sf_angle_restrict_symm_e); //! @brief PROC angle restrict pos = (REAL theta) REAL PROC_RR_R (p, genie_angle_restrict_pos_real, gsl_sf_angle_restrict_pos_e); //! @brief PROC zeta int = (INT n) REAL PROC_I_R (p, genie_zeta_int_real, gsl_sf_zeta_int_e); //! @brief PROC zeta = (REAL s) REAL PROC_R_R (p, genie_zeta_real, gsl_sf_zeta_e); //! @brief PROC zetam1 int = (INT n) REAL PROC_I_R (p, genie_zetam1_int_real, gsl_sf_zetam1_int_e); //! @brief PROC zetam1 = (REAL s) REAL PROC_R_R (p, genie_zetam1_real, gsl_sf_zetam1_e); //! @brief PROC hzeta = (REAL s, q) REAL PROC_R_R_R (p, genie_hzeta_real, gsl_sf_hzeta_e); //! @brief PROC eta int = (INT n) REAL PROC_I_R (p, genie_etaint_real, gsl_sf_eta_int_e); //! @brief PROC eta = (REAL s) REAL PROC_R_R (p, genie_eta_real, gsl_sf_eta_e); //! @brief PROC expm1 = (REAL x) REAL PROC_R_R (p, genie_expm1_real, gsl_sf_expm1_e); //! @brief PROC exprel = (REAL x) REAL PROC_R_R (p, genie_exprel_real, gsl_sf_exprel_e); //! @brief PROC exprel2 = (REAL x) REAL PROC_R_R (p, genie_exprel_2_real, gsl_sf_exprel_2_e); //! @brief PROC exprel n = (INT l, REAL x) REAL PROC_I_R_R (p, genie_exprel_n_real, gsl_sf_exprel_n_e); //! @brief PROC logabs = (REAL x) REAL PROC_R_R (p, genie_log_abs_real, gsl_sf_log_abs_e); //! @brief PROC log1plusx = (REAL x) REAL PROC_R_R (p, genie_log_1plusx_real, gsl_sf_log_1plusx_e); //! @brief PROC log1plusxmx = (REAL x) REAL PROC_R_R (p, genie_log_1plusx_mx_real, gsl_sf_log_1plusx_mx_e); //! @brief PROC hermite func = (INT n, REAL x) REAL PROC_I_R_R (p, genie_hermite_func_real, gsl_sf_hermite_func_e); #endif algol68g-3.1.2/src/a68g/conversion.c0000644000175000017500000000465714361065320013762 00000000000000//! @file conversion.c //! @author J. Marcel van der Veer // //! @section Copyright // // This file is part of Algol68G - an Algol 68 compiler-interpreter. // Copyright 2001-2023 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" #include "a68g-prelude.h" #include "a68g-mp.h" #include "a68g-genie.h" #include "a68g-postulates.h" #include "a68g-parser.h" #include "a68g-options.h" #include "a68g-optimiser.h" #include "a68g-listing.h" // A list of 10 ^ 2 ^ n for conversion purposes on IEEE 754 platforms. #if (A68_LEVEL >= 3) //! @brief 10 ** expo static DOUBLE_T pow_10_double[] = { 10.0q, 100.0q, 1.0e4q, 1.0e8q, 1.0e16q, 1.0e32q, 1.0e64q, 1.0e128q, 1.0e256q, 1.0e512q, 1.0e1024q, 1.0e2048q, 1.0e4096q }; DOUBLE_T ten_up_double (int expo) { // This way appears sufficiently accurate. DOUBLE_T dbl_expo = 1.0q, *dep; BOOL_T neg_expo; if (expo == 0) { return 1.0q; } neg_expo = (BOOL_T) (expo < 0); if (neg_expo) { expo = -expo; } if (expo > MAX_DOUBLE_EXPO) { expo = 0; errno = EDOM; } ABEND (expo > MAX_DOUBLE_EXPO, ERROR_INVALID_VALUE, __func__); for (dep = pow_10_double; expo != 0; expo >>= 1, dep++) { if (expo & 0x1) { dbl_expo *= *dep; } } return neg_expo ? 1.0q / dbl_expo : dbl_expo; } #endif static REAL_T pow_10[] = { 10.0, 100.0, 1.0e4, 1.0e8, 1.0e16, 1.0e32, 1.0e64, 1.0e128, 1.0e256 }; //! @brief 10 ** expo REAL_T ten_up (int expo) { // This way appears sufficiently accurate. REAL_T dbl_expo = 1.0, *dep; BOOL_T neg_expo = (BOOL_T) (expo < 0); if (neg_expo) { expo = -expo; } ABEND (expo > MAX_REAL_EXPO, ERROR_INVALID_VALUE, __func__); for (dep = pow_10; expo != 0; expo >>= 1, dep++) { if (expo & 0x1) { dbl_expo *= *dep; } } return neg_expo ? 1 / dbl_expo : dbl_expo; } algol68g-3.1.2/src/a68g/modes.c0000644000175000017500000033002314361065320012671 00000000000000//! @file modes.c //! @author J. Marcel van der Veer // //! @section Copyright // // This file is part of Algol68G - an Algol 68 compiler-interpreter. // Copyright 2001-2023 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 . // 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. #include "a68g.h" #include "a68g-parser.h" #include "a68g-prelude.h" BOOL_T basic_coercions (MOID_T *, MOID_T *, int, int); BOOL_T is_coercible (MOID_T *, MOID_T *, int, int); BOOL_T is_nonproc (MOID_T *); void mode_check_enclosed (NODE_T *, SOID_T *, SOID_T *); void mode_check_unit (NODE_T *, SOID_T *, SOID_T *); void mode_check_formula (NODE_T *, SOID_T *, SOID_T *); void coerce_enclosed (NODE_T *, SOID_T *); void coerce_operand (NODE_T *, SOID_T *); void coerce_formula (NODE_T *, SOID_T *); void coerce_unit (NODE_T *, SOID_T *); #define DEPREF A68_TRUE #define NO_DEPREF A68_FALSE #define IF_MODE_IS_WELL(n) (! ((n) == M_ERROR || (n) == M_UNDEFINED)) #define INSERT_COERCIONS(n, p, q) make_strong ((n), (p), MOID (q)) // MODE checker and coercion inserter. //! @brief Absorb nested series modes recursively. 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 Make SERIES (u, v). 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 (&A68_JOB), x); if (DIM (x) == 1) { return MOID (PACK (x)); } else { return x; } } //! @brief Absorb firmly related unions in mode. 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 Absorb nested series and united modes recursively. 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 united mode, from mode that is a SERIES (..). MOID_T *make_united_mode (MOID_T * m) { MOID_T *u; PACK_T *w; int mods; if (m == NO_MOID) { return M_ERROR; } else if (ATTRIBUTE (m) != SERIES_MODE) { return m; } // Do not unite a single UNION. if (DIM (m) == 1 && IS (MOID (PACK (m)), UNION_SYMBOL)) { return MOID (PACK (m)); } // Straighten the series. absorb_series_union_pack (&m); // Copy the series into a UNION. u = new_moid (); ATTRIBUTE (u) = UNION_SYMBOL; PACK (u) = NO_PACK; 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); DIM (u) = count_pack_members (PACK (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 (&A68_JOB), u); } } //! @brief Give accurate error message. 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); int N = 0; if (u == NO_PACK) { ASSERT (snprintf (txt, SNPRINTF_SIZE, "empty mode-list") >= 0); N++; } 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); N++; } else { if (strlen (txt) > 0) { ASSERT (snprintf (TAIL (txt), SNPRINTF_SIZE, " and ") >= 0); N++; } ASSERT (snprintf (TAIL (txt), SNPRINTF_SIZE, "%s", moid_to_string (MOID (u), MOID_ERROR_WIDTH, n)) >= 0); N++; } } } } } if (depth == 1) { if (N == 0) { ASSERT (snprintf (TAIL (txt), SNPRINTF_SIZE, "mode") >= 0); } 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_FLEX (q)) { 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. 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 (A68_ERROR, p, "M cannot be coerced to M in C context", from, to, context); } else { diagnostic (A68_ERROR, p, "Y in C context", txt, context); } } else { if (strlen (txt) == 0) { diagnostic (A68_ERROR, p, "M cannot be coerced to M in C-A", from, to, context, att); } else { diagnostic (A68_ERROR, p, "Y in C-A", txt, context, att); } } } //! @brief Make SOID data structure. 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. void mode_checker (NODE_T * p) { if (IS (p, PARTICULAR_PROGRAM)) { SOID_T x, y; A68 (top_soid_list) = NO_SOID; make_soid (&x, STRONG, M_VOID, 0); mode_check_enclosed (SUB (p), &x, &y); MOID (p) = MOID (&y); } } //! @brief Driver for coercion inserions. void coercion_inserter (NODE_T * p) { if (IS (p, PARTICULAR_PROGRAM)) { SOID_T q; make_soid (&q, STRONG, M_VOID, 0); coerce_enclosed (SUB (p), &q); } } //! @brief Whether mode is not well defined. 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. void free_soid_list (SOID_T * root) { if (root != NO_SOID) { SOID_T *q; for (q = root; NEXT (q) != NO_SOID; FORWARD (q)) { ; } NEXT (q) = A68 (top_soid_list); A68 (top_soid_list) = root; } } //! @brief Add SOID data structure to soid list. 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 (A68 (top_soid_list) == NO_SOID) { new_one = (SOID_T *) get_temp_heap_space ((size_t) SIZE_ALIGNED (SOID_T)); } else { new_one = A68 (top_soid_list); FORWARD (A68 (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. 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 (&A68_JOB), x); return x; } //! @brief Whether "p" is compatible with "q". 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 (!IS (p, REF_SYMBOL) && !IS (q, REF_SYMBOL)) { return DEFLEX (p) == DEFLEX (q); } } else if (deflex == SAFE_DEFLEXING) { if (!IS (p, REF_SYMBOL) && !IS (q, REF_SYMBOL)) { return DEFLEX (p) == DEFLEX (q); } } return p == q; } //! @brief Whether mode is deprefable. BOOL_T is_deprefable (MOID_T * p) { if (IS_REF (p)) { return A68_TRUE; } else { return (BOOL_T) (IS (p, PROC_SYMBOL) && PACK (p) == NO_PACK); } } //! @brief Depref mode once. MOID_T *depref_once (MOID_T * p) { if (IS_REF_FLEX (p)) { return SUB_SUB (p); } else if (IS_REF (p)) { return SUB (p); } else if (IS (p, PROC_SYMBOL) && PACK (p) == NO_PACK) { return SUB (p); } else { return NO_MOID; } } //! @brief Depref mode completely. MOID_T *depref_completely (MOID_T * p) { while (is_deprefable (p)) { p = depref_once (p); } return p; } //! @brief Deproc_completely. 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. MOID_T *depref_rows (MOID_T * p, MOID_T * q) { if (q == M_ROWS) { while (is_deprefable (p)) { p = depref_once (p); } return p; } else { return q; } } //! @brief Derow mode, strip FLEX and BOUNDS. MOID_T *derow (MOID_T * p) { if (IS_ROW (p) || IS_FLEX (p)) { return derow (SUB (p)); } else { return p; } } //! @brief Whether rows type. 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. BOOL_T is_proc_ref_file_void_or_format (MOID_T * p) { if (p == M_PROC_REF_FILE_VOID) { return A68_TRUE; } else if (p == M_FORMAT) { return A68_TRUE; } else { return A68_FALSE; } } //! @brief Whether mode can be transput. BOOL_T is_transput_mode (MOID_T * p, char rw) { if (p == M_INT) { return A68_TRUE; } else if (p == M_LONG_INT) { return A68_TRUE; } else if (p == M_LONG_LONG_INT) { return A68_TRUE; } else if (p == M_REAL) { return A68_TRUE; } else if (p == M_LONG_REAL) { return A68_TRUE; } else if (p == M_LONG_LONG_REAL) { return A68_TRUE; } else if (p == M_BOOL) { return A68_TRUE; } else if (p == M_CHAR) { return A68_TRUE; } else if (p == M_BITS) { return A68_TRUE; } else if (p == M_LONG_BITS) { return A68_TRUE; } else if (p == M_LONG_LONG_BITS) { return A68_TRUE; } else if (p == M_COMPLEX) { return A68_TRUE; } else if (p == M_LONG_COMPLEX) { return A68_TRUE; } else if (p == M_LONG_LONG_COMPLEX) { return A68_TRUE; } else if (p == M_ROW_CHAR) { return A68_TRUE; } else if (p == M_STRING) { return A68_TRUE; } else if (p == M_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_FLEX (p)) { if (SUB (p) == M_ROW_CHAR) { return A68_TRUE; } else { return (BOOL_T) (rw == 'w' ? is_transput_mode (SUB (p), rw) : A68_FALSE); } } else if (IS_ROW (p)) { 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. 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. 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_REF (p) ? is_transput_mode (SUB (p), 'r') : A68_FALSE); } } //! @brief Whether name struct. 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. MOID_T *unites_to (MOID_T * m, MOID_T * u) { // Uniting U (m). MOID_T *v = NO_MOID; PACK_T *p; if (u == M_SIMPLIN || u == M_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. 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". 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". 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".. 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". 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". 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". 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". 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 == M_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 firm. 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 "p" widens to "q". MOID_T *widens_to (MOID_T * p, MOID_T * q) { if (p == M_INT) { if (q == M_LONG_INT || q == M_LONG_LONG_INT || q == M_LONG_REAL || q == M_LONG_LONG_REAL || q == M_LONG_COMPLEX || q == M_LONG_LONG_COMPLEX) { return M_LONG_INT; } else if (q == M_REAL || q == M_COMPLEX) { return M_REAL; } else { return NO_MOID; } } else if (p == M_LONG_INT) { if (q == M_LONG_LONG_INT) { return M_LONG_LONG_INT; } else if (q == M_LONG_REAL || q == M_LONG_LONG_REAL || q == M_LONG_COMPLEX || q == M_LONG_LONG_COMPLEX) { return M_LONG_REAL; } else { return NO_MOID; } } else if (p == M_LONG_LONG_INT) { if (q == M_LONG_LONG_REAL || q == M_LONG_LONG_COMPLEX) { return M_LONG_LONG_REAL; } else { return NO_MOID; } } else if (p == M_REAL) { if (q == M_LONG_REAL || q == M_LONG_LONG_REAL || q == M_LONG_COMPLEX || q == M_LONG_LONG_COMPLEX) { return M_LONG_REAL; } else if (q == M_COMPLEX) { return M_COMPLEX; } else { return NO_MOID; } } else if (p == M_COMPLEX) { if (q == M_LONG_COMPLEX || q == M_LONG_LONG_COMPLEX) { return M_LONG_COMPLEX; } else { return NO_MOID; } } else if (p == M_LONG_REAL) { if (q == M_LONG_LONG_REAL || q == M_LONG_LONG_COMPLEX) { return M_LONG_LONG_REAL; } else if (q == M_LONG_COMPLEX) { return M_LONG_COMPLEX; } else { return NO_MOID; } } else if (p == M_LONG_COMPLEX) { if (q == M_LONG_LONG_COMPLEX) { return M_LONG_LONG_COMPLEX; } else { return NO_MOID; } } else if (p == M_LONG_LONG_REAL) { if (q == M_LONG_LONG_COMPLEX) { return M_LONG_LONG_COMPLEX; } else { return NO_MOID; } } else if (p == M_BITS) { if (q == M_LONG_BITS || q == M_LONG_LONG_BITS) { return M_LONG_BITS; } else if (q == M_ROW_BOOL) { return M_ROW_BOOL; } else if (q == M_FLEX_ROW_BOOL) { return M_FLEX_ROW_BOOL; } else { return NO_MOID; } } else if (p == M_LONG_BITS) { if (q == M_LONG_LONG_BITS) { return M_LONG_LONG_BITS; } else if (q == M_ROW_BOOL) { return M_ROW_BOOL; } else if (q == M_FLEX_ROW_BOOL) { return M_FLEX_ROW_BOOL; } else { return NO_MOID; } } else if (p == M_LONG_LONG_BITS) { if (q == M_ROW_BOOL) { return M_ROW_BOOL; } else if (q == M_FLEX_ROW_BOOL) { return M_FLEX_ROW_BOOL; } else { return NO_MOID; } } else if (p == M_BYTES && q == M_ROW_CHAR) { return M_ROW_CHAR; } else if (p == M_LONG_BYTES && q == M_ROW_CHAR) { return M_ROW_CHAR; } else if (p == M_BYTES && q == M_FLEX_ROW_CHAR) { return M_FLEX_ROW_CHAR; } else if (p == M_LONG_BYTES && q == M_FLEX_ROW_CHAR) { return M_FLEX_ROW_CHAR; } else { return NO_MOID; } } //! @brief Whether "p" widens to "q". 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. BOOL_T is_ref_row (MOID_T * p) { return (BOOL_T) (NAME (p) != NO_MOID ? IS_ROW (DEFLEX (SUB (p))) : A68_FALSE); } //! @brief Whether strong name. 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. 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_FLEX (q)) { 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. 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 == M_VOID) { return A68_TRUE; } else if ((q == M_SIMPLIN || q == M_ROW_SIMPLIN) && is_readable_mode (p)) { return A68_TRUE; } else if (q == M_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_FLEX (q) && 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 == M_SIMPLOUT || q == M_ROW_SIMPLOUT) { return is_printable_mode (p); } else { return A68_FALSE; } } //! @brief Basic coercions. 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 coercible stowed. BOOL_T is_coercible_stowed (MOID_T * p, MOID_T * q, int c, int deflex) { if (c != STRONG) { // Such construct is always in a strong position, is it not? return A68_FALSE; } else if (q == M_VOID) { return A68_TRUE; } else if (IS_FLEX (q)) { 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_ROW (q)) { 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; } } //! @brief Whether coercible series. BOOL_T is_coercible_series (MOID_T * p, MOID_T * q, int c, int deflex) { if (c == NO_SORT) { 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 Whether "p" can be coerced to "q" in a "c" context. 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 == M_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 == M_VACUUM && IS_ROW (DEFLEX (q))) { return A68_TRUE; } else { return basic_coercions (p, q, c, deflex); } } //! @brief Whether coercible in context. 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. 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) (!IS (MOID (y), STOWED_MODE)); } if (k == A68_FALSE) { diagnostic (A68_ERROR, n, ERROR_NO_UNIQUE_MODE); } return k; } } //! @brief A moid from "m" to which all other members can be coerced. MOID_T *get_balanced_mode (MOID_T * m, int sort, BOOL_T return_depreffed, int deflex) { MOID_T *common_moid = 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) != M_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_moid == NO_MOID) { common_moid = mark; } else if (IS_FLEX (candidate) && DEFLEX (candidate) == common_moid) { // We prefer FLEX. common_moid = mark; } } } } } // for } // for } return common_moid == NO_MOID ? m : common_moid; } //! @brief Whether we can search a common mode from a clause or not. 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". 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 M_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. 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) == M_VOID && MOID (y) != M_ERROR && !(MOID (y) == M_VOID || !is_nonproc (MOID (y)))) { if (IS (p, FORMULA)) { diagnostic (A68_WARNING | A68_FORCE_DIAGNOSTICS, p, WARNING_VOIDED, MOID (y)); } else { diagnostic (A68_WARNING, p, WARNING_VOIDED, MOID (y)); } } } } //! @brief Warn for things that are likely unintended. 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 (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. 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. 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. 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. 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_FLEX (q)) { make_rowing_coercion (n, p, SUB (q)); } else if (is_ref_row (q)) { make_ref_rowing_coercion (n, p, q); } } } //! @brief Make uniting coercion. void make_uniting_coercion (NODE_T * n, MOID_T * q) { make_coercion (n, UNITING, derow (q)); if (IS_ROW (q) || IS_FLEX (q)) { make_rowing_coercion (n, derow (q), q); } } //! @brief Make depreffing coercion. void make_depreffing_coercion (NODE_T * n, MOID_T * p, MOID_T * q) { if (DEFLEX (p) == DEFLEX (q)) { return; } else if (q == M_SIMPLOUT && is_printable_mode (p)) { make_coercion (n, UNITING, q); } else if (q == M_ROW_SIMPLOUT && is_printable_mode (p)) { make_coercion (n, UNITING, M_SIMPLOUT); make_coercion (n, ROWING, M_ROW_SIMPLOUT); } else if (q == M_SIMPLIN && is_readable_mode (p)) { make_coercion (n, UNITING, q); } else if (q == M_ROW_SIMPLIN && is_readable_mode (p)) { make_coercion (n, UNITING, M_SIMPLIN); make_coercion (n, ROWING, M_ROW_SIMPLIN); } else if (q == M_ROWS && is_rows_type (p)) { make_coercion (n, UNITING, M_ROWS); MOID (n) = M_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_FLEX (q) && is_strong_slice (p, q)) { make_rowing_coercion (n, p, q); } else if (IS_REF (p)) { 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). BOOL_T is_nonproc (MOID_T * p) { if (IS (p, PROC_SYMBOL) && PACK (p) == NO_PACK) { return A68_FALSE; } else if (IS_REF (p)) { return is_nonproc (SUB (p)); } else { return A68_TRUE; } } //! @brief Make_void: voiden in an appropriate way. 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, M_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, M_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_REF (z)) { 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 != M_VOID) { make_coercion (p, VOIDING, M_VOID); } return; } } } // All other is voided straight away. make_coercion (p, VOIDING, M_VOID); } //! @brief Make strong coercion. void make_strong (NODE_T * n, MOID_T * p, MOID_T * q) { if (q == M_VOID && p != M_VOID) { make_void (n, p); } else { make_depreffing_coercion (n, p, q); } } //! @brief Mode check on bounds. 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, M_INT, 0); mode_check_unit (p, &x, &y); if (!is_coercible_in_context (&y, &x, SAFE_DEFLEXING)) { cannot_coerce (p, MOID (&y), M_INT, MEEK, SAFE_DEFLEXING, UNIT); } mode_check_bounds (NEXT (p)); } else { mode_check_bounds (SUB (p)); mode_check_bounds (NEXT (p)); } } //! @brief Mode check declarer. 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. 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. 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. 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. 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. 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. 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. 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. 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, M_VOID, 0); mode_check_unit (p, &w, &y); } if (NEXT (p) != NO_NODE) { mode_check_serial (r, NEXT (p), x, k); } else { if (k) { add_to_soid_list (r, p, &y); } } } } //! @brief Mode check serial clause units. 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) : M_ERROR), 0); } free_soid_list (top_sl); } //! @brief Mode check unit list. 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. 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. 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. 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 (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. 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, MEEK, NO_MOID, 0); mode_check_serial_units (NEXT_SUB (p), &enq_expct, &enq_yield, ENQUIRY_CLAUSE); // Deduce the united mode from the enquiry clause. 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 == M_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 (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. 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), M_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. void mode_check_unit_list_2 (NODE_T * p, SOID_T * x, SOID_T * y) { SOID_T *top_sl = NO_SOID; if (MOID (x) != NO_MOID) { if (IS_FLEX (MOID (x))) { SOID_T y2; make_soid (&y2, SORT (x), SLICE (SUB_MOID (x)), 0); mode_check_unit_list (&top_sl, SUB (p), &y2); } else if (IS_ROW (MOID (x))) { SOID_T y2; 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. 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. 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 (A68_ERROR, p, ERROR_VACUUM, "REF MODE"); } else { make_soid (y, STRONG, M_VACUUM, 0); } } else { make_soid (y, STRONG, M_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. void mode_check_conditional_2 (SOID_T ** ry, NODE_T * p, SOID_T * x) { SOID_T enq_expct, enq_yield; make_soid (&enq_expct, MEEK, M_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. 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), M_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. 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, MEEK, M_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. 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), M_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. 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, M_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), M_INT, MEEK, SAFE_DEFLEXING, ENQUIRY_CLAUSE); } mode_check_loop_2 (NEXT (p), y); } else if (IS (p, WHILE_PART)) { SOID_T enq_expct, enq_yield; make_soid (&enq_expct, MEEK, M_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, M_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, M_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. void mode_check_loop (NODE_T * p, SOID_T * y) { SOID_T *z = NO_SOID; mode_check_loop_2 (p, z); make_soid (y, STRONG, M_VOID, 0); } //! @brief Mode check enclosed. 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, M_VOID, 0); MOID (NEXT_SUB (p)) = M_VOID; } else if (IS (p, COLLATERAL_CLAUSE)) { mode_check_collateral (SUB (p), x, y); } else if (IS (p, CONDITIONAL_CLAUSE)) { mode_check_conditional (SUB (p), x, y); } else if (IS (p, CASE_CLAUSE)) { mode_check_int_case (SUB (p), x, y); } else if (IS (p, CONFORMITY_CLAUSE)) { mode_check_united_case (SUB (p), x, y); } else if (IS (p, LOOP_CLAUSE)) { mode_check_loop (SUB (p), y); } MOID (p) = MOID (y); } //! @brief Search table for operator. TAG_T *search_table_for_operator (TAG_T * t, char *n, MOID_T * x, MOID_T * y) { if (is_mode_isnt_well (x)) { return A68_PARSER (error_tag); } else if (y != NO_MOID && is_mode_isnt_well (y)) { return A68_PARSER (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". 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 A68_PARSER (error_tag); } else if (y != NO_MOID && is_mode_isnt_well (y)) { return A68_PARSER (error_tag); } while (s != NO_TABLE) { TAG_T *z = search_table_for_operator (OPERATORS (s), n, x, y); if (z != NO_TAG) { return z; } BACKWARD (s); } return NO_TAG; } //! @brief Return a matching operator "x n y". 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 A68_PARSER (error_tag); } else if (y != NO_MOID && is_mode_isnt_well (y)) { return A68_PARSER (error_tag); } // (B) MONADs. if (x != NO_MOID && y == NO_MOID) { z = search_table_chain_for_operator (s, n, x, NO_MOID); if (z != NO_TAG) { return z; } else { // (B.2) A little trick to allow - (0, 1) or ABS (1, long pi). if (is_coercible (x, M_COMPLEX, STRONG, SAFE_DEFLEXING)) { z = search_table_for_operator (OPERATORS (A68_STANDENV), n, M_COMPLEX, NO_MOID); if (z != NO_TAG) { return z; } } if (is_coercible (x, M_LONG_COMPLEX, STRONG, SAFE_DEFLEXING)) { z = search_table_for_operator (OPERATORS (A68_STANDENV), n, M_LONG_COMPLEX, NO_MOID); if (z != NO_TAG) { return z; } } if (is_coercible (x, M_LONG_LONG_COMPLEX, STRONG, SAFE_DEFLEXING)) { z = search_table_for_operator (OPERATORS (A68_STANDENV), n, M_LONG_LONG_COMPLEX, NO_MOID); } } return NO_TAG; } // (C) DYADs. z = search_table_chain_for_operator (s, n, x, y); if (z != NO_TAG) { return z; } // (C.2) Vector and matrix "strong coercions" in standard environ. u = depref_completely (x); v = depref_completely (y); if ((u == M_ROW_REAL || u == M_ROW_ROW_REAL) || (v == M_ROW_REAL || v == M_ROW_ROW_REAL) || (u == M_ROW_COMPLEX || u == M_ROW_ROW_COMPLEX) || (v == M_ROW_COMPLEX || v == M_ROW_ROW_COMPLEX)) { if (u == M_INT) { z = search_table_for_operator (OPERATORS (A68_STANDENV), n, M_REAL, y); if (z != NO_TAG) { return z; } z = search_table_for_operator (OPERATORS (A68_STANDENV), n, M_COMPLEX, y); if (z != NO_TAG) { return z; } } else if (v == M_INT) { z = search_table_for_operator (OPERATORS (A68_STANDENV), n, x, M_REAL); if (z != NO_TAG) { return z; } z = search_table_for_operator (OPERATORS (A68_STANDENV), n, x, M_COMPLEX); if (z != NO_TAG) { return z; } } else if (u == M_REAL) { z = search_table_for_operator (OPERATORS (A68_STANDENV), n, M_COMPLEX, y); if (z != NO_TAG) { return z; } } else if (v == M_REAL) { z = search_table_for_operator (OPERATORS (A68_STANDENV), n, x, M_COMPLEX); if (z != NO_TAG) { return z; } } } // (C.3) Look in standenv for an appropriate cross-term. u = 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 (A68_STANDENV), n, v, v); if (z != NO_TAG) { return z; } if (is_coercible_series (u, M_REAL, STRONG, SAFE_DEFLEXING)) { z = search_table_for_operator (OPERATORS (A68_STANDENV), n, M_REAL, M_REAL); if (z != NO_TAG) { return z; } } if (is_coercible_series (u, M_LONG_REAL, STRONG, SAFE_DEFLEXING)) { z = search_table_for_operator (OPERATORS (A68_STANDENV), n, M_LONG_REAL, M_LONG_REAL); if (z != NO_TAG) { return z; } } if (is_coercible_series (u, M_LONG_LONG_REAL, STRONG, SAFE_DEFLEXING)) { z = search_table_for_operator (OPERATORS (A68_STANDENV), n, M_LONG_LONG_REAL, M_LONG_LONG_REAL); if (z != NO_TAG) { return z; } } if (is_coercible_series (u, M_COMPLEX, STRONG, SAFE_DEFLEXING)) { z = search_table_for_operator (OPERATORS (A68_STANDENV), n, M_COMPLEX, M_COMPLEX); if (z != NO_TAG) { return z; } } if (is_coercible_series (u, M_LONG_COMPLEX, STRONG, SAFE_DEFLEXING)) { z = search_table_for_operator (OPERATORS (A68_STANDENV), n, M_LONG_COMPLEX, M_LONG_COMPLEX); if (z != NO_TAG) { return z; } } if (is_coercible_series (u, M_LONG_LONG_COMPLEX, STRONG, SAFE_DEFLEXING)) { z = search_table_for_operator (OPERATORS (A68_STANDENV), n, M_LONG_LONG_COMPLEX, M_LONG_LONG_COMPLEX); if (z != NO_TAG) { return z; } } // (C.4) Now allow for depreffing for REF REAL +:= INT and alike. v = get_balanced_mode (u, STRONG, DEPREF, SAFE_DEFLEXING); z = search_table_for_operator (OPERATORS (A68_STANDENV), n, v, v); if (z != NO_TAG) { return z; } return NO_TAG; } //! @brief Mode check monadic operator. 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), M_ERROR, 0); } else if (u == M_HIP) { diagnostic (A68_ERROR, NEXT (p), ERROR_INVALID_OPERAND, u); make_soid (y, SORT (x), M_ERROR, 0); } else { if (strchr (NOMADS, *(NSYMBOL (p))) != NO_TEXT) { t = NO_TAG; diagnostic (A68_SYNTAX_ERROR, p, ERROR_OPERATOR_INVALID, NOMADS); make_soid (y, SORT (x), M_ERROR, 0); } else { t = find_operator (TABLE (p), NSYMBOL (p), u, NO_MOID); if (t == NO_TAG) { diagnostic (A68_ERROR, p, ERROR_NO_MONADIC, u); make_soid (y, SORT (x), M_ERROR, 0); } } if (t != NO_TAG) { MOID (p) = MOID (t); } TAX (p) = t; if (t != NO_TAG && t != A68_PARSER (error_tag)) { MOID (p) = MOID (t); make_soid (y, SORT (x), SUB_MOID (t), 0); } else { MOID (p) = M_ERROR; make_soid (y, SORT (x), M_ERROR, 0); } } } } //! @brief Mode check monadic formula. 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. 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), M_ERROR, 0); } else if (u == M_HIP) { diagnostic (A68_ERROR, p, ERROR_INVALID_OPERAND, u); make_soid (y, SORT (x), M_ERROR, 0); } else if (v == M_HIP) { diagnostic (A68_ERROR, q, ERROR_INVALID_OPERAND, u); make_soid (y, SORT (x), M_ERROR, 0); } else { op = find_operator (TABLE (NEXT (p)), NSYMBOL (NEXT (p)), u, v); if (op == NO_TAG) { diagnostic (A68_ERROR, NEXT (p), ERROR_NO_DYADIC, u, v); make_soid (y, SORT (x), M_ERROR, 0); } if (op != NO_TAG) { MOID (NEXT (p)) = MOID (op); } TAX (NEXT (p)) = op; if (op != NO_TAG && op != A68_PARSER (error_tag)) { make_soid (y, SORT (x), SUB_MOID (op), 0); } else { make_soid (y, SORT (x), M_ERROR, 0); } } } } //! @brief Mode check assignation. void mode_check_assignation (NODE_T * p, SOID_T * x, SOID_T * y) { SOID_T name, tmp, value; MOID_T *name_moid, *ori; // Get destination mode. make_soid (&name, SOFT, NO_MOID, 0); mode_check_unit (SUB (p), &name, &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 (A68_ERROR, p, ERROR_NO_NAME, ori, ATTRIBUTE (SUB (p))); } make_soid (y, SORT (x), M_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)) { cannot_coerce (p, MOID (&value), MOID (&name), STRONG, FORCE_DEFLEXING, UNIT); make_soid (y, SORT (x), M_ERROR, 0); } else { make_soid (y, SORT (x), name_moid, 0); } } //! @brief Mode check identity relation. 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 != M_HIP && ATTRIBUTE (lhs) != REF_SYMBOL) { diagnostic (A68_ERROR, ln, ERROR_NO_NAME, oril, ATTRIBUTE (SUB (ln))); lhs = M_ERROR; } if (IF_MODE_IS_WELL (rhs) && rhs != M_HIP && ATTRIBUTE (rhs) != REF_SYMBOL) { diagnostic (A68_ERROR, rn, ERROR_NO_NAME, orir, ATTRIBUTE (SUB (rn))); rhs = M_ERROR; } if (lhs == M_HIP && rhs == M_HIP) { diagnostic (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 = M_ERROR; } MOID (ln) = lhs; MOID (rn) = rhs; make_soid (y, SORT (x), M_BOOL, 0); } //! @brief Mode check bool functions ANDF and ORF. 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, M_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) = M_BOOL; MOID (rn) = M_BOOL; make_soid (y, SORT (x), M_BOOL, 0); } //! @brief Mode check cast. 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. void mode_check_assertion (NODE_T * p) { SOID_T w, y; make_soid (&w, STRONG, M_BOOL, 0); mode_check_enclosed (SUB_NEXT (p), &w, &y); SORT (&y) = SORT (&w); 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. 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 (A68_SYNTAX_ERROR, p, ERROR_SYNTAX, ARGUMENT); make_soid (&z, STRONG, M_ERROR, 0); add_mode_to_pack_end (v, M_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, M_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 (&A68_JOB)) { diagnostic (A68_SYNTAX_ERROR, p, ERROR_SYNTAX, CALL); } } } //! @brief Mode check argument list 2. 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. void mode_check_meek_int (NODE_T * p) { SOID_T x, y; make_soid (&x, MEEK, M_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. 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. 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. 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 (&A68_JOB), PARTIAL_PROC (GINFO (p))); PARTIAL_LOCALE (GINFO (p)) = register_extra_mode (&TOP_MOID (&A68_JOB), PARTIAL_LOCALE (GINFO (p))); if (DIM (MOID (&d)) != DIM (n)) { diagnostic (A68_ERROR, p, ERROR_ARGUMENT_NUMBER, n); make_soid (y, SORT (x), SUB (n), 0); // make_soid (y, SORT (x), M_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 (&A68_JOB)) { diagnostic (A68_WARNING | A68_FORCE_DIAGNOSTICS, NEXT (p), WARNING_EXTENSION); } make_soid (y, SORT (x), PARTIAL_PROC (GINFO (p)), 0); } } } //! @brief Mode check slice. 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_REF (n) && !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 (A68_ERROR, p, ERROR_NO_ROW_OR_PROC, n, ATTRIBUTE (SUB (p))); } make_soid (y, SORT (x), M_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 (A68_ERROR, p, ERROR_INDEXER_NUMBER, n); make_soid (y, SORT (x), M_ERROR, 0); } else { if (subs > 0 && trims == 0) { ANNOTATION (NEXT (p)) = SLICE; m = n; } else { ANNOTATION (NEXT (p)) = TRIMMER; m = n; } while (subs > 0) { if (is_ref) { m = NAME (m); } else { if (IS_FLEX (m)) { m = SUB (m); } m = SLICE (m); } ABEND (m == NO_MOID, ERROR_INTERNAL_CONSISTENCY, __func__); subs--; } // A trim cannot be but deflexed. if (ANNOTATION (NEXT (p)) == TRIMMER && TRIM (m) != NO_MOID) { ABEND (TRIM (m) == NO_MOID, ERROR_INTERNAL_CONSISTENCY, __func__); make_soid (y, SORT (x), TRIM (m), 0); } else { make_soid (y, SORT (x), m, 0); } } } //! @brief Mode check specification. 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_ROW (m) || IS_FLEX (m)) { // Assume SLICE. mode_check_slice (p, ori, x, y); return SLICE; } else { if (m != M_ERROR) { diagnostic (A68_SYNTAX_ERROR, p, ERROR_MODE_SPECIFICATION, m); } make_soid (y, SORT (x), M_ERROR, 0); return PRIMARY; } } //! @brief Mode check selection. 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_REF (n) && (IS_ROW (SUB (n)) || IS_FLEX (SUB (n))) && MULTIPLE (n) != NO_MOID) { coerce = A68_FALSE; deflex = A68_TRUE; t = PACK (MULTIPLE (n)); } else if ((IS_ROW (n) || IS_FLEX (n)) && MULTIPLE (n) != NO_MOID) { coerce = A68_FALSE; deflex = A68_TRUE; t = PACK (MULTIPLE (n)); } else if (IS_REF (n) && 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 (A68_ERROR, secondary, ERROR_NO_STRUCT, ori, ATTRIBUTE (secondary)); } make_soid (y, SORT (x), M_ERROR, 0); return; } MOID (NEXT (p)) = n; fs = NSYMBOL (SUB (p)); str = n; while (IS_REF (str)) { str = SUB (str); } if (IS_FLEX (str)) { str = SUB (str); } if (IS_ROW (str)) { str = SUB (str); } t_2 = PACK (str); while (t != NO_PACK && t_2 != NO_PACK) { if (TEXT (t) == fs) { 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 (A68_ERROR, p, ERROR_NO_FIELD, str, fs); make_soid (y, SORT (x), M_ERROR, 0); } //! @brief Mode check diagonal. 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, M_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_REF (n) && !is_ref_row (n)) { n = depref_once (n); } if (n != NO_MOID && (IS_FLEX (n) || IS_REF_FLEX (n))) { if (IF_MODE_IS_WELL (n)) { diagnostic (A68_ERROR, p, ERROR_NO_FLEX_ARGUMENT, ori, TERTIARY); } make_soid (y, SORT (x), M_ERROR, 0); return; } if (n == NO_MOID || !(SLICE (DEFLEX (n)) != NO_MOID || is_ref_row (n))) { if (IF_MODE_IS_WELL (n)) { diagnostic (A68_ERROR, p, ERROR_NO_MATRIX, ori, TERTIARY); } make_soid (y, SORT (x), M_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 (A68_ERROR, p, ERROR_NO_MATRIX, ori, TERTIARY); make_soid (y, SORT (x), M_ERROR, 0); return; } MOID (tert) = n; if (is_ref) { n = NAME (n); ABEND (!IS_REF (n), ERROR_INTERNAL_CONSISTENCY, PM (n)); } else { n = SLICE (n); } ABEND (n == NO_MOID, ERROR_INTERNAL_CONSISTENCY, __func__); make_soid (y, SORT (x), n, 0); } //! @brief Mode check transpose. 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_REF (n) && !is_ref_row (n)) { n = depref_once (n); } if (n != NO_MOID && (IS_FLEX (n) || IS_REF_FLEX (n))) { if (IF_MODE_IS_WELL (n)) { diagnostic (A68_ERROR, p, ERROR_NO_FLEX_ARGUMENT, ori, TERTIARY); } make_soid (y, SORT (x), M_ERROR, 0); return; } if (n == NO_MOID || !(SLICE (DEFLEX (n)) != NO_MOID || is_ref_row (n))) { if (IF_MODE_IS_WELL (n)) { diagnostic (A68_ERROR, p, ERROR_NO_MATRIX, ori, TERTIARY); } make_soid (y, SORT (x), M_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 (A68_ERROR, p, ERROR_NO_MATRIX, ori, TERTIARY); make_soid (y, SORT (x), M_ERROR, 0); return; } MOID (tert) = n; ABEND (n == NO_MOID, ERROR_INTERNAL_CONSISTENCY, __func__); make_soid (y, SORT (x), n, 0); } //! @brief Mode check row or column function. 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, M_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_REF (n) && !is_ref_row (n)) { n = depref_once (n); } if (n != NO_MOID && (IS_FLEX (n) || IS_REF_FLEX (n))) { if (IF_MODE_IS_WELL (n)) { diagnostic (A68_ERROR, p, ERROR_NO_FLEX_ARGUMENT, ori, TERTIARY); } make_soid (y, SORT (x), M_ERROR, 0); return; } if (n == NO_MOID || !(SLICE (DEFLEX (n)) != NO_MOID || is_ref_row (n))) { if (IF_MODE_IS_WELL (n)) { diagnostic (A68_ERROR, p, ERROR_NO_VECTOR, ori, TERTIARY); } make_soid (y, SORT (x), M_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 (A68_ERROR, p, ERROR_NO_VECTOR, ori, TERTIARY); make_soid (y, SORT (x), M_ERROR, 0); return; } MOID (tert) = n; ABEND (n == NO_MOID, ERROR_INTERNAL_CONSISTENCY, __func__); make_soid (y, SORT (x), ROWED (n), 0); } //! @brief Mode check format text. 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, M_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, M_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, M_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. 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, M_ERROR, NORMAL_IDENTIFIER); diagnostic (A68_ERROR, p, ERROR_UNDECLARED_TAG); MOID (p) = M_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, M_ERROR, NORMAL_IDENTIFIER); diagnostic (A68_ERROR, p, ERROR_UNDECLARED_TAG); MOID (p) = M_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), M_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, M_HIP, 0); } else if (IS (p, FORMULA)) { mode_check_formula (p, x, y); if (!IS_REF (MOID (y))) { 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)) { if (SORT (x) != STRONG) { diagnostic (A68_WARNING, p, WARNING_HIP, SORT (x)); } // make_soid (y, STRONG, M_HIP, 0); make_soid (y, SORT (x), M_HIP, 0); } else if (IS (p, ASSIGNATION)) { mode_check_assignation (SUB (p), x, y); } else if (IS (p, IDENTITY_RELATION)) { mode_check_identity_relation (SUB (p), x, y); 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, M_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, M_HIP, 0); } MOID (p) = MOID (y); } //! @brief Coerce bounds. void coerce_bounds (NODE_T * p) { for (; p != NO_NODE; FORWARD (p)) { if (IS (p, UNIT)) { SOID_T q; make_soid (&q, MEEK, M_INT, 0); coerce_unit (p, &q); } else { coerce_bounds (SUB (p)); } } } //! @brief Coerce declarer. 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. 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. 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. 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. 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. 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. 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. 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. 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, M_VOID, 0); coerce_unit (p, &strongvoid); } } } //! @brief Coerce closed. 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. void coerce_conditional (NODE_T * p, SOID_T * q) { SOID_T w; make_soid (&w, MEEK, M_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. 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. void coerce_int_case (NODE_T * p, SOID_T * q) { SOID_T w; make_soid (&w, MEEK, M_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. 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. 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. 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, M_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, M_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, M_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, M_BOOL, 0); coerce_serial (NEXT_SUB (un_p), &sw, A68_TRUE); } } } //! @brief Coerce struct display. 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. 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_FLEX (MOID (q))) { SOID_T w; make_soid (&w, STRONG, SLICE (SUB_MOID (q)), 0); coerce_unit_list (p, &w); } else if (IS_ROW (MOID (q))) { SOID_T w; make_soid (&w, STRONG, SLICE (MOID (q)), 0); coerce_unit_list (p, &w); } else { // if (MOID (q) != M_VOID). coerce_unit_list (p, q); } } } //! @brief Coerce_enclosed. 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. MOID_T *get_monad_moid (NODE_T * p) { if (TAX (p) != NO_TAG && TAX (p) != A68_PARSER (error_tag)) { MOID (p) = MOID (TAX (p)); return MOID (PACK (MOID (p))); } else { return M_ERROR; } } //! @brief Coerce monad oper. 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. 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. 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. 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)) != A68_PARSER (error_tag)) { SOID_T s; NODE_T *op = NEXT (p), *nq = NEXT_NEXT (p); MOID_T *w = MOID (op); MOID_T *u = MOID (PACK (w)), *v = MOID (NEXT (PACK (w))); make_soid (&s, STRONG, u, 0); coerce_operand (p, &s); make_soid (&s, STRONG, v, 0); coerce_operand (nq, &s); } } } //! @brief Coerce assignation. 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. 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. void coerce_bool_function (NODE_T * p) { SOID_T w; make_soid (&w, STRONG, M_BOOL, 0); coerce_unit (SUB (p), &w); coerce_unit (SUB (NEXT_NEXT (p)), &w); } //! @brief Coerce assertion. void coerce_assertion (NODE_T * p) { SOID_T w; make_soid (&w, MEEK, M_BOOL, 0); coerce_enclosed (SUB_NEXT (p), &w); } //! @brief Coerce selection. void coerce_selection (NODE_T * p) { SOID_T w; make_soid (&w, STRONG, MOID (NEXT (p)), 0); coerce_unit (SUB_NEXT (p), &w); } //! @brief Coerce cast. 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. 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. 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. void coerce_meek_int (NODE_T * p) { SOID_T x; make_soid (&x, MEEK, M_INT, 0); coerce_unit (p, &x); } //! @brief Coerce trimmer. 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. 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. void coerce_slice (NODE_T * p) { SOID_T w; MOID_T *row; row = MOID (p); make_soid (&w, STRONG, row, 0); coerce_unit (SUB (p), &w); coerce_indexer (SUB_NEXT (p)); } //! @brief Mode coerce diagonal. void coerce_diagonal (NODE_T * p) { SOID_T w; if (IS (p, TERTIARY)) { make_soid (&w, MEEK, M_INT, 0); coerce_unit (SUB (p), &w); FORWARD (p); } make_soid (&w, STRONG, MOID (NEXT (p)), 0); coerce_unit (SUB_NEXT (p), &w); } //! @brief Mode coerce transpose. void coerce_transpose (NODE_T * p) { SOID_T w; make_soid (&w, STRONG, MOID (NEXT (p)), 0); coerce_unit (SUB_NEXT (p), &w); } //! @brief Mode coerce row or column function. void coerce_row_column_function (NODE_T * p) { SOID_T w; if (IS (p, TERTIARY)) { make_soid (&w, MEEK, M_INT, 0); coerce_unit (SUB (p), &w); FORWARD (p); } make_soid (&w, STRONG, MOID (NEXT (p)), 0); coerce_unit (SUB_NEXT (p), &w); } //! @brief Coerce format text. 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, M_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, M_ROW_INT, 0); coerce_enclosed (SUB (NEXT_SUB (p)), &x); } else if (IS (p, DYNAMIC_REPLICATOR)) { SOID_T x; make_soid (&x, STRONG, M_INT, 0); coerce_enclosed (SUB (NEXT_SUB (p)), &x); } } } //! @brief Coerce unit. 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) != M_VOID) { diagnostic (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) == M_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. 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 (&A68_JOB) && !(STATUS_TEST (SUB (q), OPTIMAL_MASK))) {\ diagnostic (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 == M_LONG_LONG_INT && m == M_LONG_INT) { WARN_WIDENING; WIDEN; } if (lm == M_LONG_INT && m == M_INT) { WARN_WIDENING; WIDEN; } if (lm == M_LONG_LONG_REAL && m == M_LONG_REAL) { WARN_WIDENING; WIDEN; } if (lm == M_LONG_REAL && m == M_REAL) { WARN_WIDENING; WIDEN; } if (lm == M_LONG_REAL && m == M_LONG_INT) { WIDEN; } if (lm == M_REAL && m == M_INT) { WIDEN; } if (lm == M_LONG_LONG_BITS && m == M_LONG_BITS) { WARN_WIDENING; WIDEN; } if (lm == M_LONG_BITS && m == M_BITS) { WARN_WIDENING; WIDEN; } return; } } #undef WIDEN #undef WARN_WIDENING } algol68g-3.1.2/src/a68g/char.c0000644000175000017500000003723114361065320012504 00000000000000//! @file char.c //! @author J. Marcel van der Veer // //! @section Copyright // // This file is part of Algol68G - an Algol 68 compiler-interpreter. // Copyright 2001-2023 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" #include "a68g-genie.h" #include "a68g-prelude.h" #include "a68g-mp.h" #include "a68g-double.h" // CHAR, STRING and BYTES 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_VALUE (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 void genie_abs_char (NODE_T * p) { A68_CHAR i; POP_OBJECT (p, &i, A68_CHAR); PUSH_VALUE (p, TO_UCHAR (VALUE (&i)), A68_INT); } //! @brief OP REPR = (INT) CHAR 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, M_CHAR); PUSH_VALUE (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_VALUE (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 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), M_CHAR); // left part. POP_OBJECT (p, &a, A68_CHAR); CHECK_INIT (p, INITIALISED (&a), M_CHAR); // sum. c = heap_generator (p, M_STRING, DESCRIPTOR_SIZE (1)); d = heap_generator (p, M_STRING, 2 * SIZE (M_CHAR)); GET_DESCRIPTOR (a_3, t_3, &c); DIM (a_3) = 1; MOID (a_3) = M_CHAR; ELEM_SIZE (a_3) = SIZE (M_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 (M_CHAR)); MOVE ((BYTE_T *) & b_3[SIZE (M_CHAR)], (BYTE_T *) & b, SIZE (M_CHAR)); PUSH_REF (p, c); } //! @brief OP ELEM = (INT, STRING) CHAR # ALGOL68C # 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, M_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_VALUE (p, VALUE (ch), A68_CHAR); } //! @brief OP + = (STRING, STRING) STRING 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), M_STRING); GET_DESCRIPTOR (a_2, t_2, &b); l_2 = ROW_SIZE (t_2); // left part. POP_REF (p, &a); CHECK_REF (p, a, M_STRING); GET_DESCRIPTOR (a_1, t_1, &a); l_1 = ROW_SIZE (t_1); // sum. c = heap_generator (p, M_STRING, DESCRIPTOR_SIZE (1)); d = heap_generator (p, M_STRING, (l_1 + l_2) * SIZE (M_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) = M_CHAR; ELEM_SIZE (a_3) = SIZE (M_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 (M_CHAR)); m += SIZE (M_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 (M_CHAR)); m += SIZE (M_CHAR); } } PUSH_REF (p, c); } //! @brief OP * = (INT, STRING) STRING 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, M_INT); CHECK_INT_SHORTEN (p, VALUE (&k)); PUSH_REF (p, empty_string (p)); while (VALUE (&k)--) { PUSH_REF (p, a); genie_add_string (p); } } //! @brief OP * = (STRING, INT) STRING 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_VALUE (p, VALUE (&k), A68_INT); PUSH_REF (p, a); genie_times_int_string (p); } //! @brief OP * = (INT, CHAR) STRING 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, M_INT); CHECK_INT_SHORTEN (p, VALUE (&str_size)); // Make new string. NEW_ROW_1D (z, row, arr, tup, M_ROW_CHAR, M_CHAR, (int) (VALUE (&str_size))); 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 (M_CHAR)] = ch; } PUSH_REF (p, z); } //! @brief OP * = (CHAR, INT) STRING 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_VALUE (p, VALUE (&k), A68_INT); PUSH_VALUE (p, VALUE (&a), A68_CHAR); genie_times_int_char (p); } //! @brief OP +:= = (REF STRING, STRING) REF STRING void genie_plusab_string (NODE_T * p) { genie_f_and_becomes (p, M_REF_STRING, genie_add_string); } //! @brief OP +=: = (STRING, REF STRING) REF STRING void genie_plusto_string (NODE_T * p) { A68_REF refa, a, b; POP_REF (p, &refa); CHECK_REF (p, refa, M_REF_STRING); a = *DEREF (A68_REF, &refa); CHECK_INIT (p, INITIALISED (&a), M_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 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, M_INT); // REF STRING. POP_REF (p, &refa); CHECK_REF (p, refa, M_REF_STRING); a = *DEREF (A68_REF, &refa); CHECK_INIT (p, INITIALISED (&a), M_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. 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), M_STRING); GET_DESCRIPTOR (a_2, t_2, &row2); s_2 = ROW_SIZE (t_2); POP_REF (p, &row1); CHECK_INIT (p, INITIALISED (&row1), M_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_VALUE (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, >=) // BYTES operations. //! @brief OP ELEM = (INT, BYTES) CHAR 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, M_INT); if (VALUE (&i) > (int) strlen (VALUE (&j))) { genie_null_char (p); } else { PUSH_VALUE (p, VALUE (&j)[VALUE (&i) - 1], A68_CHAR); } } //! @brief PROC bytes pack = (STRING) BYTES void genie_bytespack (NODE_T * p) { A68_REF z; A68_BYTES b; POP_REF (p, &z); CHECK_REF (p, z, M_STRING); PRELUDE_ERROR (a68_string_size (p, z) > BYTES_WIDTH, p, ERROR_OUT_OF_BOUNDS, M_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 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, M_BYTES); bufcat (VALUE (i), VALUE (j), BYTES_WIDTH); } //! @brief OP +:= = (REF BYTES, BYTES) REF BYTES void genie_plusab_bytes (NODE_T * p) { genie_f_and_becomes (p, M_REF_BYTES, genie_add_bytes); } //! @brief OP +=: = (BYTES, REF BYTES) REF BYTES void genie_plusto_bytes (NODE_T * p) { A68_BYTES i, *address, j; A68_REF z; POP_REF (p, &z); CHECK_REF (p, z, M_REF_BYTES); address = DEREF (A68_BYTES, &z); CHECK_INIT (p, INITIALISED (address), M_BYTES); POP_OBJECT (p, &i, A68_BYTES); PRELUDE_ERROR (((int) strlen (VALUE (address)) + (int) strlen (VALUE (&i))) > BYTES_WIDTH, p, ERROR_OUT_OF_BOUNDS, M_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. 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_VALUE (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 void genie_leng_bytes (NODE_T * p) { A68_LONG_BYTES a; memset (VALUE (&a), 0, sizeof (VALUE (&a))); POP_OBJECT (p, (A68_BYTES *) &a, A68_BYTES); PUSH_LONG_BYTES (p, VALUE (&a)); } //! @brief OP SHORTEN = (LONG BYTES) BYTES 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, M_BYTES); PUSH_BYTES (p, VALUE (&a)); } //! @brief OP ELEM = (INT, LONG BYTES) CHAR 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, M_INT); if (VALUE (&i) > (int) strlen (VALUE (&j))) { genie_null_char (p); } else { PUSH_VALUE (p, VALUE (&j)[VALUE (&i) - 1], A68_CHAR); } } //! @brief PROC long bytes pack = (STRING) LONG BYTES void genie_long_bytespack (NODE_T * p) { A68_REF z; A68_LONG_BYTES b; POP_REF (p, &z); CHECK_REF (p, z, M_STRING); PRELUDE_ERROR (a68_string_size (p, z) > LONG_BYTES_WIDTH, p, ERROR_OUT_OF_BOUNDS, M_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 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, M_LONG_BYTES); bufcat (VALUE (i), VALUE (j), LONG_BYTES_WIDTH); } //! @brief OP +:= = (REF LONG BYTES, LONG BYTES) REF LONG BYTES void genie_plusab_long_bytes (NODE_T * p) { genie_f_and_becomes (p, M_REF_LONG_BYTES, genie_add_long_bytes); } //! @brief OP +=: = (LONG BYTES, REF LONG BYTES) REF LONG BYTES 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, M_REF_LONG_BYTES); address = DEREF (A68_LONG_BYTES, &z); CHECK_INIT (p, INITIALISED (address), M_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, M_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. 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_VALUE (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, >=) algol68g-3.1.2/src/a68g/plotutils.c0000644000175000017500000016031614361065320013627 00000000000000//! @file plotutils.c //! @author J. Marcel van der Veer // //! @section Copyright // // This file is part of Algol68G - an Algol 68 compiler-interpreter. // Copyright 2001-2023 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 . // 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" #include "a68g-genie.h" #include "a68g-numbers.h" #include "a68g-prelude.h" #if defined (HAVE_GNU_PLOTUTILS) // 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. BOOL_T string_to_colour (NODE_T * p, char *name, int *iindex) { A68_REF z_ref = heap_generator (p, M_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. 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 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, M_REF_FILE); file = FILE_DEREF (&ref_file); if (DEVICE_MADE (&DEVICE (file))) { diagnostic (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, M_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, M_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_VALUE (p, A68_TRUE, A68_BOOL); } //! @brief Closes the plotter. BOOL_T close_device (NODE_T * p, A68_FILE * f) { CHECK_INIT (p, INITIALISED (f), M_FILE); if (!OPENED (f)) { diagnostic (A68_RUNTIME_ERROR, p, ERROR_FILE_NOT_OPEN); exit_genie (p, A68_RUNTIME_ERROR); } if (!(DEVICE_OPENED (&DEVICE (f)))) { diagnostic (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 (A68_RUNTIME_ERROR, p, ERROR_CLOSING_DEVICE); exit_genie (p, A68_RUNTIME_ERROR); } if (pl_deletepl_r (PLOTTER (&DEVICE (f))) < 0) { diagnostic (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 (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. 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), M_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 (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 (A68_RUNTIME_ERROR, p, ERROR_FILE_NOT_OPEN); exit_genie (p, A68_RUNTIME_ERROR); } if (READ_MOOD (f)) { diagnostic (A68_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "read"); exit_genie (p, A68_RUNTIME_ERROR); } if (WRITE_MOOD (f)) { diagnostic (A68_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "write"); exit_genie (p, A68_RUNTIME_ERROR); } if (!DRAW (&CHANNEL (f))) { diagnostic (A68_RUNTIME_ERROR, p, ERROR_CHANNEL_DOES_NOT_ALLOW, "drawing"); exit_genie (p, A68_RUNTIME_ERROR); } if (!DEVICE_MADE (&DEVICE (f))) { diagnostic (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 (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 (A68_RUNTIME_ERROR, p, ERROR_PAGE_SIZE); exit_genie (p, A68_RUNTIME_ERROR); } if (!scan_int (&z, &(WINDOW_Y_SIZE (&DEVICE (f))))) { diagnostic (A68_RUNTIME_ERROR, p, ERROR_PAGE_SIZE); exit_genie (p, A68_RUNTIME_ERROR); } if (z[0] != NULL_CHAR) { diagnostic (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 (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 (A68_RUNTIME_ERROR, p, ERROR_DEVICE_CANNOT_OPEN); exit_genie (p, A68_RUNTIME_ERROR); } if (pl_openpl_r (PLOTTER (&DEVICE (f))) < 0) { diagnostic (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, "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 (A68_RUNTIME_ERROR, p, ERROR_PAGE_SIZE); exit_genie (p, A68_RUNTIME_ERROR); } if (!scan_int (&z, &(WINDOW_Y_SIZE (&DEVICE (f))))) { diagnostic (A68_RUNTIME_ERROR, p, ERROR_PAGE_SIZE); exit_genie (p, A68_RUNTIME_ERROR); } if (z[0] != NULL_CHAR) { diagnostic (A68_RUNTIME_ERROR, p, ERROR_PAGE_SIZE); exit_genie (p, A68_RUNTIME_ERROR); } // Open the output file for drawing. CHECK_REF (p, ref_filename, M_ROWS); filename = DEREF (char, &ref_filename); errno = 0; if ((STREAM (&DEVICE (f)) = fopen (filename, "wb")) == NO_STREAM) { diagnostic (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 (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 (A68_RUNTIME_ERROR, p, ERROR_DEVICE_CANNOT_OPEN); exit_genie (p, A68_RUNTIME_ERROR); } if (pl_openpl_r (PLOTTER (&DEVICE (f))) < 0) { diagnostic (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, "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 (A68_RUNTIME_ERROR, p, ERROR_PAGE_SIZE); exit_genie (p, A68_RUNTIME_ERROR); } if (!scan_int (&z, &(WINDOW_Y_SIZE (&DEVICE (f))))) { diagnostic (A68_RUNTIME_ERROR, p, ERROR_PAGE_SIZE); exit_genie (p, A68_RUNTIME_ERROR); } if (z[0] != NULL_CHAR) { diagnostic (A68_RUNTIME_ERROR, p, ERROR_PAGE_SIZE); exit_genie (p, A68_RUNTIME_ERROR); } // Open the output file for drawing. CHECK_REF (p, ref_filename, M_ROWS); filename = DEREF (char, &ref_filename); errno = 0; if ((STREAM (&DEVICE (f)) = fopen (filename, "wb")) == NO_STREAM) { diagnostic (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 (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 (A68_RUNTIME_ERROR, p, ERROR_DEVICE_CANNOT_OPEN); exit_genie (p, A68_RUNTIME_ERROR); } if (pl_openpl_r (PLOTTER (&DEVICE (f))) < 0) { diagnostic (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, "png")) { #if defined (X_DISPLAY_MISSING) diagnostic (A68_RUNTIME_ERROR, p, ERROR_INVALID_PARAMETER, "PNG plotter missing", ""); exit_genie (p, A68_RUNTIME_ERROR); #else /*-----------------------------+ | Supported plotter type - PNG | +-----------------------------*/ 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 (A68_RUNTIME_ERROR, p, ERROR_PAGE_SIZE); exit_genie (p, A68_RUNTIME_ERROR); } if (!scan_int (&z, &(WINDOW_Y_SIZE (&DEVICE (f))))) { diagnostic (A68_RUNTIME_ERROR, p, ERROR_PAGE_SIZE); exit_genie (p, A68_RUNTIME_ERROR); } if (z[0] != NULL_CHAR) { diagnostic (A68_RUNTIME_ERROR, p, ERROR_PAGE_SIZE); exit_genie (p, A68_RUNTIME_ERROR); } // Open the output file for drawing. CHECK_REF (p, ref_filename, M_ROWS); filename = DEREF (char, &ref_filename); errno = 0; if ((STREAM (&DEVICE (f)) = fopen (filename, "wb")) == NO_STREAM) { diagnostic (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 (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 ("png", NULL, STREAM (&DEVICE (f)), stderr, PLOTTER_PARAMS (&DEVICE (f))); if (PLOTTER (&DEVICE (f)) == NULL) { diagnostic (A68_RUNTIME_ERROR, p, ERROR_DEVICE_CANNOT_OPEN); exit_genie (p, A68_RUNTIME_ERROR); } if (pl_openpl_r (PLOTTER (&DEVICE (f))) < 0) { diagnostic (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, "ps")) { #if defined (POSTSCRIPT_MISSING) diagnostic (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, M_ROWS); filename = DEREF (char, &ref_filename); errno = 0; if ((STREAM (&DEVICE (f)) = fopen (filename, "w")) == NO_STREAM) { diagnostic (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 (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 (A68_RUNTIME_ERROR, p, ERROR_DEVICE_CANNOT_OPEN); exit_genie (p, A68_RUNTIME_ERROR); } if (pl_openpl_r (PLOTTER (&DEVICE (f))) < 0) { diagnostic (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 (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 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, M_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 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, M_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 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, M_REF_FILE); f = FILE_DEREF (&ref_file); plotter = set_up_device (p, f); PUSH_VALUE (p, (REAL_T) WINDOW_Y_SIZE (&DEVICE (f)) / (REAL_T) WINDOW_X_SIZE (&DEVICE (f)), A68_REAL); (void) plotter; } //! @brief PROC (REF FILE, INT) VOID draw fillstyle 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, M_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 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 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, M_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 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, M_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 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; REAL_T x, y, z; plPlotter *plotter; POP_REF (p, &ref_c); POP_REF (p, &ref_file); CHECK_REF (p, ref_file, M_REF_FILE); f = FILE_DEREF (&ref_file); name_ref = heap_generator (p, M_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 (A68_RUNTIME_ERROR, p, ERROR_INVALID_PARAMETER, "unidentified colour name", name); exit_genie (p, A68_RUNTIME_ERROR); } x = (REAL_T) (RED (&A68_COLOURS[iindex])) / (REAL_T) (0xff); y = (REAL_T) (GREEN (&A68_COLOURS[iindex])) / (REAL_T) (0xff); z = (REAL_T) (BLUE (&A68_COLOURS[iindex])) / (REAL_T) (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 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; REAL_T x, y, z; plPlotter *plotter; POP_REF (p, &ref_c); POP_REF (p, &ref_file); CHECK_REF (p, ref_file, M_REF_FILE); f = FILE_DEREF (&ref_file); name_ref = heap_generator (p, M_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 (A68_RUNTIME_ERROR, p, ERROR_INVALID_PARAMETER, "unidentified colour name", name); exit_genie (p, A68_RUNTIME_ERROR); } x = (REAL_T) (RED (&A68_COLOURS[iindex])) / (REAL_T) (0xff); y = (REAL_T) (GREEN (&A68_COLOURS[iindex])) / (REAL_T) (0xff); z = (REAL_T) (BLUE (&A68_COLOURS[iindex])) / (REAL_T) (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 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, M_REF_FILE); f = FILE_DEREF (&ref_file); plotter = set_up_device (p, f); size = a68_string_size (p, txt); z_ref = heap_generator (p, M_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 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, M_REF_FILE); f = FILE_DEREF (&ref_file); plotter = set_up_device (p, f); (void) pl_linewidth_r (plotter, (int) (VALUE (&width) * (REAL_T) WINDOW_Y_SIZE (&DEVICE (f)))); } //! @brief PROC (REF FILE, REAL, REAL) VOID draw move 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, M_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 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, M_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 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, M_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 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, M_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 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, M_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) * MAX (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 void genie_draw_atom (NODE_T * p) { A68_REAL x, y, r; REAL_T 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, M_REF_FILE); f = FILE_DEREF (&ref_file); plotter = set_up_device (p, f); k = (int) (VALUE (&r) * MAX (WINDOW_X_SIZE (&DEVICE (f)), WINDOW_Y_SIZE (&DEVICE (f)))); (void) pl_filltype_r (plotter, 1); for (j = k - 1; j >= 0; j--) { frac = (REAL_T) j / (REAL_T) (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)), (REAL_T) 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 void genie_draw_star (NODE_T * p) { A68_REAL x, y, r; REAL_T 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, M_REF_FILE); f = FILE_DEREF (&ref_file); plotter = set_up_device (p, f); k = (int) (VALUE (&r) * MAX (WINDOW_X_SIZE (&DEVICE (f)), WINDOW_Y_SIZE (&DEVICE (f)))); for (j = k; j >= 0; j--) { z = (REAL_T) j / (REAL_T) k; if (z < 0.2) { z = z / 0.2; frac = 0.5 * (1 + (cos (CONST_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)), (REAL_T) 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 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, M_REF_FILE); f = FILE_DEREF (&ref_file); plotter = set_up_device (p, f); size = a68_string_size (p, txt); z_ref = heap_generator (p, M_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 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, M_REF_FILE); f = FILE_DEREF (&ref_file); plotter = set_up_device (p, f); size = a68_string_size (p, txt); z_ref = heap_generator (p, M_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 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, M_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 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, M_REF_FILE); f = FILE_DEREF (&ref_file); plotter = set_up_device (p, f); (void) pl_textangle_r (plotter, (int) VALUE (&angle)); } #endif algol68g-3.1.2/src/a68g/single-gamic.c0000644000175000017500000003146014361065320014124 00000000000000//! @file single-gamic.c //! @author J. Marcel van der Veer // //! @section Copyright // // This file is part of Algol68G - an Algol 68 compiler-interpreter. // Copyright 2001-2023 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 . // Generalised incomplete gamma code in this file was downloaded from // http://helios.mi.parisdescartes.fr/~rabergel/ // and adapted for Algol 68 Genie. // // Reference: // Rémy Abergel, Lionel Moisan. Fast and accurate evaluation of a // generalized incomplete gamma function. 2019. hal-01329669v2 // // Original source code copyright and license: // // DELTAGAMMAINC Fast and Accurate Evaluation of a Generalized Incomplete Gamma // Function. Copyright (C) 2016 Remy Abergel (remy.abergel AT gmail.com), Lionel // Moisan (Lionel.Moisan AT parisdescartes.fr). // // This file is a part of the DELTAGAMMAINC software, dedicated to the // computation of a generalized incomplete gammafunction. See the Companion paper // for a complete description of the algorithm. // // ``Fast and accurate evaluation of a generalized incomplete gamma function'' // (Rémy Abergel, Lionel Moisan), preprint MAP5 nº2016-14, revision 1. // // 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 . // References // // R. Abergel and L. Moisan. 2016. Fast and accurate evaluation of a // generalized incomplete gamma function, preprint MAP5 nº2016-14, revision 1 // // Rémy Abergel, Lionel Moisan. Fast and accurate evaluation of a // generalized incomplete gamma function. 2019. hal-01329669v2 // // F. W. J. Olver, D. W. Lozier, R. F. Boisvert, and C. W. Clark // (Eds.). 2010. NIST Handbook of Mathematical Functions. Cambridge University // Press. (see online version at [[http://dlmf.nist.gov/]]) // // W. H. Press, S. A. Teukolsky, W. T. Vetterling, and // B. P. Flannery. 1992. Numerical recipes in C: the art of scientific // computing (2nd ed.). // // G. R. Pugh, 2004. An analysis of the Lanczos Gamma approximation (phd // thesis) #include "a68g.h" #include "a68g-genie.h" #include "a68g-prelude.h" #include "a68g-lib.h" #include "a68g-double.h" #include "a68g-mp.h" #define ITMAX 1000000000 // Maximum allowed number of iterations #define DPMIN DBL_MIN // Number near the smallest representable double-point number #define EPS DBL_EPSILON // Machine epsilon #define NITERMAX_ROMBERG 15 // Maximum allowed number of Romberg iterations #define TOL_ROMBERG 0.1 // Tolerance factor used to stop the Romberg iterations #define TOL_DIFF 0.2 // Tolerance factor used for the approximation of I_{x,y}^{mu,p} using differences // plim: compute plim (x), the limit of the partition of the domain (p,x) // detailed in the paper. // // | x if 0 < x // | // plim (x) = < 0 if -9 <= x <= 0 // | // | 5.*sqrt (|x|)-5. otherwise REAL_T plim (REAL_T x) { return (x >= 0) ? x : ((x >= -9) ? 0 : 5 * sqrt (-x) - 5); } //! @brief compute G(p,x) in the domain x <= p using a continued fraction // // p >= 0 // x <= p void G_cfrac_lower (REAL_T * Gcfrac, REAL_T p, REAL_T x) { REAL_T c, d, del, f, an, bn; INT_T k, n; // deal with special case if (x == 0) { *Gcfrac = 0; return; } // Evaluate the continued fraction using Modified Lentz's method. However, // as detailed in the paper, perform manually the first pass (n=1), of the // initial Modified Lentz's method. an = 1; bn = p; f = an / bn; c = an / DPMIN; d = 1 / bn; n = 2; do { k = n / 2; an = (n & 1 ? k : -(p - 1 + k)) * x; bn++; d = an * d + bn; if (d == 0) { d = DPMIN; } c = bn + an / c; if (c == 0) { c = DPMIN; } d = 1 / d; del = d * c; f *= del; n++; } while ((a68_abs (del - 1.0) >= EPS) && (n < ITMAX)); *Gcfrac = f; } //! @brief compute the G-function in the domain x < 0 and |x| < max (1,p-1) // using a recursive integration by parts relation. // This function cannot be used when mu > 0. // // p > 0, integer // x < 0, |x| < max (1,p-1) void G_ibp (REAL_T * Gibp, REAL_T p, REAL_T x) { REAL_T t, tt, c, d, s, del; INT_T l; BOOL_T odd, stop; t = a68_abs (x); tt = 1 / (t * t); odd = (INT_T) a68_int (p) % 2 != 0; c = 1 / t; d = (p - 1); s = c * (t - d); l = 0; do { c *= d * (d - 1) * tt; d -= 2; del = c * (t - d); s += del; l++; stop = a68_abs (del) < a68_abs (s) * EPS; } while ((l < floor ((p - 2) / 2)) && !stop); if (odd && !stop) { s += d * c / t; } *Gibp = ((odd ? -1 : 1) * a68_exp (-t + lgamma (p) - (p - 1) * a68_ln (t)) + s) / t; } //! @brief compute the G-function in the domain x > p using a // continued fraction. // // p > 0 // x > p, or x = +infinity void G_cfrac_upper (REAL_T * Gcfrac, REAL_T p, REAL_T x) { REAL_T c, d, del, f, an, bn; INT_T i, n; BOOL_T t; // Special case if (a68_isinf (x)) { *Gcfrac = 0; return; } // Evaluate the continued fraction using Modified Lentz's method. However, // as detailed in the paper, perform manually the first pass (n=1), of the // initial Modified Lentz's method. an = 1; bn = x + 1 - p; t = bn != 0; if (t) { // b{1} is non-zero f = an / bn; c = an / DPMIN; d = 1 / bn; n = 2; } else { // b{1}=0 but b{2} is non-zero, compute Mcfrac = a{1}/f with f = a{2}/(b{2}+) a{3}/(b{3}+) ... an = -(1 - p); bn = x + 3 - p; f = an / bn; c = an / DPMIN; d = 1 / bn; n = 3; } i = n - 1; do { an = -i * (i - p); bn += 2; d = an * d + bn; if (d == 0) { d = DPMIN; } c = bn + an / c; if (c == 0) { c = DPMIN; } d = 1 / d; del = d * c; f *= del; i++; n++; } while ((a68_abs (del - 1.0) >= EPS) && (n < ITMAX)); *Gcfrac = t ? f : 1 / f; } //! @brief compute G : (p,x) --> R defined as follows // // if x <= p: // G(p,x) = exp (x-p*ln (|x|)) * integral of s^{p-1} * exp (-sign (x)*s) ds from s = 0 to |x| // otherwise: // G(p,x) = exp (x-p*ln (|x|)) * integral of s^{p-1} * exp (-s) ds from s = x to infinity // // p > 0 // x is a real number or +infinity. void G_func (REAL_T * G, REAL_T p, REAL_T x) { if (p >= plim (x)) { G_cfrac_lower (G, p, x); } else if (x < 0) { G_ibp (G, p, x); } else { G_cfrac_upper (G, p, x); } } //! @brief iteration of the Romberg approximation of I_{x,y}^{mu,p} void romberg_iterations (REAL_T * R, REAL_T sigma, INT_T n, REAL_T x, REAL_T y, REAL_T mu, REAL_T p, REAL_T h, REAL_T pow2) { INT_T j, m; REAL_T sum, xx; INT_T adr0_prev = ((n - 1) * n) / 2; INT_T adr0 = (n * (n + 1)) / 2; for (sum = 0, j = 1; j <= pow2; j++) { xx = x + ((y - x) * (2 * j - 1)) / (2 * pow2); sum += a68_exp (-mu * xx + (p - 1) * a68_ln (xx) - sigma); } R[adr0] = 0.5 * R[adr0_prev] + h * sum; REAL_T pow4 = 4; for (m = 1; m <= n; m++) { R[adr0 + m] = (pow4 * R[adr0 + (m - 1)] - R[adr0_prev + (m - 1)]) / (pow4 - 1); pow4 *= 4; } } //! @ compute I_{x,y}^{mu,p} using a Romberg approximation. // Compute rho and sigma so I_{x,y}^{mu,p} = rho * exp (sigma) void romberg_estimate (REAL_T * rho, REAL_T * sigma, REAL_T x, REAL_T y, REAL_T mu, REAL_T p) { REAL_T *R = (REAL_T *) get_heap_space (((NITERMAX_ROMBERG + 1) * (NITERMAX_ROMBERG + 2)) / 2 * sizeof (REAL_T)); ASSERT (R != NULL); // Initialization (n=1) *sigma = -mu * y + (p - 1) * a68_ln (y); R[0] = 0.5 * (y - x) * (a68_exp (-mu * x + (p - 1) * a68_ln (x) - (*sigma)) + 1); // Loop for n > 0 REAL_T relneeded = EPS / TOL_ROMBERG; INT_T adr0 = 0; INT_T n = 1; REAL_T h = (y - x) / 2; // n=1, h = (y-x)/2^n REAL_T pow2 = 1; // n=1; pow2 = 2^(n-1) if (NITERMAX_ROMBERG >= 1) { REAL_T relerr; do { romberg_iterations (R, *sigma, n, x, y, mu, p, h, pow2); h /= 2; pow2 *= 2; adr0 = (n * (n + 1)) / 2; relerr = a68_abs ((R[adr0 + n] - R[adr0 + n - 1]) / R[adr0 + n]); n++; } while (n <= NITERMAX_ROMBERG && relerr > relneeded); } // save Romberg estimate and free memory *rho = R[adr0 + (n - 1)]; a68_free (R); } //! @brief compute generalized incomplete gamma function I_{x,y}^{mu,p} // // I_{x,y}^{mu,p} = integral from x to y of s^{p-1} * exp (-mu*s) ds // // This procedure computes (rho, sigma) described below. // The approximated value of I_{x,y}^{mu,p} is I = rho * exp (sigma) // // mu is a real number non equal to zero // (in general we take mu = 1 or -1 but any nonzero real number is allowed) // // x, y are two numbers with 0 <= x <= y <= +infinity, // (the setting y=+infinity is allowed only when mu > 0) // // p is a real number > 0, p must be an integer when mu < 0. void deltagammainc (REAL_T * rho, REAL_T * sigma, REAL_T x, REAL_T y, REAL_T mu, REAL_T p) { REAL_T mA, mB, mx, my, nA, nB, nx, ny; // Particular cases if (a68_isinf (x) && a68_isinf (y)) { *rho = 0; *sigma = a68_neginf (); return; } else if (x == y) { *rho = 0; *sigma = a68_neginf (); return; } if (x == 0 && a68_isinf (y)) { *rho = 1; (*sigma) = lgamma (p) - p * a68_ln (mu); return; } // Initialization G_func (&mx, p, mu * x); nx = (a68_isinf (x) ? a68_neginf () : -mu * x + p * a68_ln (x)); G_func (&my, p, mu * y); ny = (a68_isinf (y) ? a68_neginf () : -mu * y + p * a68_ln (y)); // Compute (mA,nA) and (mB,nB) such as I_{x,y}^{mu,p} can be // approximated by the difference A-B, where A >= B >= 0, A = mA*exp (nA) an // B = mB*exp (nB). When the difference involves more than one digit loss due to // cancellation errors, the integral I_{x,y}^{mu,p} is evaluated using the // Romberg approximation method. if (mu < 0) { mA = my; nA = ny; mB = mx; nB = nx; } else { if (p < plim (mu * x)) { mA = mx; nA = nx; mB = my; nB = ny; } else if (p < plim (mu * y)) { mA = 1; nA = lgamma (p) - p * a68_ln (mu); nB = fmax (nx, ny); mB = mx * a68_exp (nx - nB) + my * a68_exp (ny - nB); } else { mA = my; nA = ny; mB = mx; nB = nx; } } // Compute (rho,sigma) such that rho*exp (sigma) = A-B *rho = mA - mB * a68_exp (nB - nA); *sigma = nA; // If the difference involved a significant loss of precision, compute Romberg estimate. if (!a68_isinf (y) && ((*rho) / mA < TOL_DIFF)) { romberg_estimate (rho, sigma, x, y, mu, p); } } // A68G Driver routines //! @brief PROC gamma inc g = (REAL p, x, y, mu) REAL void genie_gamma_inc_g_real (NODE_T * n) { A68_REAL x, y, mu, p; POP_OBJECT (n, &mu, A68_REAL); POP_OBJECT (n, &y, A68_REAL); POP_OBJECT (n, &x, A68_REAL); POP_OBJECT (n, &p, A68_REAL); REAL_T rho, sigma; deltagammainc (&rho, &sigma, VALUE (&x), VALUE (&y), VALUE (&mu), VALUE (&p)); PUSH_VALUE (n, rho * a68_exp (sigma), A68_REAL); } //! @brief PROC gamma inc f = (REAL p, x) REAL void genie_gamma_inc_f_real (NODE_T * n) { A68_REAL x, p; POP_OBJECT (n, &x, A68_REAL); POP_OBJECT (n, &p, A68_REAL); REAL_T rho, sigma; deltagammainc (&rho, &sigma, VALUE (&x), a68_posinf (), 1, VALUE (&p)); PUSH_VALUE (n, rho * a68_exp (sigma), A68_REAL); } //! @brief PROC gamma inc = (REAL p, x) REAL void genie_gamma_inc_h_real (NODE_T * n) { #if (A68_LEVEL >= 3) && defined (HAVE_GNU_MPFR) genie_gamma_inc_real_mpfr (n); #else genie_gamma_inc_f_real (n); #endif } //! @brief PROC gamma inc gf = (REAL p, x) REAL void genie_gamma_inc_gf_real (NODE_T * q) { // if x <= p: G(p,x) = exp (x-p*ln (|x|)) * integral over [0,|x|] of s^{p-1} * exp (-sign (x)*s) ds // otherwise: G(p,x) = exp (x-p*ln (x)) * integral over [x,inf] of s^{p-1} * exp (-s) ds A68_REAL x, p; POP_OBJECT (q, &x, A68_REAL); POP_OBJECT (q, &p, A68_REAL); REAL_T G; G_func (&G, VALUE (&p), VALUE (&x)); PUSH_VALUE (q, G, A68_REAL); } algol68g-3.1.2/src/a68g/victal.c0000644000175000017500000002313114361065320013043 00000000000000//! @file victal.c //! @author J. Marcel van der Veer // //! @section Copyright // // This file is part of Algol68G - an Algol 68 compiler-interpreter. // Copyright 2001-2023 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 . // VICTAL checker for formal, actual and virtual declarers. #include "a68g.h" #include "a68g-parser.h" BOOL_T victal_check_declarer (NODE_T *, int); //! @brief Check generator. void victal_check_generator (NODE_T * p) { if (!victal_check_declarer (NEXT (p), ACTUAL_DECLARER_MARK)) { diagnostic (A68_SYNTAX_ERROR, p, ERROR_EXPECTED, "actual declarer"); } } //! @brief Check formal pack. 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. 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 (A68_SYNTAX_ERROR, p, ERROR_EXPECTED, "formal declarers"); } FORWARD (p); } if (!victal_check_declarer (NEXT (p), FORMAL_DECLARER_MARK)) { diagnostic (A68_SYNTAX_ERROR, p, ERROR_EXPECTED, "formal declarer"); } } //! @brief Check mode declaration. 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 (A68_SYNTAX_ERROR, p, ERROR_EXPECTED, "actual declarer"); } } } } //! @brief Check variable declaration. 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 (A68_SYNTAX_ERROR, p, ERROR_EXPECTED, "actual declarer"); } victal_check_variable_dec (NEXT (p)); } } } //! @brief Check identity declaration. 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 (A68_SYNTAX_ERROR, p, ERROR_EXPECTED, "formal declarer"); } victal_check_identity_dec (NEXT (p)); } } } //! @brief Check routine pack. 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. 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 (A68_SYNTAX_ERROR, p, ERROR_EXPECTED, "formal declarers"); } FORWARD (p); } if (!victal_check_declarer (p, FORMAL_DECLARER_MARK)) { diagnostic (A68_SYNTAX_ERROR, p, ERROR_EXPECTED, "formal declarer"); } victal_checker (NEXT (p)); } //! @brief Check structure pack. 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. 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. 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_REF (p)) { return victal_check_declarer (NEXT (p), VIRTUAL_DECLARER_MARK); } else if (IS_FLEX (p)) { return victal_check_declarer (NEXT (p), x); } else if (IS (p, BOUNDS)) { victal_checker (SUB (p)); if (x == FORMAL_DECLARER_MARK) { diagnostic (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 (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 (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 (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 (A68_SYNTAX_ERROR, p, ERROR_EXPECTED, "formal declarer"); } FORWARD (p); } if (!victal_check_declarer (NEXT (p), FORMAL_DECLARER_MARK)) { diagnostic (A68_SYNTAX_ERROR, p, ERROR_EXPECTED, "formal declarer"); } return A68_TRUE; } else { return A68_FALSE; } } //! @brief Check cast. void victal_check_cast (NODE_T * p) { if (!victal_check_declarer (p, FORMAL_DECLARER_MARK)) { diagnostic (A68_SYNTAX_ERROR, p, ERROR_EXPECTED, "formal declarer"); victal_checker (NEXT (p)); } } //! @brief Driver for checking VICTALITY of declarers. 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)); } } } algol68g-3.1.2/src/a68g/moid-to-string.c0000644000175000017500000002265114361065320014443 00000000000000//! @file moid-to-string.c //! @author J. Marcel van der Veer // //! @section Copyright // // This file is part of Algol68G - an Algol 68 compiler-interpreter. // Copyright 2001-2023 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" #include "a68g-prelude.h" #include "a68g-mp.h" #include "a68g-genie.h" #include "a68g-postulates.h" // A pretty printer for moids. // For example "PROC (REF STRUCT (REF SELF, UNION (INT, VOID))) REF SELF" // for a procedure yielding a pointer to an object of its own mode. void moid_to_string_2 (char *, MOID_T *, int *, NODE_T *); //! @brief Add string to MOID text. 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. 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. 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. 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 (A68 (postulates), n)) { add_to_moid_text (b, "SELF", w); return; } // If declared by a mode-declaration, present the indicant. if (idf != NO_NODE && !IS (n, STANDARD)) { TAG_T *indy = find_indicant_global (TABLE (idf), n); if (indy != NO_TAG) { add_to_moid_text (b, NSYMBOL (NODE (indy)), w); return; } } // Write the standard modes. if (n == M_HIP) { add_to_moid_text (b, "HIP", w); } else if (n == M_ERROR) { add_to_moid_text (b, "ERROR", w); } else if (n == M_UNDEFINED) { add_to_moid_text (b, "unresolved mode", w); } else if (n == M_C_STRING) { add_to_moid_text (b, "C-STRING", w); } else if (n == M_COMPLEX || n == M_COMPL) { add_to_moid_text (b, "COMPLEX", w); } else if (n == M_LONG_COMPLEX || n == M_LONG_COMPL) { add_to_moid_text (b, "LONG COMPLEX", w); } else if (n == M_LONG_LONG_COMPLEX || n == M_LONG_LONG_COMPL) { add_to_moid_text (b, "LONG LONG COMPLEX", w); } else if (n == M_STRING) { add_to_moid_text (b, "STRING", w); } else if (n == M_PIPE) { add_to_moid_text (b, "PIPE", w); } else if (n == M_SOUND) { add_to_moid_text (b, "SOUND", w); } else if (n == M_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 == M_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_REF (n)) { 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_FLEX (n)) { 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_ROW (n)) { 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_STRUCT (n)) { int j = (int) strlen ("STRUCT ()") + (DIM (n) - 1) * (int) strlen (".., ") + (int) strlen (".."); if ((*w) >= j) { POSTULATE_T *save = A68 (postulates); make_postulate (&A68 (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 (A68 (postulates), save); A68 (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_UNION (n)) { int j = (int) strlen ("UNION ()") + (DIM (n) - 1) * (int) strlen (".., ") + (int) strlen (".."); if ((*w) >= j) { POSTULATE_T *save = A68 (postulates); make_postulate (&A68 (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 (A68 (postulates), save); A68 (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 = A68 (postulates); make_postulate (&A68 (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 (A68 (postulates), save); A68 (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. char *moid_to_string (MOID_T * n, int w, NODE_T * idf) { #define MAX_MTS 8 // We use a static buffer of MAX_MTS strings. This value 8 should be safe. // No more than MAX_MTS calls can be pending in for instance printf. // Instead we could allocate each string on the heap but that leaks memory. static int mts_buff_ptr = 0; static char mts_buff[8][BUFFER_SIZE]; char *a = &(mts_buff[mts_buff_ptr][0]); mts_buff_ptr++; if (mts_buff_ptr >= MAX_MTS) { mts_buff_ptr = 0; } a[0] = NULL_CHAR; if (w >= BUFFER_SIZE) { w = BUFFER_SIZE - 1; } A68 (postulates) = NO_POSTULATE; if (n != NO_MOID) { moid_to_string_2 (a, n, &w, idf); } else { bufcat (a, "null", BUFFER_SIZE); } return a; #undef MAX_MTS } algol68g-3.1.2/src/a68g/top-down.c0000644000175000017500000004756514361065320013351 00000000000000//! @file top-down.c //! @author J. Marcel van der Veer // //! @section Copyright // // This file is part of Algol68G - an Algol 68 compiler-interpreter. // Copyright 2001-2023 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" #include "a68g-parser.h" // Top-down parser, elaborates the control structure. //! @brief Substitute brackets. 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 Intelligible diagnostic from syntax tree branch. 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 (A68 (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, " and", BUFFER_SIZE); } // Attribute or symbol. if (z != NO_TEXT && SUB (p) != NO_NODE) { if (gatt == IDENTIFIER || gatt == OPERATOR || gatt == DENOTATION) { ASSERT (snprintf (A68 (edit_line), SNPRINTF_SIZE, " \"%s\"", NSYMBOL (p)) >= 0); bufcat (buffer, A68 (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 (A68 (edit_line), SNPRINTF_SIZE, " %s", z) >= 0); bufcat (buffer, A68 (edit_line), BUFFER_SIZE); } } else if (z != NO_TEXT && SUB (p) == NO_NODE) { ASSERT (snprintf (A68 (edit_line), SNPRINTF_SIZE, " \"%s\"", NSYMBOL (p)) >= 0); bufcat (buffer, A68 (edit_line), BUFFER_SIZE); } else if (NSYMBOL (p) != NO_TEXT) { ASSERT (snprintf (A68 (edit_line), SNPRINTF_SIZE, " \"%s\"", NSYMBOL (p)) >= 0); bufcat (buffer, A68 (edit_line), BUFFER_SIZE); } // Add "starting in line nn". if (z != NO_TEXT && line != LINE_NUMBER (p)) { line = LINE_NUMBER (p); if (gatt == SERIAL_CLAUSE || gatt == ENQUIRY_CLAUSE || gatt == INITIALISER_SERIES) { bufcat (buffer, " starting", BUFFER_SIZE); } ASSERT (snprintf (A68 (edit_line), SNPRINTF_SIZE, " in line %d", line) >= 0); bufcat (buffer, A68 (edit_line), BUFFER_SIZE); } count++; } } if (p != NO_NODE && count == MAX_TERMINALS) { bufcat (buffer, " etcetera", BUFFER_SIZE); } return buffer; } // Next is a top-down parser that branches out the basic blocks. // After this we can assign symbol tables to basic blocks. // This renders the two-level grammar LALR. //! @brief Give diagnose from top-down parser. 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 (A68_SYNTAX_ERROR, issue, ERROR_EXPECTED_NEAR, expected, clause, NSYMBOL (start), LINE (INFO (start))); } else { diagnostic (A68_SYNTAX_ERROR, issue, ERROR_UNBALANCED_KEYWORD, clause, NSYMBOL (start), LINE (INFO (start))); } } //! @brief Check for premature exhaustion of tokens. void tokens_exhausted (NODE_T * p, NODE_T * q) { if (p == NO_NODE) { diagnostic (A68_SYNTAX_ERROR, q, ERROR_KEYWORD); longjmp (A68_PARSER (top_down_crash_exit), 1); } } // This part specifically branches out loop clauses. //! @brief Whether in cast or formula with loop clause. int is_loop_cast_formula (NODE_T * p) { // Accept declarers that can appear in such casts but not much more. if (IS (p, VOID_SYMBOL)) { return 1; } else if (IS (p, INT_SYMBOL)) { return 1; } else if (IS_REF (p)) { return 1; } else if (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). 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. 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. 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 (A68_PARSER (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 (A68_PARSER (top_down_crash_exit), 1); } } if (IS (q, FROM_SYMBOL)) { start = q; q = top_down_skip_loop_unit (NEXT (q)); tokens_exhausted (q, start); if (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 (A68_PARSER (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 (A68_PARSER (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 (A68_PARSER (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 (A68_PARSER (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 (!IS (q, OD_SYMBOL)) { top_down_diagnose (start, q, LOOP_CLAUSE, OD_SYMBOL); longjmp (A68_PARSER (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. 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. 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). 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. NODE_T *top_down_begin (NODE_T * begin_p) { NODE_T *end_p = top_down_series (NEXT (begin_p)); if (end_p == NO_NODE || !IS (end_p, END_SYMBOL)) { top_down_diagnose (begin_p, end_p, ENCLOSED_CLAUSE, END_SYMBOL); longjmp (A68_PARSER (top_down_crash_exit), 1); return NO_NODE; } else { make_sub (begin_p, end_p, BEGIN_SYMBOL); return NEXT (begin_p); } } //! @brief Make branch of CODE .. EDOC. NODE_T *top_down_code (NODE_T * code_p) { NODE_T *edoc_p = top_down_series (NEXT (code_p)); if (edoc_p == NO_NODE || !IS (edoc_p, EDOC_SYMBOL)) { diagnostic (A68_SYNTAX_ERROR, code_p, ERROR_KEYWORD); longjmp (A68_PARSER (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 ( .. ). 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 || !IS (then_bar_p, THEN_BAR_SYMBOL)) { top_down_diagnose (open_p, then_bar_p, ENCLOSED_CLAUSE, STOP); longjmp (A68_PARSER (top_down_crash_exit), 1); } 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 || !IS (close_p, CLOSE_SYMBOL)) { top_down_diagnose (open_p, elif_bar_p, ENCLOSED_CLAUSE, CLOSE_SYMBOL); longjmp (A68_PARSER (top_down_crash_exit), 1); } 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 (A68_PARSER (top_down_crash_exit), 1); return NO_NODE; } } //! @brief Make branch of [ .. ]. 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 (A68_PARSER (top_down_crash_exit), 1); return NO_NODE; } } //! @brief Make branch of { .. }. 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 (A68_PARSER (top_down_crash_exit), 1); return NO_NODE; } } //! @brief Make branch of IF .. THEN .. ELSE .. FI. NODE_T *top_down_if (NODE_T * if_p) { NODE_T *then_p = top_down_series (NEXT (if_p)), *elif_p; if (then_p == NO_NODE || !IS (then_p, THEN_SYMBOL)) { top_down_diagnose (if_p, then_p, CONDITIONAL_CLAUSE, THEN_SYMBOL); longjmp (A68_PARSER (top_down_crash_exit), 1); } 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 || !IS (fi_p, FI_SYMBOL)) { top_down_diagnose (if_p, fi_p, CONDITIONAL_CLAUSE, FI_SYMBOL); longjmp (A68_PARSER (top_down_crash_exit), 1); } else { 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 (A68_PARSER (top_down_crash_exit), 1); return NO_NODE; } } //! @brief Make branch of CASE .. IN .. OUT .. ESAC. NODE_T *top_down_case (NODE_T * case_p) { NODE_T *in_p = top_down_series (NEXT (case_p)), *ouse_p; if (in_p == NO_NODE || !IS (in_p, IN_SYMBOL)) { top_down_diagnose (case_p, in_p, ENCLOSED_CLAUSE, IN_SYMBOL); longjmp (A68_PARSER (top_down_crash_exit), 1); } 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 || !IS (esac_p, ESAC_SYMBOL)) { top_down_diagnose (case_p, esac_p, ENCLOSED_CLAUSE, ESAC_SYMBOL); longjmp (A68_PARSER (top_down_crash_exit), 1); } else { 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 (A68_PARSER (top_down_crash_exit), 1); return NO_NODE; } } //! @brief Skip a unit. 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; } NODE_T *top_down_skip_format (NODE_T *); //! @brief Make branch of ( .. ) in a format. 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 (A68_PARSER (top_down_crash_exit), 1); return NO_NODE; } } //! @brief Skip a format text. 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 $ .. $. 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 && !IS (f, FORMAT_DELIMITER_SYMBOL)) { if (IS (f, FORMAT_OPEN_SYMBOL)) { f = top_down_format_open (f); } else { f = NEXT (f); } } if (f == NO_NODE) { top_down_diagnose (p, f, FORMAT_TEXT, FORMAT_DELIMITER_SYMBOL); longjmp (A68_PARSER (top_down_crash_exit), 1); } else { make_sub (q, f, FORMAT_DELIMITER_SYMBOL); } } } } //! @brief Make branches of phrases for the bottom-up parser. void top_down_parser (NODE_T * p) { if (p != NO_NODE) { if (!setjmp (A68_PARSER (top_down_crash_exit))) { (void) top_down_series (p); top_down_loops (p); top_down_untils (p); top_down_formats (p); } } } algol68g-3.1.2/src/a68g/mp-gamic.c0000644000175000017500000007041414361065320013261 00000000000000//! @file mp-gamic.c //! @author J. Marcel van der Veer // //! @section Copyright // // This file is part of Algol68G - an Algol 68 compiler-interpreter. // Copyright 2001-2023 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 . // Generalised incomplete gamma code in this file was downloaded from // http://helios.mi.parisdescartes.fr/~rabergel/ // and adapted for Algol 68 Genie. // // Reference: // Rémy Abergel, Lionel Moisan. Fast and accurate evaluation of a // generalized incomplete gamma function. 2019. hal-01329669v2 // // Original source code copyright and license: // // DELTAGAMMAINC Fast and Accurate Evaluation of a Generalized Incomplete Gamma // Function. Copyright (C) 2016 Remy Abergel (remy.abergel AT gmail.com), Lionel // Moisan (Lionel.Moisan AT parisdescartes.fr). // // This file is a part of the DELTAGAMMAINC software, dedicated to the // computation of a generalized incomplete gammafunction. See the Companion paper // for a complete description of the algorithm. // // ``Fast and accurate evaluation of a generalized incomplete gamma function'' // (Rémy Abergel, Lionel Moisan), preprint MAP5 nº2016-14, revision 1. // // 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 . // References // // R. Abergel and L. Moisan. 2016. Fast and accurate evaluation of a // generalized incomplete gamma function, preprint MAP5 nº2016-14, revision 1 // // Rémy Abergel, Lionel Moisan. Fast and accurate evaluation of a // generalized incomplete gamma function. 2019. hal-01329669v2 // // F. W. J. Olver, D. W. Lozier, R. F. Boisvert, and C. W. Clark // (Eds.). 2010. NIST Handbook of Mathematical Functions. Cambridge University // Press. (see online version at [[http://dlmf.nist.gov/]]) // // W. H. Press, S. A. Teukolsky, W. T. Vetterling, and // B. P. Flannery. 1992. Numerical recipes in C: the art of scientific // computing (2nd ed.). // // G. R. Pugh, 2004. An analysis of the Lanczos Gamma approximation (phd // thesis) #include "a68g.h" #include "a68g-genie.h" #include "a68g-prelude.h" #include "a68g-double.h" #include "a68g-mp.h" #include "a68g-lib.h" // Processing time of Abergel's algorithms rises steeply with precision. #define MAX_PRECISION (LONG_LONG_MP_DIGITS + LONG_MP_DIGITS) #define GAM_DIGITS(digs) FUN_DIGITS (digs) #define ITMAX(p, digits) lit_mp (p, 1000000, 0, digits); #define DPMIN(p, digits) lit_mp (p, 1, 10 - MAX_MP_EXPONENT, digits) #define EPS(p, digits) lit_mp (p, 1, 1 - digits, digits) #define NITERMAX_ROMBERG 16 // Maximum allowed number of Romberg iterations #define TOL_ROMBERG(p, digits) lit_mp (p, MP_RADIX / 10, -1, digits) #define TOL_DIFF(p, digits) lit_mp (p, MP_RADIX / 5, -1, digits) //! @brief compute G(p,x) in the domain x <= p >= 0 using a continued fraction MP_T *G_cfrac_lower_mp (NODE_T *q, MP_T * Gcfrac, MP_T *p, MP_T *x, int digs) { if (IS_ZERO_MP (x)) { SET_MP_ZERO (Gcfrac, digs); return Gcfrac; } ADDR_T pop_sp = A68_SP; MP_T *c = nil_mp (q, digs); MP_T *d = nil_mp (q, digs); MP_T *del = nil_mp (q, digs); MP_T *f = nil_mp (q, digs); // Evaluate the continued fraction using Modified Lentz's method. However, // as detailed in the paper, perform manually the first pass (n=1), of the // initial Modified Lentz's method. // an = 1; bn = p; f = an / bn; c = an / DPMIN; d = 1 / bn; n = 2; MP_T *an = lit_mp (q, 1, 0, digs); MP_T *bn = nil_mp (q, digs); MP_T *trm = nil_mp (q, digs); MP_T *dpmin = DPMIN (q, digs); MP_T *eps = EPS (q, digs); MP_T *itmax = ITMAX (q, digs); (void) move_mp (bn, p, digs); (void) div_mp (q, f, an, bn, digs); (void) div_mp (q, c, an, dpmin, digs); (void) rec_mp (q, d, bn, digs); MP_T *n = lit_mp (q, 2, 0, digs); MP_T *k = nil_mp (q, digs); MP_T *two = lit_mp (q, 2, 0, digs); BOOL_T odd = A68_FALSE, cont = A68_TRUE; while (cont) { A68_BOOL ge, lt; // k = n / 2; (void) over_mp (q, k, n, two, digs); // an = (n & 1 ? k : -(p - 1 + k)) * x; if (odd) { (void) move_mp (an, k, digs); odd = A68_FALSE; } else { (void) minus_one_mp (q, trm, p, digs); (void) add_mp (q, trm, trm, k, digs); (void) minus_mp (q, an, trm, digs); odd = A68_TRUE; } (void) mul_mp (q, an, an, x, digs); // bn++; (void) plus_one_mp (q, bn, bn, digs); // d = an * d + bn; (void) mul_mp (q, trm, an, d, digs); (void) add_mp (q, d, trm, bn, digs); // if (d == 0) { d = DPMIN; } if (IS_ZERO_MP (d)) { (void) move_mp (d, dpmin, digs); } // c = bn + an / c; mind possible overflow. (void) div_mp (q, trm, an, c, digs); (void) add_mp (q, c, bn, trm, digs); // if (c == 0) { c = DPMIN; } if (IS_ZERO_MP (c)) { (void) move_mp (c, dpmin, digs); } // d = 1 / d; (void) rec_mp (q, d, d, digs); // del = d * c; (void) mul_mp (q, del, d, c, digs); // f *= del; (void) mul_mp (q, f, f, del, digs); // n++; (void) plus_one_mp (q, n, n, digs); // while ((fabsq (del - 1) >= EPS) && (n < ITMAX)); (void) minus_one_mp (q, trm, del, digs); (void) abs_mp (q, trm, trm, digs); (void) ge_mp (q, &ge, trm, eps, digs); (void) lt_mp (q, <, n, itmax, digs); cont = VALUE (&ge) && VALUE (<); } (void) move_mp (Gcfrac, f, digs); A68_SP = pop_sp; return Gcfrac; } //! @brief compute the G-function in the domain x > p using a // continued fraction. // // 0 < p < x, or x = +infinity MP_T *G_cfrac_upper_mp (NODE_T *q, MP_T * Gcfrac, MP_T *p, MP_T *x, int digs) { ADDR_T pop_sp = A68_SP; if (PLUS_INF_MP (x)) { SET_MP_ZERO (Gcfrac, digs); return Gcfrac; } MP_T *c = nil_mp (q, digs); MP_T *d = nil_mp (q, digs); MP_T *del = nil_mp (q, digs); MP_T *f = nil_mp (q, digs); MP_T *trm = nil_mp (q, digs); MP_T *dpmin = DPMIN (q, digs); MP_T *eps = EPS (q, digs); MP_T *itmax = ITMAX (q, digs); MP_T *n = lit_mp (q, 2, 0, digs); MP_T *i = nil_mp (q, digs); MP_T *two = lit_mp (q, 2, 0, digs); // an = 1; MP_T *an = lit_mp (q, 1, 0, digs); // bn = x + 1 - p; MP_T *bn = lit_mp (q, 1, 0, digs); (void) add_mp (q, bn, x, bn, digs); (void) sub_mp (q, bn, bn, p, digs); BOOL_T t = !IS_ZERO_MP (bn); // Evaluate the continued fraction using Modified Lentz's method. However, // as detailed in the paper, perform manually the first pass (n=1), of the // initial Modified Lentz's method. if (t) { // b{1} is non-zero // f = an / bn; (void) div_mp (q, f, an, bn, digs); // c = an / DPMIN; (void) div_mp (q, c, an, dpmin, digs); // d = 1 / bn; (void) rec_mp (q, d, bn, digs); // n = 2; set_mp (n, 2, 0, digs); } else { // b{1}=0 but b{2} is non-zero, compute Mcfrac = a{1}/f with f = a{2}/(b{2}+) a{3}/(b{3}+) ... // an = -(1 - p); (void) minus_one_mp (q, an, p, digs); // bn = x + 3 - p; (void) set_mp (bn, 3, 0, digs); (void) add_mp (q, bn, x, bn, digs); (void) sub_mp (q, bn, bn, p, digs); // f = an / bn; (void) div_mp (q, f, an, bn, digs); // c = an / DPMIN; (void) div_mp (q, c, an, dpmin, digs); // d = 1 / bn; (void) rec_mp (q, d, bn, digs); // n = 3; set_mp (n, 3, 0, digs); } // i = n - 1; minus_one_mp (q, i, n, digs); BOOL_T cont = A68_TRUE; while (cont) { A68_BOOL ge, lt; // an = -i * (i - p); (void) sub_mp (q, trm, p, i, digs); (void) mul_mp (q, an, i, trm, digs); // bn += 2; (void) add_mp (q, bn, bn, two, digs); // d = an * d + bn; (void) mul_mp (q, trm, an, d, digs); (void) add_mp (q, d, trm, bn, digs); // if (d == 0) { d = DPMIN; } if (IS_ZERO_MP (d)) { (void) move_mp (d, dpmin, digs); } // c = bn + an / c; mind possible overflow. (void) div_mp (q, trm, an, c, digs); (void) add_mp (q, c, bn, trm, digs); // if (c == 0) { c = DPMIN; } if (IS_ZERO_MP (c)) { (void) move_mp (c, dpmin, digs); } // d = 1 / d; (void) rec_mp (q, d, d, digs); // del = d * c; (void) mul_mp (q, del, d, c, digs); // f *= del; (void) mul_mp (q, f, f, del, digs); // i++; (void) plus_one_mp (q, i, i, digs); // n++; (void) plus_one_mp (q, n, n, digs); // while ((fabsq (del - 1) >= EPS) && (n < ITMAX)); (void) minus_one_mp (q, trm, del, digs); (void) abs_mp (q, trm, trm, digs); (void) ge_mp (q, &ge, trm, eps, digs); (void) lt_mp (q, <, n, itmax, digs); cont = VALUE (&ge) && VALUE (<); } A68_SP = pop_sp; // *Gcfrac = t ? f : 1 / f; if (t) { (void) move_mp (Gcfrac, f, digs); } else { (void) rec_mp (q, Gcfrac, f, digs); } return Gcfrac; } //! @brief compute the G-function in the domain x < 0 and |x| < max (1,p-1) // using a recursive integration by parts relation. // This function cannot be used when mu > 0. // // p > 0, integer; x < 0, |x| < max (1,p-1) MP_T *G_ibp_mp (NODE_T *q, MP_T * Gibp, MP_T *p, MP_T *x, int digs) { ADDR_T pop_sp = A68_SP; MP_T *trm = nil_mp (q, digs), *trn = nil_mp (q, digs); MP_T *eps = EPS (q, digs); // t = fabsq (x); MP_T *t = nil_mp (q, digs); (void) abs_mp (q, x, x, digs); // tt = 1 / (t * t); MP_T *tt = nil_mp (q, digs); (void) mul_mp (q, tt, t, t, digs); (void) rec_mp (q, tt, tt, digs); // odd = (INT_T) (p) % 2 != 0; MP_T *two = lit_mp (q, 2, 0, digs); (void) trunc_mp (q, trm, p, digs); (void) mod_mp (q, trm, trm, two, digs); BOOL_T odd = !IS_ZERO_MP (trm); // c = 1 / t; MP_T *c = nil_mp (q, digs); (void) rec_mp (q, c, t, digs); // d = (p - 1); MP_T *d = nil_mp (q, digs); (void) minus_one_mp (q, d, p, digs); // s = c * (t - d); MP_T *s = nil_mp (q, digs); (void) sub_mp (q, trm, t, d, digs); (void) mul_mp (q, s, c, trm, digs); // l = 0; MP_T *l = nil_mp (q, digs); // BOOL_T cont = A68_TRUE, stop; MP_T *del = nil_mp (q, digs); while (cont) { // c *= d * (d - 1) * tt; (void) minus_one_mp (q, trm, d, digs); (void) mul_mp (q, trm, d, trm, digs); (void) mul_mp (q, trm, trm, tt, digs); (void) mul_mp (q, c, c, trm, digs); // d -= 2; (void) sub_mp (q, d, d, two, digs); // del = c * (t - d); (void) sub_mp (q, trm, t, d, digs); (void) mul_mp (q, del, c, trm, digs); // s += del; (void) add_mp (q, s, s, del, digs); // l++; (void) plus_one_mp (q, l, l, digs); // stop = fabsq (del) < fabsq (s) * EPS; (void) abs_mp (q, trm, del, digs); (void) abs_mp (q, trn, s, digs); (void) mul_mp (q, trn, trn, eps, digs); A68_BOOL lt; (void) lt_mp (q, <, trm, trn, digs); stop = VALUE (<); //while ((l < floorq ((p - 2) / 2)) && !stop); (void) sub_mp (q, trm, p, two, digs); (void) half_mp (q, trm, trm, digs); (void) floor_mp (q, trm, trm, digs); (void) lt_mp (q, <, l, trm, digs); cont = VALUE (<) && !stop; } if (odd && !stop) { // s += d * c / t; (void) div_mp (q, trm, c, t, digs); (void) mul_mp (q, trm, d, trm, digs); (void) add_mp (q, s, s, trm, digs); } // Gibp = ((odd ? -1 : 1) * expq (-t + lgammaq (p) - (p - 1) * logq (t)) + s) / t; (void) ln_mp (q, trn, t, digs); (void) minus_one_mp (q, trm, p, digs); (void) mul_mp (q, trm, trm, trn, digs); (void) lngamma_mp (q, trn, p, digs); (void) sub_mp (q, trm, trn, trm, digs); (void) sub_mp (q, trm, trm, t, digs); (void) exp_mp (q, Gibp, trm, digs); if (odd) { (void) minus_mp (q, Gibp, Gibp, digs); } (void) add_mp (q, Gibp, Gibp, s, digs); (void) div_mp (q, Gibp, Gibp, t, digs); A68_SP = pop_sp; return Gibp; } MP_T *plim_mp (NODE_T *p, MP_T *z, MP_T *x, int digs) { ADDR_T pop_sp = A68_SP; if (MP_DIGIT (x, 1) > 0) { (void) move_mp (z, x, digs); } else { MP_T *five = lit_mp (p, 5, 0, digs); MP_T *nine = lit_mp (p, -9, 0, digs); A68_BOOL ge; (void) ge_mp (p, &ge, x, nine, digs); if (VALUE (&ge)) { SET_MP_ZERO (z, digs); } else { (void) minus_mp (p, z, x, digs); (void) sqrt_mp (p, z, z, digs); (void) mul_mp (p, z, five, z, digs); (void) sub_mp (p, z, z, five, digs); } } A68_SP = pop_sp; return z; } //! @brief compute G : (p,x) --> R defined as follows // // if x <= p: // G(p,x) = exp (x-p*ln (|x|)) * integral of s^{p-1} * exp (-sign (x)*s) ds from s = 0 to |x| // otherwise: // G(p,x) = exp (x-p*ln (|x|)) * integral of s^{p-1} * exp (-s) ds from s = x to infinity // // p > 0; x is a real number or +infinity. void G_func_mp (NODE_T *q, MP_T * G, MP_T *p, MP_T *x, int digs) { ADDR_T pop_sp = A68_SP; MP_T *pl = nil_mp (q, digs); A68_BOOL ge; (void) plim_mp (q, pl, x, digs); (void) ge_mp (q, &ge, p, pl, digs); if (VALUE (&ge)) { G_cfrac_lower_mp (q, G, p, x, digs); } else if (MP_DIGIT (x, 1) < 0) { G_ibp_mp (q, G, p, x, digs); } else { G_cfrac_upper_mp (q, G, p, x, digs); } A68_SP = pop_sp; } //! @brief compute I_{x,y}^{mu,p} using a Romberg approximation. // Compute rho and sigma so I_{x,y}^{mu,p} = rho * exp (sigma) //! @brief iteration of the Romberg approximation of I_{x,y}^{mu,p} #define ROMBERG_N (((NITERMAX_ROMBERG + 1) * (NITERMAX_ROMBERG + 2)) / 2) static inline int IX (int n, int digs) { int offset = n * SIZE_MP (digs); return offset; } void mp_romberg_iterations (NODE_T *q, MP_T *R, MP_T *sigma, INT_T n, MP_T *x, MP_T *y, MP_T *mu, MP_T *p, MP_T *h, MP_T *pow2, int digs) { INT_T m; MP_T *trm = nil_mp (q, digs), *trn = nil_mp (q, digs); MP_T *sum = nil_mp (q, digs), *xx = nil_mp (q, digs); INT_T adr0_prev = ((n - 1) * n) / 2; INT_T adr0 = (n * (n + 1)) / 2; MP_T *j = lit_mp (q, 1, 0, digs); A68_BOOL le; VALUE (&le) = A68_TRUE; while (VALUE (&le)) { // xx = x + ((y - x) * (2 * j - 1)) / (2 * pow2); (void) add_mp (q, trm, j, j, digs); (void) minus_one_mp (q, trm, trm, digs); (void) sub_mp (q, trn, y, x, digs); (void) mul_mp (q, trm, trm, trn, digs); (void) div_mp (q, trm, trm, pow2, digs); (void) half_mp (q, trm, trm, digs); (void) add_mp (q, xx, x, trm, digs); // sum += exp (-mu * xx + (p - 1) * a68_ln (xx) - sigma); (void) ln_mp (q, trn, xx, digs); (void) minus_one_mp (q, trm, p, digs); (void) mul_mp (q, trm, trm, trn, digs); (void) mul_mp (q, trn, mu, xx, digs); (void) sub_mp (q, trm, trm, trn, digs); (void) sub_mp (q, trm, trm, sigma, digs); (void) exp_mp (q, trm, trm, digs); (void) add_mp (q, sum, sum, trm, digs); // j++; (void) plus_one_mp (q, j, j, digs); (void) le_mp (q, &le, j, pow2, digs); } // R[adr0] = 0.5 * R[adr0_prev] + h * sum; (void) half_mp (q, trm, &R[IX (adr0_prev, digs)], digs); (void) mul_mp (q, trn, h, sum, digs); (void) add_mp (q, &R[IX (adr0, digs)], trm, trn, digs); // REAL_T pow4 = 4; MP_T *pow4 = lit_mp (q, 4, 0, digs); for (m = 1; m <= n; m++) { // R[adr0 + m] = (pow4 * R[adr0 + (m - 1)] - R[adr0_prev + (m - 1)]) / (pow4 - 1); (void) mul_mp (q, trm, pow4, &R[IX (adr0 + m - 1, digs)], digs); (void) sub_mp (q, trm, trm, &R[IX (adr0_prev + m - 1, digs)], digs); (void) minus_one_mp (q, trn, pow4, digs); (void) div_mp (q, &R[IX (adr0 + m, digs)], trm, trn, digs); // pow4 *= 4; (void) add_mp (q, trm, pow4, pow4, digs); (void) add_mp (q, pow4, trm, trm, digs); } } void mp_romberg_estimate (NODE_T *q, MP_T * rho, MP_T * sigma, MP_T *x, MP_T *y, MP_T *mu, MP_T *p, int digs) { ADDR_T pop_sp = A68_SP; MP_T *R = (MP_T *) get_heap_space (ROMBERG_N * SIZE_MP (digs)); // Initialization (n=1) MP_T *trm = nil_mp (q, digs), *trn = nil_mp (q, digs); // sigma = -mu * y + (p - 1) * ln (y); (void) ln_mp (q, trn, y, digs); (void) minus_one_mp (q, trm, p, digs); (void) mul_mp (q, trm, trm, trn, digs); (void) mul_mp (q, trn, mu, y, digs); (void) sub_mp (q, sigma, trm, trn, digs); // R[0] = 0.5 * (y - x) * (exp (-mu * x + (p - 1) * ln (x) - (*sigma)) + 1); (void) ln_mp (q, trn, x, digs); (void) minus_one_mp (q, trm, p, digs); (void) mul_mp (q, trm, trm, trn, digs); (void) mul_mp (q, trn, mu, x, digs); (void) sub_mp (q, trm, trm, trn, digs); (void) sub_mp (q, trm, trm, sigma, digs); (void) exp_mp (q, trm, trm, digs); (void) plus_one_mp (q, trm, trm, digs); (void) sub_mp (q, trn, y, x, digs); (void) mul_mp (q, trm, trm, trn, digs); (void) half_mp (q, &R[IX (0, digs)], trm, digs); // Loop for n > 0 MP_T *relerr = nil_mp (q, digs); MP_T *relneeded = EPS (q, digs); (void) div_mp (q, relneeded, relneeded, TOL_ROMBERG (q, digs), digs); INT_T adr0 = 0; INT_T n = 1; // REAL_T h = (y - x) / 2; // n=1, h = (y-x)/2^n MP_T *h = nil_mp (q, digs); (void) sub_mp (q, h, y, x, digs); (void) half_mp (q, h, h, digs); // REAL_T pow2 = 1; // n=1; pow2 = 2^(n-1) MP_T *pow2 = lit_mp (q, 1, 0, digs); BOOL_T cont = A68_TRUE; while (cont) { // while (n <= NITERMAX_ROMBERG && relerr > relneeded); // mp_romberg_iterations (R, *sigma, n, x, y, mu, p, h, pow2); ADDR_T pop_sp_2 = A68_SP; mp_romberg_iterations (q, R, sigma, n, x, y, mu, p, h, pow2, digs); A68_SP = pop_sp_2; // h /= 2; (void) half_mp (q, h, h, digs); // pow2 *= 2; (void) add_mp (q, pow2, pow2, pow2, digs); // adr0 = (n * (n + 1)) / 2; adr0 = (n * (n + 1)) / 2; // relerr = abs ((R[adr0 + n] - R[adr0 + n - 1]) / R[adr0 + n]); (void) sub_mp (q, trm, &R[IX (adr0 + n, digs)], &R[IX (adr0 + n - 1, digs)], digs); (void) div_mp (q, trm, trm, &R[IX (adr0 + n, digs)], digs); (void) abs_mp (q, relerr, trm, digs); // n++; n++; A68_BOOL gt; (void) gt_mp (q, >, relerr, relneeded, digs); cont = (n <= NITERMAX_ROMBERG) && VALUE (>); } // save Romberg estimate and free memory // rho = R[adr0 + (n - 1)]; (void) move_mp (rho, &R[IX (adr0 + n - 1, digs)], digs); a68_free (R); A68_SP = pop_sp; } //! @brief compute generalized incomplete gamma function I_{x,y}^{mu,p} // // I_{x,y}^{mu,p} = integral from x to y of s^{p-1} * exp (-mu*s) ds // // This procedure computes (rho, sigma) described below. // The approximated value of I_{x,y}^{mu,p} is I = rho * exp (sigma) // // mu is a real number non equal to zero // (in general we take mu = 1 or -1 but any nonzero real number is allowed) // // x, y are two numbers with 0 <= x <= y <= +infinity, // (the setting y=+infinity is allowed only when mu > 0) // // p is a real number > 0, p must be an integer when mu < 0. void Dgamic_mp (NODE_T *q, MP_T * rho, MP_T * sigma, MP_T *x, MP_T *y, MP_T *mu, MP_T *p, int digs) { ADDR_T pop_sp = A68_SP; // Particular cases if (PLUS_INF_MP (x) && PLUS_INF_MP (y)) { SET_MP_ZERO (rho, digs); SET_MP_ZERO (sigma, digs); MP_STATUS (sigma) = (UNSIGNED_T) MP_STATUS (sigma) | MINUS_INF_MASK; A68_SP = pop_sp; return; } else if (same_mp (q, x, y, digs)) { SET_MP_ZERO (rho, digs); SET_MP_ZERO (sigma, digs); MP_STATUS (sigma) = (UNSIGNED_T) MP_STATUS (sigma) | MINUS_INF_MASK; A68_SP = pop_sp; return; } if (IS_ZERO_MP (x) && PLUS_INF_MP (y)) { set_mp (rho, 1, 0, digs); MP_T *lgam = nil_mp (q, digs); MP_T *lnmu = nil_mp (q, digs); (void) lngamma_mp (q, lgam, p, digs); (void) ln_mp (q, lnmu, mu, digs); (void) mul_mp (q, lnmu, p, lnmu, digs); (void) sub_mp (q, sigma, lgam, lnmu, digs); return; } // Initialization MP_T *mx = nil_mp (q, digs); MP_T *nx = nil_mp (q, digs); MP_T *my = nil_mp (q, digs); MP_T *ny = nil_mp (q, digs); MP_T *mux = nil_mp (q, digs); MP_T *muy = nil_mp (q, digs); // Initialization // nx = (a68_isinf (x) ? a68_neginf () : -mu * x + p * ln (x)); if (PLUS_INF_MP (x)) { SET_MP_ZERO (mx, digs); MP_STATUS (nx) = (UNSIGNED_T) MP_STATUS (nx) | MINUS_INF_MASK; } else { (void) mul_mp (q, mux, mu, x, digs); G_func_mp (q, mx, p, mux, digs); (void) ln_mp (q, nx, x, digs); (void) mul_mp (q, nx, p, nx, digs); (void) sub_mp (q, nx, nx, mux, digs); } // ny = (a68_isinf (y) ? a68_neginf () : -mu * y + p * ln (y)); if (PLUS_INF_MP (y)) { SET_MP_ZERO (my, digs); MP_STATUS (ny) = (UNSIGNED_T) MP_STATUS (ny) | MINUS_INF_MASK; } else { (void) mul_mp (q, muy, mu, y, digs); G_func_mp (q, my, p, muy, digs); (void) ln_mp (q, ny, y, digs); (void) mul_mp (q, ny, p, ny, digs); (void) sub_mp (q, ny, ny, muy, digs); } // Compute (mA,nA) and (mB,nB) such as I_{x,y}^{mu,p} can be // approximated by the difference A-B, where A >= B >= 0, A = mA*exp (nA) an // B = mB*exp (nB). When the difference involves more than one digit loss due to // cancellation errors, the integral I_{x,y}^{mu,p} is evaluated using the // Romberg approximation method. MP_T *mA = nil_mp (q, digs); MP_T *mB = nil_mp (q, digs); MP_T *nA = nil_mp (q, digs); MP_T *nB = nil_mp (q, digs); MP_T *trm = nil_mp (q, digs); if (MP_DIGIT (mu, 1) < 0) { (void) move_mp (mA, my, digs); (void) move_mp (nA, ny, digs); (void) move_mp (mB, mx, digs); (void) move_mp (nB, nx, digs); goto compute; } MP_T *pl = nil_mp (q, digs); A68_BOOL lt; if (PLUS_INF_MP (x)) { VALUE (<) = A68_TRUE; } else { (void) mul_mp (q, mux, mu, x, digs); (void) plim_mp (q, pl, mux, digs); (void) lt_mp (q, <, p, pl, digs); } if (VALUE (<)) { (void) move_mp (mA, mx, digs); (void) move_mp (nA, nx, digs); (void) move_mp (mB, my, digs); (void) move_mp (nB, ny, digs); goto compute; } if (PLUS_INF_MP (y)) { VALUE (<) = A68_TRUE; } else { (void) mul_mp (q, muy, mu, y, digs); (void) plim_mp (q, pl, muy, digs); (void) lt_mp (q, <, p, pl, digs); } if (VALUE (<)) { // mA = 1; set_mp (mA, 1, 0, digs); // nA = lgammaq (p) - p * logq (mu); MP_T *lgam = nil_mp (q, digs); MP_T *lnmu = nil_mp (q, digs); (void) lngamma_mp (q, lgam, p, digs); (void) ln_mp (q, lnmu, mu, digs); (void) mul_mp (q, lnmu, p, lnmu, digs); (void) sub_mp (q, nA, lgam, lnmu, digs); // nB = fmax (nx, ny); A68_BOOL ge; if (MINUS_INF_MP (ny)) { VALUE (&ge) = A68_TRUE; } else { (void) ge_mp (q, &ge, nx, ny, digs); } if (VALUE (&ge)) { (void) move_mp (nB, nx, digs); } else { (void) move_mp (nB, ny, digs); } // mB = mx * expq (nx - nB) + my * expq (ny - nB); (void) sub_mp (q, trm, nx, nB, digs); (void) exp_mp (q, trm, trm, digs); (void) mul_mp (q, mB, mx, trm, digs); if (! MINUS_INF_MP (ny)) { (void) sub_mp (q, trm, ny, nB, digs); (void) exp_mp (q, trm, trm, digs); (void) mul_mp (q, trm, my, trm, digs); (void) add_mp (q, mB, nB, trm, digs); } goto compute; } (void) move_mp (mA, my, digs); (void) move_mp (nA, ny, digs); (void) move_mp (mB, mx, digs); (void) move_mp (nB, nx, digs); compute: // Compute (rho,sigma) such that rho*exp (sigma) = A-B // 1. rho = mA - mB * expq (nB - nA); (void) sub_mp (q, trm, nB, nA, digs); (void) exp_mp (q, trm, trm, digs); (void) mul_mp (q, trm, mB, trm, digs); (void) sub_mp (q, rho, mA, trm, digs); // 2. sigma = nA; (void) move_mp (sigma, nA, digs); // If the difference involved a significant loss of precision, compute Romberg estimate. // if (!isinfq (y) && ((*rho) / mA < TOL_DIFF)) { (void) div_mp (q, trm, rho, mA, digs); (void) lt_mp (q, <, trm, TOL_DIFF (q, digs), digs); if (!PLUS_INF_MP (y) && VALUE (<)) { mp_romberg_estimate (q, rho, sigma, x, y, mu, p, digs); } A68_SP = pop_sp; } void Dgamic_wrap_mp (NODE_T *q, MP_T * s, MP_T * rho, MP_T * sigma, MP_T *x, MP_T *y, MP_T *mu, MP_T *p, int digs) { ADDR_T pop_sp = A68_SP; int gdigs = GAM_DIGITS (MAX_PRECISION); errno = 0; if (digs <= gdigs) { gdigs = GAM_DIGITS (digs); MP_T *rho_g = len_mp (q, rho, digs, gdigs); MP_T *sigma_g = len_mp (q, sigma, digs, gdigs); MP_T *x_g = len_mp (q, x, digs, gdigs); MP_T *y_g = len_mp (q, y, digs, gdigs); MP_T *mu_g = len_mp (q, mu, digs, gdigs); MP_T *p_g = len_mp (q, p, digs, gdigs); Dgamic_mp (q, rho_g, sigma_g, x_g, y_g, mu_g, p_g, gdigs); if (IS_ZERO_MP (rho_g) || MINUS_INF_MP (sigma_g)) { SET_MP_ZERO (s, digs); } else { (void) exp_mp (q, sigma_g, sigma_g, gdigs); (void) mul_mp (q, rho_g, rho_g, sigma_g, gdigs); (void) shorten_mp (q, s, digs, rho_g, gdigs); } } else { diagnostic (A68_MATH_WARNING, q, WARNING_MATH_PRECISION, MOID (q), CALL, NULL); MP_T *rho_g = cut_mp (q, rho, digs, gdigs); MP_T *sigma_g = cut_mp (q, sigma, digs, gdigs); MP_T *x_g = cut_mp (q, x, digs, gdigs); MP_T *y_g = cut_mp (q, y, digs, gdigs); MP_T *mu_g = cut_mp (q, mu, digs, gdigs); MP_T *p_g = cut_mp (q, p, digs, gdigs); Dgamic_mp (q, rho_g, sigma_g, x_g, y_g, mu_g, p_g, gdigs); if (IS_ZERO_MP (rho_g) || MINUS_INF_MP (sigma_g)) { SET_MP_ZERO (s, digs); } else { (void) exp_mp (q, sigma_g, sigma_g, gdigs); (void) mul_mp (q, rho_g, rho_g, sigma_g, gdigs); MP_T *tmp = nil_mp (q, MAX_PRECISION); (void) shorten_mp (q, tmp, MAX_PRECISION, rho_g, gdigs); (void) lengthen_mp (q, s, digs, tmp, MAX_PRECISION); } } PRELUDE_ERROR (errno != 0, q, ERROR_MATH, MOID (q)); A68_SP = pop_sp; } //! @brief PROC long long gamma inc f = (LONG LONG REAL p, x) LONG LONG REAL void genie_gamma_inc_f_mp (NODE_T *p) { int digs = DIGITS (MOID (p)), size = SIZE (MOID (p)); ADDR_T pop_sp = A68_SP; MP_T *x = (MP_T *) STACK_OFFSET (-size); MP_T *s = (MP_T *) STACK_OFFSET (-2 * size); MP_T *mu = lit_mp (p, 1, 0, digs); MP_T *y = nil_mp (p, digs); MP_T *rho = nil_mp (p, digs); MP_T *sigma = nil_mp (p, digs); MP_STATUS (y) = (UNSIGNED_T) MP_STATUS (y) | PLUS_INF_MASK; Dgamic_wrap_mp (p, s, rho, sigma, x, y, mu, s, digs); A68_SP = pop_sp; A68_SP -= size; } //! @brief PROC long long gamma inc g = (LONG LONG REAL p, x, y, mu) LONG LONG REAL void genie_gamma_inc_g_mp (NODE_T *p) { int digs = DIGITS (MOID (p)), size = SIZE (MOID (p)); ADDR_T pop_sp = A68_SP; MP_T *mu = (MP_T *) STACK_OFFSET (-size); MP_T *y = (MP_T *) STACK_OFFSET (-2 * size); MP_T *x = (MP_T *) STACK_OFFSET (-3 * size); MP_T *s = (MP_T *) STACK_OFFSET (-4 * size); MP_T *rho = nil_mp (p, digs); MP_T *sigma = nil_mp (p, digs); Dgamic_wrap_mp (p, s, rho, sigma, x, y, mu, s, digs); A68_SP = pop_sp; A68_SP -= 3 * size; } //! @brief PROC long long gamma inc gf = (LONG LONG REAL p, x, y, mu) LONG LONG REAL void genie_gamma_inc_gf_mp (NODE_T *p) { // if x <= p: G(p,x) = exp (x-p*ln (|x|)) * integral over [0,|x|] of s^{p-1} * exp (-sign (x)*s) ds // otherwise: G(p,x) = exp (x-p*ln (x)) * integral over [x,inf] of s^{p-1} * exp (-s) ds int digs = DIGITS (MOID (p)), size = SIZE (MOID (p)); ADDR_T pop_sp = A68_SP; MP_T *x = (MP_T *) STACK_OFFSET (-size); MP_T *s = (MP_T *) STACK_OFFSET (-2 * size); int gdigs = GAM_DIGITS (MAX_PRECISION); errno = 0; if (digs <= gdigs) { gdigs = GAM_DIGITS (digs); MP_T *x_g = len_mp (p, x, digs, gdigs); MP_T *s_g = len_mp (p, s, digs, gdigs); MP_T *G = nil_mp (p, gdigs); G_func_mp (p, G, s_g, x_g, gdigs); PRELUDE_ERROR (errno != 0, p, ERROR_MATH, MOID (p)); (void) shorten_mp (p, s, digs, G, gdigs); } else { diagnostic (A68_MATH_WARNING, p, WARNING_MATH_PRECISION, MOID (p), CALL, NULL); MP_T *x_g = cut_mp (p, x, digs, gdigs); MP_T *s_g = cut_mp (p, s, digs, gdigs); MP_T *G = nil_mp (p, gdigs); G_func_mp (p, G, s_g, x_g, gdigs); PRELUDE_ERROR (errno != 0, p, ERROR_MATH, MOID (p)); MP_T *tmp = nil_mp (p, MAX_PRECISION); (void) shorten_mp (p, tmp, MAX_PRECISION, G, gdigs); (void) lengthen_mp (p, s, digs, tmp, MAX_PRECISION); } A68_SP = pop_sp - size; } //! @brief PROC long long gamma inc = (LONG LONG REAL p, x) LONG LONG REAL void genie_gamma_inc_h_mp (NODE_T *p) { #if defined (HAVE_GNU_MPFR) && (A68_LEVEL >= 3) genie_gamma_inc_mpfr (p); #else genie_gamma_inc_f_mp (p); #endif } algol68g-3.1.2/src/a68g/curses.c0000644000175000017500000001233714361065320013073 00000000000000//! @file curses.c //! @author J. Marcel van der Veer // //! @section Copyright // // This file is part of Algol68G - an Algol 68 compiler-interpreter. // Copyright 2001-2023 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" #include "a68g-genie.h" #include "a68g-prelude.h" // Some routines that interface Algol68G and the curses library. #if defined (HAVE_CURSES) #define CHECK_CURSES_RETVAL(f) {\ if (!(f)) {\ diagnostic (A68_RUNTIME_ERROR, p, ERROR_CURSES);\ exit_genie (p, A68_RUNTIME_ERROR);\ }} //! @brief Clean_curses. void clean_curses (void) { if (A68 (curses_mode) == A68_TRUE) { (void) wattrset (stdscr, A_NORMAL); (void) endwin (); A68 (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. int rgetchar (void) { #if defined (BUILD_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 void genie_curses_start (NODE_T * p) { (void) p; init_curses (); A68 (curses_mode) = A68_TRUE; } //! @brief PROC curses end = VOID void genie_curses_end (NODE_T * p) { (void) p; clean_curses (); } //! @brief PROC curses clear = VOID void genie_curses_clear (NODE_T * p) { if (A68 (curses_mode) == A68_FALSE) { genie_curses_start (p); } CHECK_CURSES_RETVAL (clear () != ERR); } //! @brief PROC curses refresh = VOID void genie_curses_refresh (NODE_T * p) { if (A68 (curses_mode) == A68_FALSE) { genie_curses_start (p); } CHECK_CURSES_RETVAL (refresh () != ERR); } //! @brief PROC curses lines = INT void genie_curses_lines (NODE_T * p) { if (A68 (curses_mode) == A68_FALSE) { genie_curses_start (p); } PUSH_VALUE (p, LINES, A68_INT); } //! @brief PROC curses columns = INT void genie_curses_columns (NODE_T * p) { if (A68 (curses_mode) == A68_FALSE) { genie_curses_start (p); } PUSH_VALUE (p, COLS, A68_INT); } //! @brief PROC curses getchar = CHAR void genie_curses_getchar (NODE_T * p) { if (A68 (curses_mode) == A68_FALSE) { genie_curses_start (p); } PUSH_VALUE (p, (char) rgetchar (), A68_CHAR); } //! @brief PROC curses colour = VOID #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 void genie_curses_del_char (NODE_T * p) { A68_CHAR ch; int v; POP_OBJECT (p, &ch, A68_CHAR); v = (int) VALUE (&ch); PUSH_VALUE (p, (BOOL_T) (v == 8 || v == 127 || v == KEY_BACKSPACE), A68_BOOL); } //! @brief PROC curses putchar = (CHAR) VOID void genie_curses_putchar (NODE_T * p) { A68_CHAR ch; if (A68 (curses_mode) == A68_FALSE) { genie_curses_start (p); } POP_OBJECT (p, &ch, A68_CHAR); (void) (addch ((chtype) (VALUE (&ch)))); } //! @brief PROC curses move = (INT, INT) VOID void genie_curses_move (NODE_T * p) { A68_INT i, j; if (A68 (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 (A68_RUNTIME_ERROR, p, ERROR_CURSES_OFF_SCREEN); exit_genie (p, A68_RUNTIME_ERROR); } if (VALUE (&j) < 0 || VALUE (&j) >= COLS) { diagnostic (A68_RUNTIME_ERROR, p, ERROR_CURSES_OFF_SCREEN); exit_genie (p, A68_RUNTIME_ERROR); } CHECK_CURSES_RETVAL (move (VALUE (&i), VALUE (&j)) != ERR); } #endif algol68g-3.1.2/src/a68g/brackets.c0000644000175000017500000001431114361065320013357 00000000000000//! @file brackets.c //! @author J. Marcel van der Veer // //! @section Copyright // // This file is part of Algol68G - an Algol 68 compiler-interpreter. // Copyright 2001-2023 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" #include "a68g-parser.h" // Recursive-descent 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. //! @brief Intelligible diagnostics for the bracket checker. 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. 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; } } } A68 (edit_line)[0] = NULL_CHAR; bracket_check_error (A68 (edit_line), begins, "BEGIN", "END"); bracket_check_error (A68 (edit_line), opens, "(", ")"); bracket_check_error (A68 (edit_line), format_opens, "(", ")"); bracket_check_error (A68 (edit_line), format_delims, "$", "$"); bracket_check_error (A68 (edit_line), accos, "{", "}"); bracket_check_error (A68 (edit_line), subs, "[", "]"); bracket_check_error (A68 (edit_line), ifs, "IF", "FI"); bracket_check_error (A68 (edit_line), cases, "CASE", "ESAC"); bracket_check_error (A68 (edit_line), dos, "DO", "OD"); return A68 (edit_line); } //! @brief Driver for locally diagnosing non-matching tokens. 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 (A68_SYNTAX_ERROR, p, ERROR_PARENTHESIS, (strlen (diag) > 0 ? diag : INFO_MISSING_KEYWORDS)); longjmp (A68_PARSER (top_down_crash_exit), 1); } else { char *diag = bracket_check_diagnose (top); diagnostic (A68_SYNTAX_ERROR, p, ERROR_PARENTHESIS_2, ATTRIBUTE (q), LINE (INFO (q)), ket, (strlen (diag) > 0 ? diag : INFO_MISSING_KEYWORDS)); longjmp (A68_PARSER (top_down_crash_exit), 1); } } return NO_NODE; } //! @brief Driver for globally diagnosing non-matching tokens. void check_parenthesis (NODE_T * top) { if (!setjmp (A68_PARSER (top_down_crash_exit))) { if (bracket_check_parse (top, top) != NO_NODE) { diagnostic (A68_SYNTAX_ERROR, top, ERROR_PARENTHESIS, INFO_MISSING_KEYWORDS); } } } algol68g-3.1.2/src/a68g/environ.c0000644000175000017500000000415114361065320013242 00000000000000//! @file environ.c //! @author J. Marcel van der Veer // //! @section Copyright // // This file is part of Algol68G - an Algol 68 compiler-interpreter. // Copyright 2001-2023 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" #include "a68g-genie.h" #include "a68g-prelude.h" #include "a68g-mp.h" #include "a68g-physics.h" #include "a68g-numbers.h" #include "a68g-optimiser.h" #include "a68g-double.h" #include "a68g-transput.h" #define VECTOR_SIZE 512 #define FD_READ 0 #define FD_WRITE 1 //! @brief PROC (PROC VOID) VOID on gc event void genie_on_gc_event (NODE_T * p) { POP_PROCEDURE (p, &A68 (on_gc_event)); } //! @brief Generic procedure for OP AND BECOMES (+:=, -:=, ...). 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); } //! @brief INT system heap pointer void genie_system_heap_pointer (NODE_T * p) { PUSH_VALUE (p, (int) (A68_HP), A68_INT); } //! @brief INT system stack pointer void genie_system_stack_pointer (NODE_T * p) { BYTE_T stack_offset; PUSH_VALUE (p, (int) (A68 (system_stack_offset) - &stack_offset), A68_INT); } algol68g-3.1.2/src/a68g/laplace.c0000644000175000017500000000654014361065320013167 00000000000000//! @file laplace.c //! @author J. Marcel van der Veer // //! @section Copyright // // This file is part of Algol68G - an Algol 68 compiler-interpreter. // Copyright 2001-2023 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" #include "a68g-genie.h" #include "a68g-prelude.h" #if defined (HAVE_GSL) //! @brief Map GSL error handler onto a68g error handler. void laplace_error_handler (const char *reason, const char *file, int line, int gsl_errno) { if (line != 0) { ASSERT (snprintf (A68 (edit_line), SNPRINTF_SIZE, "%s in line %d of file %s", reason, line, file) >= 0); } else { ASSERT (snprintf (A68 (edit_line), SNPRINTF_SIZE, "%s", reason) >= 0); } diagnostic (A68_RUNTIME_ERROR, A68 (f_entry), ERROR_LAPLACE, A68 (edit_line), gsl_strerror (gsl_errno)); exit_genie (A68 (f_entry), A68_RUNTIME_ERROR); } //! @brief Detect math errors. 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 #define LAPLACE_DIVISIONS 1024 typedef struct A68_LAPLACE A68_LAPLACE; struct A68_LAPLACE { NODE_T *p; A68_PROCEDURE f; REAL_T s; }; //! @brief Evaluate function for Laplace transform. REAL_T laplace_f (REAL_T t, void *z) { A68_LAPLACE *l = (A68_LAPLACE *) z; ADDR_T pop_sp = A68_SP, pop_fp = A68_FP; MOID_T *u = M_PROC_REAL_REAL; A68_REAL *ft = (A68_REAL *) STACK_TOP; PUSH_VALUE (P (l), t, A68_REAL); genie_call_procedure (P (l), MOID (&(F (l))), u, u, &(F (l)), pop_sp, pop_fp); A68_SP = pop_sp; return VALUE (ft) * a68_exp (-(S (l)) * t); } //! @brief Calculate Laplace transform. 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; REAL_T 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, M_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_VALUE (p, result, A68_REAL); gsl_integration_workspace_free (w); (void) gsl_set_error_handler (save_handler); } #endif algol68g-3.1.2/src/a68g/mp-bits.c0000644000175000017500000005121514361065320013140 00000000000000//! @file mp-bits.c //! @author J. Marcel van der Veer // //! @section Copyright // // This file is part of Algol68G - an Algol 68 compiler-interpreter. // Copyright 2001-2023 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" #include "a68g-genie.h" #include "a68g-prelude.h" #include "a68g-double.h" #include "a68g-mp.h" #include "a68g-numbers.h" #include "a68g-transput.h" #if (A68_LEVEL <= 2) // This legacy code implements a quick-and-dirty LONG LONG BITS mode, // constructed on top of the LONG LONG INT/REAL/COMPLEX library. // It was essentially meant to have LONG LONG BITS for demonstration only. // There are obvious possibilities to improve this code, but discussions // suggested that workers needing long bit strings, in fields such as // cryptography, would be better off implementing their own optimally // efficient tools, and investment in an efficient LONG LONG BITS library // would not be worth the while. // Hence in recent a68c versions, LONG BITS is a 128-bit quad word, // and LONG LONG BITS is mapped onto LONG BITS. // // Below code is left in a68g for reference purposes, and in case a build of // a version < 3 would be required. #define MP_BITS_WIDTH(k) ((int) ceil ((k) * LOG_MP_RADIX * CONST_LOG2_10) - 1) #define MP_BITS_WORDS(k) ((int) ceil ((REAL_T) MP_BITS_WIDTH (k) / (REAL_T) MP_BITS_BITS)) //! @brief Length in bits of mode. int get_mp_bits_width (MOID_T * m) { if (m == M_LONG_BITS) { return MP_BITS_WIDTH (LONG_MP_DIGITS); } else if (m == M_LONG_LONG_BITS) { return MP_BITS_WIDTH (A68_MP (varying_mp_digits)); } return 0; } //! @brief Length in words of mode. int get_mp_bits_words (MOID_T * m) { if (m == M_LONG_BITS) { return MP_BITS_WORDS (LONG_MP_DIGITS); } else if (m == M_LONG_LONG_BITS) { return MP_BITS_WORDS (A68_MP (varying_mp_digits)); } return 0; } //! @brief Convert z to a row of MP_BITS_T in the stack. MP_BITS_T *stack_mp_bits (NODE_T * p, MP_T * z, MOID_T * m) { int digits = DIGITS (m), words = get_mp_bits_words (m), k, lim; MP_BITS_T *row, mask; row = (MP_BITS_T *) STACK_ADDRESS (A68_SP); INCREMENT_STACK_POINTER (p, words * SIZE_ALIGNED (MP_BITS_T)); MP_T *u = nil_mp (p, digits); MP_T *v = nil_mp (p, digits); MP_T *w = nil_mp (p, digits); (void) move_mp (u, z, digits); // Argument check. if (MP_DIGIT (u, 1) < 0.0) { errno = EDOM; diagnostic (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--) { (void) 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] = (MP_BITS_T) 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 (A68_RUNTIME_ERROR, p, ERROR_OUT_OF_BOUNDS, m); exit_genie (p, A68_RUNTIME_ERROR); } // Exit. return row; } //! @brief Convert row of MP_BITS_T to LONG BITS. MP_T *pack_mp_bits (NODE_T * p, MP_T * u, MP_BITS_T * row, MOID_T * m) { int digits = DIGITS (m), words = get_mp_bits_words (m), k, lim; ADDR_T pop_sp = A68_SP; // Discard excess bits. MP_BITS_T mask = 0x1, musk = 0x0; MP_T *v = nil_mp (p, digits); MP_T *w = nil_mp (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); SET_MP_ONE (v, 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; A68_SP = pop_sp; return u; } //! @brief Convert multi-precision number to unt. UNSIGNED_T mp_to_unt (NODE_T * p, MP_T * z, int digits) { // This routine 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_T sum = 0, weight = 1; if (expo >= digits) { diagnostic (A68_RUNTIME_ERROR, p, ERROR_OUT_OF_BOUNDS, MOID (p)); exit_genie (p, A68_RUNTIME_ERROR); } for (j = 1 + expo; j >= 1; j--) { UNSIGNED_T term; if ((unt) MP_DIGIT (z, j) > UINT_MAX / weight) { diagnostic (A68_RUNTIME_ERROR, p, ERROR_OUT_OF_BOUNDS, M_BITS); exit_genie (p, A68_RUNTIME_ERROR); } term = (unt) MP_DIGIT (z, j) * weight; if (sum > UINT_MAX - term) { diagnostic (A68_RUNTIME_ERROR, p, ERROR_OUT_OF_BOUNDS, M_BITS); exit_genie (p, A68_RUNTIME_ERROR); } sum += term; weight *= MP_RADIX; } return sum; } //! @brief Whether LONG BITS value is in range. 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 = A68_SP; (void) stack_mp_bits (p, u, m); A68_SP = pop_sp; } } //! @brief LONG BITS value of LONG BITS denotation void mp_strtou (NODE_T * p, MP_T * z, char *str, MOID_T * m) { int base = 0; char *radix = NO_TEXT; errno = 0; base = (int) a68_strtou (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 = A68_SP; char *q = radix; MP_T *v = nil_mp (p, digits); MP_T *w = nil_mp (p, digits); while (q[0] != NULL_CHAR) { q++; } SET_MP_ZERO (z, digits); SET_MP_ONE (w, digits); if (base < 2 || base > 16) { diagnostic (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 (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); A68_SP = pop_sp; } else { diagnostic (A68_RUNTIME_ERROR, p, ERROR_IN_DENOTATION, m); exit_genie (p, A68_RUNTIME_ERROR); } } //! @brief Convert to other radix, binary up to hexadecimal. 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)) { MP_INT_T digit; int digits = DIGITS (m); BOOL_T success; (void) 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 = (MP_INT_T) MP_DIGIT (v, 1); success = convert_radix_mp (p, u, radix, width - 1, m, v, w); plusab_transput_buffer (p, EDIT_BUFFER, images[digit]); return success; } else { return (BOOL_T) (MP_DIGIT (u, 1) == 0); } } //! @brief OP LENG = (BITS) LONG BITS void genie_lengthen_unt_to_mp (NODE_T * p) { int digits = DIGITS (M_LONG_INT); A68_BITS k; POP_OBJECT (p, &k, A68_BITS); MP_T *z = nil_mp (p, digits); (void) unt_to_mp (p, z, (UNSIGNED_T) VALUE (&k), digits); MP_STATUS (z) = (MP_T) INIT_MASK; } //! @brief OP BIN = (LONG INT) LONG BITS void genie_bin_mp (NODE_T * p) { MOID_T *mode = SUB_MOID (p); int size = SIZE (mode); ADDR_T pop_sp = A68_SP; 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; A68_SP = pop_sp; } //! @brief OP NOT = (LONG BITS) LONG BITS void genie_not_mp (NODE_T * p) { MOID_T *mode = LHS_MODE (p); int size = SIZE (mode); ADDR_T pop_sp = A68_SP; int k, words = get_mp_bits_words (mode); MP_T *u = (MP_T *) STACK_OFFSET (-size); MP_BITS_T *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); A68_SP = pop_sp; } //! @brief OP SHORTEN = (LONG BITS) BITS void genie_shorten_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_VALUE (p, mp_to_unt (p, z, digits), A68_BITS); } //! @brief Get bit from LONG BITS. unt elem_long_bits (NODE_T * p, ADDR_T k, MP_T * z, MOID_T * m) { int n; ADDR_T pop_sp = A68_SP; MP_BITS_T *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; } A68_SP = pop_sp; return (words[k / MP_BITS_BITS]) & mask; } //! @brief OP ELEM = (INT, LONG BITS) BOOL void genie_elem_long_bits (NODE_T * p) { A68_INT *i; MP_T *z; MP_BITS_T w; int bits = get_mp_bits_width (M_LONG_BITS), size = SIZE (M_LONG_BITS); z = (MP_T *) STACK_OFFSET (-size); i = (A68_INT *) STACK_OFFSET (-(size + SIZE (M_INT))); PRELUDE_ERROR (VALUE (i) < 1 || VALUE (i) > bits, p, ERROR_OUT_OF_BOUNDS, M_INT); w = elem_long_bits (p, VALUE (i), z, M_LONG_BITS); DECREMENT_STACK_POINTER (p, size + SIZE (M_INT)); PUSH_VALUE (p, (BOOL_T) (w != 0), A68_BOOL); } //! @brief OP ELEM = (INT, LONG LONG BITS) BOOL void genie_elem_long_mp_bits (NODE_T * p) { A68_INT *i; MP_T *z; MP_BITS_T w; int bits = get_mp_bits_width (M_LONG_LONG_BITS), size = SIZE (M_LONG_LONG_BITS); z = (MP_T *) STACK_OFFSET (-size); i = (A68_INT *) STACK_OFFSET (-(size + SIZE (M_INT))); PRELUDE_ERROR (VALUE (i) < 1 || VALUE (i) > bits, p, ERROR_OUT_OF_BOUNDS, M_INT); w = elem_long_bits (p, VALUE (i), z, M_LONG_LONG_BITS); DECREMENT_STACK_POINTER (p, size + SIZE (M_INT)); PUSH_VALUE (p, (BOOL_T) (w != 0), A68_BOOL); } //! @brief Set bit in LONG BITS. MP_BITS_T *set_long_bits (NODE_T * p, int k, MP_T * z, MOID_T * m, MP_BITS_T bit) { int n; MP_BITS_T *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 void genie_set_long_bits (NODE_T * p) { A68_INT *i; MP_T *z; MP_BITS_T *w; ADDR_T pop_sp = A68_SP; int bits = get_mp_bits_width (M_LONG_BITS), size = SIZE (M_LONG_BITS); z = (MP_T *) STACK_OFFSET (-size); i = (A68_INT *) STACK_OFFSET (-(size + SIZE (M_INT))); PRELUDE_ERROR (VALUE (i) < 1 || VALUE (i) > bits, p, ERROR_OUT_OF_BOUNDS, M_INT); w = set_long_bits (p, VALUE (i), z, M_LONG_BITS, 0x1); (void) pack_mp_bits (p, (MP_T *) STACK_ADDRESS (pop_sp - size - SIZE (M_INT)), w, M_LONG_BITS); A68_SP = pop_sp; DECREMENT_STACK_POINTER (p, SIZE (M_INT)); } //! @brief OP SET = (INT, LONG LONG BITS) BOOL void genie_set_long_mp_bits (NODE_T * p) { A68_INT *i; MP_T *z; MP_BITS_T *w; ADDR_T pop_sp = A68_SP; int bits = get_mp_bits_width (M_LONG_LONG_BITS), size = SIZE (M_LONG_LONG_BITS); z = (MP_T *) STACK_OFFSET (-size); i = (A68_INT *) STACK_OFFSET (-(size + SIZE (M_INT))); PRELUDE_ERROR (VALUE (i) < 1 || VALUE (i) > bits, p, ERROR_OUT_OF_BOUNDS, M_INT); w = set_long_bits (p, VALUE (i), z, M_LONG_LONG_BITS, 0x1); (void) pack_mp_bits (p, (MP_T *) STACK_ADDRESS (pop_sp - size - SIZE (M_INT)), w, M_LONG_LONG_BITS); A68_SP = pop_sp; DECREMENT_STACK_POINTER (p, SIZE (M_INT)); } //! @brief OP CLEAR = (INT, LONG BITS) BOOL void genie_clear_long_bits (NODE_T * p) { A68_INT *i; MP_T *z; MP_BITS_T *w; ADDR_T pop_sp = A68_SP; int bits = get_mp_bits_width (M_LONG_BITS), size = SIZE (M_LONG_BITS); z = (MP_T *) STACK_OFFSET (-size); i = (A68_INT *) STACK_OFFSET (-(size + SIZE (M_INT))); PRELUDE_ERROR (VALUE (i) < 1 || VALUE (i) > bits, p, ERROR_OUT_OF_BOUNDS, M_INT); w = set_long_bits (p, VALUE (i), z, M_LONG_BITS, 0x0); (void) pack_mp_bits (p, (MP_T *) STACK_ADDRESS (pop_sp - size - SIZE (M_INT)), w, M_LONG_BITS); A68_SP = pop_sp; DECREMENT_STACK_POINTER (p, SIZE (M_INT)); } //! @brief OP CLEAR = (INT, LONG LONG BITS) BOOL void genie_clear_long_mp_bits (NODE_T * p) { A68_INT *i; MP_T *z; MP_BITS_T *w; ADDR_T pop_sp = A68_SP; int bits = get_mp_bits_width (M_LONG_LONG_BITS), size = SIZE (M_LONG_LONG_BITS); z = (MP_T *) STACK_OFFSET (-size); i = (A68_INT *) STACK_OFFSET (-(size + SIZE (M_INT))); PRELUDE_ERROR (VALUE (i) < 1 || VALUE (i) > bits, p, ERROR_OUT_OF_BOUNDS, M_INT); w = set_long_bits (p, VALUE (i), z, M_LONG_LONG_BITS, 0x0); (void) pack_mp_bits (p, (MP_T *) STACK_ADDRESS (pop_sp - size - SIZE (M_INT)), w, M_LONG_LONG_BITS); A68_SP = pop_sp; DECREMENT_STACK_POINTER (p, SIZE (M_INT)); } //! @brief PROC long bits pack = ([] BOOL) LONG BITS 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; POP_REF (p, &z); CHECK_REF (p, z, M_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, M_ROW_BOOL); // Convert so that LWB goes to MSB, so ELEM gives same order as [] BOOL. MP_T *sum = nil_mp (p, digits); pop_sp = A68_SP; MP_T *fact = lit_mp (p, 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), M_BOOL); if (VALUE (boo)) { (void) add_mp (p, sum, sum, fact, digits); } (void) mul_mp_digit (p, fact, fact, (MP_T) 2, digits); } } A68_SP = pop_sp; MP_STATUS (sum) = (MP_T) INIT_MASK; } //! @brief OP SHL = (LONG BITS, INT) LONG BITS void genie_shl_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; MP_BITS_T *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 = A68_SP; 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] &= ~((MP_BITS_T) 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); A68_SP = pop_sp; } //! @brief OP SHR = (LONG BITS, INT) LONG BITS void genie_shr_mp (NODE_T * p) { A68_INT *j; POP_OPERAND_ADDRESS (p, j, A68_INT); VALUE (j) = -VALUE (j); (void) genie_shl_mp (p); // Conform RR } //! @brief OP <= = (LONG BITS, LONG BITS) BOOL 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 = A68_SP; BOOL_T result = A68_TRUE; MP_T *u = (MP_T *) STACK_OFFSET (-2 * size), *v = (MP_T *) STACK_OFFSET (-size); MP_BITS_T *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])); } A68_SP = pop_sp; DECREMENT_STACK_POINTER (p, 2 * size); PUSH_VALUE (p, (BOOL_T) (result ? A68_TRUE : A68_FALSE), A68_BOOL); } //! @brief OP >= = (LONG BITS, LONG BITS) BOOL 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 = A68_SP; BOOL_T result = A68_TRUE; MP_T *u = (MP_T *) STACK_OFFSET (-2 * size), *v = (MP_T *) STACK_OFFSET (-size); MP_BITS_T *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])); } A68_SP = pop_sp; DECREMENT_STACK_POINTER (p, 2 * size); PUSH_VALUE (p, (BOOL_T) (result ? A68_TRUE : A68_FALSE), A68_BOOL); } //! @brief OP AND = (LONG BITS, LONG BITS) LONG BITS void genie_and_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 = A68_SP; MP_T *u = (MP_T *) STACK_OFFSET (-2 * size), *v = (MP_T *) STACK_OFFSET (-size); MP_BITS_T *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); A68_SP = pop_sp; DECREMENT_STACK_POINTER (p, size); } //! @brief OP OR = (LONG BITS, LONG BITS) LONG BITS void genie_or_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 = A68_SP; MP_T *u = (MP_T *) STACK_OFFSET (-2 * size), *v = (MP_T *) STACK_OFFSET (-size); MP_BITS_T *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); A68_SP = pop_sp; DECREMENT_STACK_POINTER (p, size); } //! @brief OP XOR = (LONG BITS, LONG BITS) LONG BITS void genie_xor_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 = A68_SP; MP_T *u = (MP_T *) STACK_OFFSET (-2 * size), *v = (MP_T *) STACK_OFFSET (-size); MP_BITS_T *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); A68_SP = pop_sp; DECREMENT_STACK_POINTER (p, size); } //! @brief LONG BITS long max bits void genie_long_max_bits (NODE_T * p) { int digits = DIGITS (M_LONG_BITS); int width = get_mp_bits_width (M_LONG_BITS); ADDR_T pop_sp; MP_T *z = nil_mp (p, digits); pop_sp = A68_SP; (void) set_mp (z, (MP_T) 2, 0, digits); (void) pow_mp_int (p, z, z, width, digits); (void) minus_one_mp (p, z, z, digits); A68_SP = pop_sp; } //! @brief LONG LONG BITS long long max bits void genie_long_mp_max_bits (NODE_T * p) { int digits = DIGITS (M_LONG_LONG_BITS); int width = get_mp_bits_width (M_LONG_LONG_BITS); MP_T *z = nil_mp (p, digits); ADDR_T pop_sp = A68_SP; (void) set_mp (z, (MP_T) 2, 0, digits); (void) pow_mp_int (p, z, z, width, digits); (void) minus_one_mp (p, z, z, digits); A68_SP = pop_sp; } //! @brief Lengthen LONG BITS to [] BOOL. void genie_lengthen_long_bits_to_row_bool (NODE_T * p) { 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); MP_BITS_T *bits; BYTE_T *base; MP_T *x; ADDR_T pop_sp = A68_SP; // Calculate and convert BITS value. x = (MP_T *) STACK_OFFSET (-size); bits = stack_mp_bits (p, x, m); // Make [] BOOL. NEW_ROW_1D (z, row, arr, tup, M_ROW_BOOL, M_BOOL, width); PUT_DESCRIPTOR (arr, tup, &z); base = ADDRESS (&row) + (width - 1) * SIZE (M_BOOL); k = width; while (k > 0) { MP_BITS_T 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 (M_BOOL); bit <<= 1; k--; } words--; } A68_SP = pop_sp; PUSH_REF (p, z); } #endif algol68g-3.1.2/src/a68g/mp-mpfr.c0000644000175000017500000003572414361065320013152 00000000000000//! @file mp-mpfr.c //! @author J. Marcel van der Veer // //! @section Copyright // // This file is part of Algol68G - an Algol 68 compiler-interpreter. // Copyright 2001-2023 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" #include "a68g-genie.h" #include "a68g-prelude.h" #include "a68g-mp.h" #include "a68g-double.h" #if (A68_LEVEL >= 3) #if defined (HAVE_GNU_MPFR) #define DEFAULT GMP_RNDN #define MPFR_REAL_BITS (REAL_MANT_DIG) #define MPFR_LONG_REAL_BITS (FLT128_MANT_DIG) #define MPFR_MP_BITS (MANT_BITS (mpfr_digits ())) #define NO_MPFR ((mpfr_ptr) NULL) #define CHECK_MPFR(p, z) PRELUDE_ERROR (mpfr_number_p (z) == 0, (p), ERROR_MATH, M_LONG_LONG_REAL) void zeroin_mpfr (NODE_T *, mpfr_t *, mpfr_t, mpfr_t, mpfr_t, int (*)(mpfr_t, const mpfr_t, mpfr_rnd_t)); //! @brief Decimal digits in mpfr significand. size_t mpfr_digits (void) { return (long_mp_digits () * LOG_MP_RADIX); } //! @brief Convert mp to mpfr. void mp_to_mpfr (NODE_T * p, MP_T * z, mpfr_t * x, int digits) { // This routine looks a lot like "strtod". (void) p; mpfr_set_ui (*x, 0, DEFAULT); if (MP_EXPONENT (z) * (MP_T) LOG_MP_RADIX > (MP_T) REAL_MIN_10_EXP) { int j, expo; BOOL_T neg = MP_DIGIT (z, 1) < 0; mpfr_t term, W; mpfr_inits2 (MPFR_MP_BITS, term, W, NO_MPFR); MP_DIGIT (z, 1) = ABS (MP_DIGIT (z, 1)); expo = (int) (MP_EXPONENT (z) * LOG_MP_RADIX); mpfr_set_ui (W, 10, DEFAULT); mpfr_pow_si (W, W, expo, DEFAULT); for (j = 1; j <= digits; j++) { mpfr_set_d (term, MP_DIGIT (z, j), DEFAULT); mpfr_mul (term, term, W, DEFAULT); mpfr_add (*x, *x, term, DEFAULT); mpfr_div_ui (W, W, MP_RADIX, DEFAULT); } if (neg) { mpfr_neg (*x, *x, DEFAULT); } } } //! @brief Convert mpfr to mp number. MP_T *mpfr_to_mp (NODE_T * p, MP_T * z, mpfr_t * x, int digits) { int j, k, sign_x, sum, W; mpfr_t u, v, t; SET_MP_ZERO (z, digits); if (mpfr_zero_p (*x)) { return z; } sign_x = mpfr_sgn (*x); mpfr_inits2 (MPFR_MP_BITS, t, u, v, NO_MPFR); // Scale to [0, 0.1>. // a = ABS (x); mpfr_set (u, *x, DEFAULT); mpfr_abs (u, u, DEFAULT); // expo = (int) log10q (a); mpfr_log10 (v, u, DEFAULT); INT_T expo = mpfr_get_si (v, DEFAULT); // v /= ten_up_double (expo); mpfr_set_ui (v, 10, DEFAULT); mpfr_pow_si (v, v, expo, DEFAULT); mpfr_div (u, u, v, DEFAULT); expo--; if (mpfr_cmp_ui (u, 1) >= 0) { mpfr_div_ui (u, u, 10, DEFAULT); expo++; } // Transport digits of x to the mantissa of z. sum = 0; W = (MP_RADIX / 10); for (k = 0, j = 1; j <= digits && k < mpfr_digits (); k++) { mpfr_mul_ui (t, u, 10, DEFAULT); mpfr_floor (v, t); mpfr_frac (u, t, DEFAULT); sum += W * mpfr_get_d (v, DEFAULT); W /= 10; if (W < 1) { MP_DIGIT (z, j++) = (MP_T) sum; sum = 0; W = (MP_RADIX / 10); } } // Store the last digits. if (j <= digits) { MP_DIGIT (z, j) = (MP_T) sum; } (void) align_mp (z, &expo, digits); MP_EXPONENT (z) = (MP_T) expo; MP_DIGIT (z, 1) *= sign_x; check_mp_exp (p, z); mpfr_clear (t); mpfr_clear (u); mpfr_clear (v); return z; } //! @brief PROC long long mpfr = (LONG LONG REAL) LONG LONG REAL void genie_mpfr_mp (NODE_T * p) { MOID_T *mode = MOID (p); int digits = DIGITS (mode); int size = SIZE (mode); mpfr_t u; MP_T *z = (MP_T *) STACK_OFFSET (-size); mpfr_init2 (u, MPFR_MP_BITS); mp_to_mpfr (p, z, &u, digits); mpfr_out_str (stdout, 10, 0, u, DEFAULT); CHECK_MPFR (p, u); mpfr_to_mp (p, z, &u, digits); mpfr_clear (u); } //! @brief mpfr_beta_inc void mpfr_beta_inc (mpfr_t I, mpfr_t s, mpfr_t t, mpfr_t x, mpfr_rnd_t rnd) { // Incomplete beta function I{x}(s, t). // From a continued fraction, see dlmf.nist.gov/8.17; Lentz's algorithm. errno = EDOM; // Until proven otherwise //mpfr_printf ("%.128Rf", x); if (mpfr_cmp_d (x, 0) < 0 || mpfr_cmp_d (x, 1) > 0) { mpfr_set_nan (I); } else { mpfr_t a, b, c, d, e, F, T, W; int N, m, cont = A68_TRUE; mpfr_prec_t lim = 2 * mpfr_get_prec (x); mpfr_inits2 (MPFR_MP_BITS, a, b, c, d, e, F, T, W, NO_MPFR); // Rapid convergence when x < (s+1)/(s+t+2) mpfr_add_d (a, s, 1, rnd); mpfr_add (b, s, t, rnd); mpfr_add_d (b, b, 2, rnd); mpfr_div (c, a, b, rnd); // Recursion when x > (s+1)/(s+t+2) if (mpfr_cmp (x, c) > 0) { // B{x}(s, t) = 1 - B{1-x}(t, s) mpfr_d_sub (d, 1, x, rnd); mpfr_beta_inc (I, t, s, d, rnd); mpfr_d_sub (I, 1, I, rnd); mpfr_clears (a, b, c, d, e, F, T, W, NO_MPFR); return; } // Lentz's algorithm for continued fraction. mpfr_set_d (W, 1, rnd); mpfr_set_d (F, 1, rnd); mpfr_set_d (c, 1, rnd); mpfr_set_d (d, 0, rnd); for (N = 0, m = 0; cont && N < lim; N++) { if (N == 0) { // d := 1 mpfr_set_d (T, 1, rnd); } else if (N % 2 == 0) { // d{2m} := x m(t-m)/((s+2m-1)(s+2m)) mpfr_sub_si (a, t, m, rnd); mpfr_mul_si (a, a, m, rnd); mpfr_mul (a, a, x, rnd); mpfr_add_si (b, s, m, rnd); mpfr_add_si (b, b, m, rnd); mpfr_set (e, b, rnd); mpfr_sub_d (b, b, 1, rnd); mpfr_mul (b, b, e, rnd); mpfr_div (T, a, b, rnd); } else { // d{2m+1} := -x (s+m)(s+t+m)/((s+2m+1)(s+2m)) mpfr_add_si (e, s, m, rnd); mpfr_add (T, e, t, rnd); mpfr_mul (a, e, T, rnd); mpfr_mul (a, a, x, rnd); mpfr_add_si (b, s, m, rnd); mpfr_add_si (b, b, m, rnd); mpfr_set (e, b, rnd); mpfr_add_d (b, b, 1, rnd); mpfr_mul (b, b, e, rnd); mpfr_div (T, a, b, rnd); mpfr_neg (T, T, rnd); m++; } mpfr_mul (e, T, d, rnd); mpfr_add_d (d, e, 1, rnd); mpfr_d_div (d, 1, d, rnd); mpfr_div (e, T, c, rnd); mpfr_add_d (c, e, 1, rnd); mpfr_mul (F, F, c, rnd); mpfr_mul (F, F, d, rnd); if (mpfr_cmp (F, W) == 0) { cont = A68_FALSE; errno = 0; } else { mpfr_set (W, F, rnd); } } // I{x}(s,t)=x^s(1-x)^t / a / B(s,t) F mpfr_pow (a, x, s, rnd); mpfr_d_sub (b, 1, x, rnd); mpfr_pow (b, b, t, rnd); mpfr_mul (a, a, b, rnd); mpfr_beta (W, s, t, rnd); mpfr_sub_d (F, F, 1, rnd); mpfr_mul (b, F, a, rnd); mpfr_div (b, b, W, rnd); mpfr_div (b, b, s, rnd); mpfr_set (I, b, rnd); mpfr_clears (a, b, c, d, e, F, T, W, NO_MPFR); } } //! @brief PROC long long erf = (LONG LONG REAL) LONG LONG REAL void genie_mpfr_erf_mp (NODE_T * p) { MOID_T *mode = MOID (p); int digits = DIGITS (mode); int size = SIZE (mode); mpfr_t u; MP_T *z = (MP_T *) STACK_OFFSET (-size); mpfr_init2 (u, MPFR_MP_BITS); mp_to_mpfr (p, z, &u, digits); mpfr_erf (u, u, DEFAULT); CHECK_MPFR (p, u); mpfr_to_mp (p, z, &u, digits); mpfr_clear (u); } //! @brief PROC long long erfc = (LONG LONG REAL) LONG LONG REAL void genie_mpfr_erfc_mp (NODE_T * p) { MOID_T *mode = MOID (p); int digits = DIGITS (mode); int size = SIZE (mode); mpfr_t u; MP_T *z = (MP_T *) STACK_OFFSET (-size); mpfr_init2 (u, MPFR_MP_BITS); mp_to_mpfr (p, z, &u, digits); mpfr_erfc (u, u, DEFAULT); CHECK_MPFR (p, u); mpfr_to_mp (p, z, &u, digits); mpfr_clear (u); } //! @brief PROC long long inverf = (LONG LONG REAL) LONG LONG REAL void genie_mpfr_inverf_mp (NODE_T * _p_) { MOID_T *mode = MOID (_p_); int digits = DIGITS (mode), size = SIZE (mode); REAL_T x0; mpfr_t a, b, u, y; MP_T *z = (MP_T *) STACK_OFFSET (-size); A68 (f_entry) = _p_; mpfr_inits2 (MPFR_MP_BITS, a, b, u, y, NO_MPFR); mp_to_mpfr (_p_, z, &y, digits); x0 = a68_inverf (mp_to_real (_p_, z, digits)); // a = z - 1e-9; // b = z + 1e-9; mpfr_set_d (a, x0 - 1e-9, DEFAULT); mpfr_set_d (b, x0 + 1e-9, DEFAULT); zeroin_mpfr (_p_, &u, a, b, y, mpfr_erf); MATH_RTE (_p_, errno != 0, M_LONG_LONG_REAL, NO_TEXT); mpfr_to_mp (_p_, z, &u, digits); mpfr_clears (a, b, u, y, NO_MPFR); } //! @brief PROC long long inverfc = (LONG LONG REAL) LONG LONG REAL void genie_mpfr_inverfc_mp (NODE_T * p) { MOID_T *mode = MOID (p); ADDR_T pop_sp = A68_SP; int digits = DIGITS (mode), size = SIZE (mode); MP_T *z = (MP_T *) STACK_OFFSET (-size); one_minus_mp (p, z, z, digits); A68_SP = pop_sp; genie_inverf_mp (p); } //! @brief PROC long long gamma = (LONG LONG REAL) LONG LONG REAL void genie_gamma_mpfr (NODE_T * p) { MOID_T *mode = MOID (p); int digits = DIGITS (mode); int size = SIZE (mode); mpfr_t u; MP_T *z = (MP_T *) STACK_OFFSET (-size); mpfr_init2 (u, MPFR_MP_BITS); mp_to_mpfr (p, z, &u, digits); mpfr_gamma (u, u, DEFAULT); CHECK_MPFR (p, u); mpfr_to_mp (p, z, &u, digits); mpfr_clear (u); } //! @brief PROC long long ln gamma = (LONG LONG REAL) LONG LONG REAL void genie_lngamma_mpfr (NODE_T * p) { MOID_T *mode = MOID (p); int digits = DIGITS (mode); int size = SIZE (mode); mpfr_t u; MP_T *z = (MP_T *) STACK_OFFSET (-size); mpfr_init2 (u, MPFR_MP_BITS); mp_to_mpfr (p, z, &u, digits); mpfr_lngamma (u, u, DEFAULT); CHECK_MPFR (p, u); mpfr_to_mp (p, z, &u, digits); mpfr_clear (u); } void genie_gamma_inc_real_mpfr (NODE_T * p) { A68_REAL x, s; mpfr_t xx, ss; POP_OBJECT (p, &x, A68_REAL); POP_OBJECT (p, &s, A68_REAL); mpfr_inits2 (MPFR_LONG_REAL_BITS, ss, xx, NO_MPFR); mpfr_set_d (xx, VALUE (&x), DEFAULT); mpfr_set_d (ss, VALUE (&s), DEFAULT); mpfr_gamma_inc (ss, ss, xx, DEFAULT); CHECK_MPFR (p, ss); PUSH_VALUE (p, mpfr_get_d (ss, DEFAULT), A68_REAL); mpfr_clears (ss, xx, NO_MPFR); } void genie_gamma_inc_real_16_mpfr (NODE_T * p) { A68_LONG_REAL x, s; mpfr_t xx, ss; POP_OBJECT (p, &x, A68_LONG_REAL); POP_OBJECT (p, &s, A68_LONG_REAL); mpfr_inits2 (MPFR_LONG_REAL_BITS, ss, xx, NO_MPFR); mpfr_set_float128 (xx, VALUE (&x).f, DEFAULT); mpfr_set_float128 (ss, VALUE (&s).f, DEFAULT); mpfr_gamma_inc (ss, ss, xx, DEFAULT); CHECK_MPFR (p, ss); PUSH_VALUE (p, dble (mpfr_get_float128 (ss, DEFAULT)), A68_LONG_REAL); mpfr_clears (ss, xx, NO_MPFR); } void genie_gamma_inc_mpfr (NODE_T * p) { int digits = DIGITS (MOID (p)), size = SIZE (MOID (p)); MP_T *x = (MP_T *) STACK_OFFSET (-size); MP_T *s = (MP_T *) STACK_OFFSET (-2 * size); mpfr_t xx, ss; A68_SP -= size; mpfr_inits2 (MPFR_MP_BITS, ss, xx, NO_MPFR); mp_to_mpfr (p, x, &xx, digits); mp_to_mpfr (p, s, &ss, digits); mpfr_gamma_inc (ss, ss, xx, DEFAULT); CHECK_MPFR (p, ss); mpfr_to_mp (p, s, &ss, digits); mpfr_clears (ss, xx, NO_MPFR); } void genie_beta_mpfr (NODE_T * p) { int digits = DIGITS (MOID (p)), size = SIZE (MOID (p)); MP_T *x = (MP_T *) STACK_OFFSET (-size); MP_T *s = (MP_T *) STACK_OFFSET (-2 * size); mpfr_t xx, ss; A68_SP -= size; mpfr_inits2 (MPFR_MP_BITS, ss, xx, NO_MPFR); mp_to_mpfr (p, x, &xx, digits); mp_to_mpfr (p, s, &ss, digits); mpfr_beta (ss, ss, xx, DEFAULT); CHECK_MPFR (p, ss); mpfr_to_mp (p, s, &ss, digits); mpfr_clears (ss, xx, NO_MPFR); } void genie_ln_beta_mpfr (NODE_T * p) { int digits = DIGITS (MOID (p)), size = SIZE (MOID (p)); MP_T *b = (MP_T *) STACK_OFFSET (-size); MP_T *a = (MP_T *) STACK_OFFSET (-2 * size); mpfr_t bb, aa, yy, zz; A68_SP -= size; mpfr_inits2 (MPFR_MP_BITS, aa, bb, yy, zz, NO_MPFR); mp_to_mpfr (p, b, &bb, digits); mp_to_mpfr (p, a, &aa, digits); mpfr_lngamma (zz, aa, DEFAULT); mpfr_lngamma (yy, bb, DEFAULT); mpfr_add (zz, zz, yy, DEFAULT); mpfr_add (yy, aa, bb, DEFAULT); mpfr_lngamma (yy, yy, DEFAULT); mpfr_sub (aa, zz, yy, DEFAULT); CHECK_MPFR (p, aa); mpfr_to_mp (p, a, &aa, digits); mpfr_clears (aa, bb, yy, zz, NO_MPFR); } void genie_beta_inc_mpfr (NODE_T * p) { int digits = DIGITS (MOID (p)), size = SIZE (MOID (p)); MP_T *x = (MP_T *) STACK_OFFSET (-size); MP_T *t = (MP_T *) STACK_OFFSET (-2 * size); MP_T *s = (MP_T *) STACK_OFFSET (-3 * size); mpfr_t xx, ss, tt; A68_SP -= 2 * size; mpfr_inits2 (MPFR_MP_BITS, ss, tt, xx, NO_MPFR); mp_to_mpfr (p, x, &xx, digits); mp_to_mpfr (p, s, &ss, digits); mp_to_mpfr (p, t, &tt, digits); mpfr_beta_inc (ss, ss, tt, xx, DEFAULT); CHECK_MPFR (p, ss); mpfr_to_mp (p, s, &ss, digits); mpfr_clears (ss, tt, xx, NO_MPFR); } //! @brief zeroin void zeroin_mpfr (NODE_T * _p_, mpfr_t * z, mpfr_t a, mpfr_t b, mpfr_t y, int (*f) (mpfr_t, const mpfr_t, mpfr_rnd_t)) { // 'zeroin' // MCA 2310 in 'ALGOL 60 Procedures in Numerical Algebra' by Th.J. Dekker int sign, its = 5; BOOL_T go_on = A68_TRUE; mpfr_t c, fa, fb, fc, tolb, eps, p, q, v, w; mpfr_inits2 (MPFR_MP_BITS, c, fa, fb, fc, tolb, eps, p, q, v, w, NO_MPFR); mpfr_set_ui (eps, 10, DEFAULT); mpfr_pow_si (eps, eps, -(mpfr_digits () - 2), DEFAULT); f (fa, a, DEFAULT); mpfr_sub (fa, fa, y, DEFAULT); f (fb, b, DEFAULT); mpfr_sub (fb, fb, y, DEFAULT); mpfr_set (c, a, DEFAULT); mpfr_set (fc, fa, DEFAULT); while (go_on && (its--) > 0) { mpfr_abs (v, fc, DEFAULT); mpfr_abs (w, fb, DEFAULT); if (mpfr_cmp (v, w) < 0) { mpfr_set (a, b, DEFAULT); mpfr_set (fa, fb, DEFAULT); mpfr_set (b, c, DEFAULT); mpfr_set (fb, fc, DEFAULT); mpfr_set (c, a, DEFAULT); mpfr_set (fc, fa, DEFAULT); } mpfr_abs (tolb, b, DEFAULT); mpfr_add_ui (tolb, tolb, 1, DEFAULT); mpfr_mul (tolb, tolb, eps, DEFAULT); mpfr_add (w, c, b, DEFAULT); mpfr_div_2ui (w, w, 1, DEFAULT); mpfr_sub (v, w, b, DEFAULT); mpfr_abs (v, v, DEFAULT); go_on = mpfr_cmp (v, tolb) > 0; if (go_on) { mpfr_sub (p, b, a, DEFAULT); mpfr_mul (p, p, fb, DEFAULT); mpfr_sub (q, fa, fb, DEFAULT); if (mpfr_cmp_ui (p, 0) < 0) { mpfr_neg (p, p, DEFAULT); mpfr_neg (q, q, DEFAULT); } mpfr_set (a, b, DEFAULT); mpfr_set (fa, fb, DEFAULT); mpfr_abs (v, q, DEFAULT); mpfr_mul (v, v, tolb, DEFAULT); if (mpfr_cmp (p, v) <= 0) { if (mpfr_cmp (c, b) > 0) { mpfr_add (b, b, tolb, DEFAULT); } else { mpfr_sub (b, b, tolb, DEFAULT); } } else { mpfr_sub (v, w, b, DEFAULT); mpfr_mul (v, v, q, DEFAULT); if (mpfr_cmp (p, v) < 0) { mpfr_div (v, p, q, DEFAULT); mpfr_add (b, v, b, DEFAULT); } else { mpfr_set (b, w, DEFAULT); } } f (fb, b, DEFAULT); mpfr_sub (fb, fb, y, DEFAULT); sign = mpfr_sgn (fb) + mpfr_sgn (fc); if (ABS (sign) == 2) { mpfr_set (c, a, DEFAULT); mpfr_set (fc, fa, DEFAULT); } } } CHECK_MPFR (_p_, b); mpfr_set (*z, b, DEFAULT); mpfr_clears (c, fa, fb, fc, tolb, eps, p, q, v, w, NO_MPFR); } #endif #endif algol68g-3.1.2/src/a68g/format.c0000644000175000017500000026020514361065320013056 00000000000000//! @file format.c //! @author J. Marcel van der Veer // //! @section Copyright // // This file is part of Algol68G - an Algol 68 compiler-interpreter. // Copyright 2001-2023 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" #include "a68g-genie.h" #include "a68g-frames.h" #include "a68g-prelude.h" #include "a68g-mp.h" #include "a68g-double.h" #include "a68g-transput.h" // 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 Convert to other radix, binary up to hexadecimal. BOOL_T convert_radix (NODE_T * p, UNSIGNED_T z, int radix, int width) { reset_transput_buffer (EDIT_BUFFER); if (radix < 2 || radix > 16) { radix = 16; } if (width > 0) { while (width > 0) { int digit = (int) (z % (UNSIGNED_T) radix); plusto_transput_buffer (p, digchar (digit), EDIT_BUFFER); width--; z /= (UNSIGNED_T) radix; } return z == 0; } else if (width == 0) { do { int digit = (int) (z % (UNSIGNED_T) radix); plusto_transput_buffer (p, digchar (digit), EDIT_BUFFER); z /= (UNSIGNED_T) radix; } while (z > 0); return A68_TRUE; } else { return A68_FALSE; } } //! @brief Handle format error event. 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 (A68_RUNTIME_ERROR, p, diag); exit_genie (p, A68_RUNTIME_ERROR); } } //! @brief Initialise processing of pictures. 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 (A68_FP, 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. 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 (A68_FP, 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. 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 (A68_FP, 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. A68_FP = FRAME_POINTER (file); A68_SP = 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. 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, M_INT, NSYMBOL (p), (BYTE_T *) & u) == A68_FALSE) { diagnostic (A68_RUNTIME_ERROR, p, ERROR_IN_DENOTATION, M_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 (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. 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 (A68_FP, 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, ERROR_INTERNAL_CONSISTENCY, __func__); } COUNT (collitem) = 0; // This insertion is now done } else if (IS (picture, REPLICATOR) || IS (picture, COLLECTION)) { BOOL_T go_on = A68_TRUE; NODE_T *a68_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. a68_select = scan_format_pattern (NEXT_SUB (picture), ref_file); if (a68_select != NO_NODE) { return a68_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. 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 (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 (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. void pattern_error (NODE_T * p, MOID_T * mode, int att) { diagnostic (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. void unite_to_number (NODE_T * p, MOID_T * mode, BYTE_T * item) { ADDR_T sp = A68_SP; PUSH_UNION (p, mode); PUSH (p, item, (int) SIZE (mode)); A68_SP = sp + SIZE (M_NUMBER); } //! @brief Write a group of insertions. void write_insertion (NODE_T * p, A68_REF ref_file, MOOD_T mood) { for (; p != NO_NODE; FORWARD (p)) { write_insertion (SUB (p), ref_file, mood); if (IS (p, FORMAT_ITEM_L)) { plusab_transput_buffer (p, FORMATTED_BUFFER, NEWLINE_CHAR); write_purge_buffer (p, ref_file, FORMATTED_BUFFER); } else if (IS (p, FORMAT_ITEM_P)) { plusab_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)) { plusab_transput_buffer (p, FORMATTED_BUFFER, BLANK_CHAR); } else if (IS (p, FORMAT_ITEM_Y)) { PUSH_REF (p, ref_file); PUSH_VALUE (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++) { plusab_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++) { plusab_transput_buffer (p, FORMATTED_BUFFER, BLANK_CHAR); } } return; } } } //! @brief Write string to file following current format. 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) { plusab_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. 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_TRUE; FORWARD (p); } else { *right_align = A68_FALSE; } 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. 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. 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. 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_VALUE (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 (A68_RUNTIME_ERROR, p, ERROR_FORMAT_INTS_REQUIRED, M_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 == M_REAL || mode == M_INT) { def_expo = EXP_WIDTH + 1; } else if (mode == M_LONG_REAL || mode == M_LONG_INT) { def_expo = LONG_EXP_WIDTH + 1; } else if (mode == M_LONG_LONG_REAL || mode == M_LONG_LONG_INT) { def_expo = LONG_LONG_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 (A68_RUNTIME_ERROR, p, ERROR_FORMAT_INTS_REQUIRED, M_INT); exit_genie (p, A68_RUNTIME_ERROR); break; } } PUSH_VALUE (p, VALUE (&a_width), A68_INT); PUSH_VALUE (p, VALUE (&a_after), A68_INT); PUSH_VALUE (p, VALUE (&a_expo), A68_INT); PUSH_VALUE (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. void write_c_pattern (NODE_T * p, MOID_T * mode, BYTE_T * item, A68_REF ref_file) { BOOL_T right_align, sign, invalid; int width = 0, after = 0, letter; ADDR_T pop_sp = A68_SP; 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_VALUE (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 == M_REAL || mode == M_INT) { width = REAL_WIDTH + EXP_WIDTH + 4; after = REAL_WIDTH - 1; expo = EXP_WIDTH + 1; } else if (mode == M_LONG_REAL || mode == M_LONG_INT) { width = LONG_REAL_WIDTH + LONG_EXP_WIDTH + 4; after = LONG_REAL_WIDTH - 1; expo = LONG_EXP_WIDTH + 1; } else if (mode == M_LONG_LONG_REAL || mode == M_LONG_LONG_INT) { width = LONG_LONG_REAL_WIDTH + LONG_LONG_EXP_WIDTH + 4; after = LONG_LONG_REAL_WIDTH - 1; expo = LONG_LONG_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_VALUE (p, (sign ? width : -width), A68_INT); PUSH_VALUE (p, after, A68_INT); PUSH_VALUE (p, expo, A68_INT); PUSH_VALUE (p, 1, A68_INT); str = real (p); A68_SP = 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 == M_REAL || mode == M_INT) { width = REAL_WIDTH + 2; after = REAL_WIDTH - 1; } else if (mode == M_LONG_REAL || mode == M_LONG_INT) { width = LONG_REAL_WIDTH + 2; after = LONG_REAL_WIDTH - 1; } else if (mode == M_LONG_LONG_REAL || mode == M_LONG_LONG_INT) { width = LONG_LONG_REAL_WIDTH + 2; after = LONG_LONG_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_VALUE (p, (sign ? width : -width), A68_INT); PUSH_VALUE (p, after, A68_INT); str = fixed (p); A68_SP = 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 == M_BITS) { width = (int) ceil ((REAL_T) BITS_WIDTH / (REAL_T) nibble); } else if (mode == M_LONG_BITS || mode == M_LONG_LONG_BITS) { #if (A68_LEVEL <= 2) width = (int) ceil ((REAL_T) get_mp_bits_width (mode) / (REAL_T) nibble); #else width = (int) ceil ((REAL_T) LONG_BITS_WIDTH / (REAL_T) nibble); #endif } } if (mode == M_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 == M_LONG_BITS) { #if (A68_LEVEL >= 3) A68_LONG_BITS *z = (A68_LONG_BITS *) item; reset_transput_buffer (EDIT_BUFFER); if (!convert_radix_double (p, VALUE (z), radix, width)) { errno = EDOM; value_error (p, mode, ref_file); } str = get_transput_buffer (EDIT_BUFFER); #else int digits = DIGITS (mode); MP_T *u = (MP_T *) item; MP_T *v = nil_mp (p, digits); MP_T *w = nil_mp (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); #endif } else if (mode == M_LONG_LONG_BITS) { #if (A68_LEVEL <= 2) int digits = DIGITS (mode); MP_T *u = (MP_T *) item; MP_T *v = nil_mp (p, digits); MP_T *w = nil_mp (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); #endif } } // Did the conversion succeed?. if (IS (p, CHAR_C_PATTERN) || IS (p, STRING_C_PATTERN)) { invalid = A68_FALSE; } else { invalid = (strchr (str, ERROR_CHAR) != NO_TEXT); } if (invalid) { 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--) { plusab_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--) { plusab_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. 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. 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); plusab_transput_buffer (p, INPUT_BUFFER, (char) ch); } } //! @brief Read %[-][+][w][.][d]s/d/i/f/e/b/o/x formats. 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 = A68_SP; 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 != M_INT && mode != M_LONG_INT && mode != M_LONG_LONG_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 != M_REAL && mode != M_LONG_REAL && mode != M_LONG_LONG_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 != M_BITS && mode != M_LONG_BITS && mode != M_LONG_LONG_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)) { plusab_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); } } A68_SP = pop_sp; } // INTEGRAL, REAL, COMPLEX and BITS patterns. //! @brief Count Z and D frames in a mould. 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. 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. 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. void put_zeroes_to_integral (NODE_T * p, int n) { for (; n > 0; n--) { plusab_transput_buffer (p, EDIT_BUFFER, '0'); } } //! @brief Pad a sign to integral representation. 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)) { plusab_transput_buffer (p, EDIT_BUFFER, (char) (sign >= 0 ? '+' : '-')); } else { plusab_transput_buffer (p, EDIT_BUFFER, (char) (sign >= 0 ? BLANK_CHAR : '-')); } } //! @brief Write point, exponent or plus-i-times symbol. 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. void write_mould_put_sign (NODE_T * p, char **q) { if ((*q)[0] == '+' || (*q)[0] == '-' || (*q)[0] == BLANK_CHAR) { plusab_transput_buffer (p, FORMATTED_BUFFER, (*q)[0]); (*q)++; } } //! @brief Write character according to a mould. void add_char_mould (NODE_T * p, char ch, char **q) { if (ch != NULL_CHAR) { plusab_transput_buffer (p, FORMATTED_BUFFER, ch); (*q)++; } } //! @brief Write string according to a mould. void write_mould (NODE_T * p, A68_REF ref_file, int type, char **q, MOOD_T * 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 = (MOOD_T) (DIGIT_NORMAL | INSERTION_NORMAL); } } else { add_char_mould (p, (*q)[0], q); *mood = (MOOD_T) (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 = (MOOD_T) (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. void write_integral_pattern (NODE_T * p, MOID_T * mode, MOID_T * root, BYTE_T * item, A68_REF ref_file) { errno = 0; if (!(mode == M_INT || mode == M_LONG_INT || mode == M_LONG_LONG_INT)) { pattern_error (p, root, ATTRIBUTE (p)); } else { ADDR_T pop_sp = A68_SP; char *str = "*"; int width = 0, sign = 0; MOOD_T 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 == M_INT) { A68_INT *z = (A68_INT *) item; sign = SIGN (VALUE (z)); str = sub_whole (p, ABS (VALUE (z)), width); } else if (mode == M_LONG_INT) { #if (A68_LEVEL >= 3) A68_LONG_INT *z = (A68_LONG_INT *) item; QUAD_WORD_T w = VALUE (z); sign = sign_int_16 (w); str = long_sub_whole_double (p, abs_int_16 (w), width); #else MP_T *z = (MP_T *) item; sign = MP_SIGN (z); MP_DIGIT (z, 1) = ABS (MP_DIGIT (z, 1)); str = long_sub_whole (p, z, DIGITS (mode), width); #endif } else if (mode == M_LONG_LONG_INT) { MP_T *z = (MP_T *) item; sign = MP_SIGN (z); MP_DIGIT (z, 1) = ABS (MP_DIGIT (z, 1)); str = long_sub_whole (p, z, DIGITS (mode), width); } // Edit string and output. if (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 = (MOOD_T) (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); } A68_SP = pop_sp; } } //! @brief Write REAL value using real pattern. void write_real_pattern (NODE_T * p, MOID_T * mode, MOID_T * root, BYTE_T * item, A68_REF ref_file) { errno = 0; if (!(mode == M_REAL || mode == M_LONG_REAL || mode == M_LONG_LONG_REAL || mode == M_INT || mode == M_LONG_INT || mode == M_LONG_LONG_INT)) { pattern_error (p, root, ATTRIBUTE (p)); } else { ADDR_T pop_sp = A68_SP; int 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; MOOD_T 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); } 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 == M_REAL || mode == M_INT) { REAL_T x; if (mode == M_REAL) { x = VALUE ((A68_REAL *) item); } else { x = (REAL_T) VALUE ((A68_INT *) item); } CHECK_REAL (p, x); 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 == M_LONG_REAL || mode == M_LONG_INT) { #if (A68_LEVEL >= 3) QUAD_WORD_T x = VALUE ((A68_DOUBLE *) item); if (mode == M_LONG_INT) { x = int_16_to_real_16 (p, x); } CHECK_DOUBLE_REAL (p, x.f); exp_value = 0; sign = sign_real_16 (x); if (sign_mould != NO_NODE) { put_sign_to_integral (sign_mould, sign); } x.f = fabsq (x.f); if (expo_mould != NO_NODE) { standardise_double (&(x.f), stag_digits, frac_digits, &exp_value); } str = sub_fixed_double (p, x.f, mant_length, frac_digits, LONG_REAL_WIDTH); #else ADDR_T pop_sp2 = A68_SP; int digits = DIGITS (mode); MP_T *x = nil_mp (p, digits); (void) 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); A68_SP = pop_sp2; #endif } else if (mode == M_LONG_LONG_REAL || mode == M_LONG_LONG_INT) { ADDR_T pop_sp2 = A68_SP; int digits = DIGITS (mode); MP_T *x = nil_mp (p, digits); (void) 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); A68_SP = pop_sp2; } // Edit and output the string. if (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 (strchr (stag_str, ERROR_CHAR) != NO_TEXT) { value_error (p, root, ref_file); } str = 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 = (MOOD_T) (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 = (MOOD_T) (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, M_INT, root, (BYTE_T *) & z, ref_file); } A68_SP = pop_sp; } } //! @brief Write COMPLEX value using complex pattern. 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; errno = 0; // 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. void write_bits_pattern (NODE_T * p, MOID_T * mode, BYTE_T * item, A68_REF ref_file) { MOOD_T mood; int width = 0, radix; char *str; ADDR_T pop_sp = A68_SP; if (mode == M_BITS) { A68_BITS *z = (A68_BITS *) item; // 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 (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); } } else if (mode == M_LONG_BITS) { #if (A68_LEVEL >= 3) A68_LONG_BITS *z = (A68_LONG_BITS *) item; // 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 (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_double (p, VALUE (z), radix, width)) { errno = EDOM; value_error (p, mode, ref_file); } #else int digits = DIGITS (mode); MP_T *u = (MP_T *) item; MP_T *v = nil_mp (p, digits); MP_T *w = nil_mp (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 (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); } #endif } else if (mode == M_LONG_LONG_BITS) { #if (A68_LEVEL <= 2) int digits = DIGITS (mode); MP_T *u = (MP_T *) item; MP_T *v = nil_mp (p, digits); MP_T *w = nil_mp (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 (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); } #endif } // Output the edited string. mood = (MOOD_T) (DIGIT_BLANK | INSERTION_NORMAL); str = get_transput_buffer (EDIT_BUFFER); write_mould (NEXT_SUB (p), ref_file, INTEGRAL_MOULD, &str, &mood); A68_SP = pop_sp; } //! @brief Write value to file. 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, M_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, M_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, M_REAL, item, ref_file); } else if (IS (p, REAL_PATTERN)) { write_real_pattern (p, M_REAL, M_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, M_REAL, M_COMPLEX, (BYTE_T *) item, (BYTE_T *) & im, ref_file); } else { pattern_error (p, M_REAL, ATTRIBUTE (p)); } } //! @brief Write value to file. 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, M_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, M_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, M_LONG_REAL, item, ref_file); } else if (IS (p, REAL_PATTERN)) { write_real_pattern (p, M_LONG_REAL, M_LONG_REAL, item, ref_file); } else if (IS (p, COMPLEX_PATTERN)) { #if (A68_LEVEL >= 3) ADDR_T pop_sp = A68_SP; A68_LONG_REAL *z = (A68_LONG_REAL *) STACK_TOP; QUAD_WORD_T im; im.f = 0.0q; PUSH_VALUE (p, im, A68_LONG_REAL); write_complex_pattern (p, M_LONG_REAL, M_LONG_COMPLEX, item, (BYTE_T *) z, ref_file); A68_SP = pop_sp; #else ADDR_T pop_sp = A68_SP; MP_T *z = nil_mp (p, DIGITS (M_LONG_REAL)); z[0] = (MP_T) INIT_MASK; write_complex_pattern (p, M_LONG_REAL, M_LONG_COMPLEX, item, (BYTE_T *) z, ref_file); A68_SP = pop_sp; #endif } else { pattern_error (p, M_LONG_REAL, ATTRIBUTE (p)); } } //! @brief Write value to file. void genie_write_long_mp_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, M_LONG_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, M_LONG_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, M_LONG_LONG_REAL, item, ref_file); } else if (IS (p, REAL_PATTERN)) { write_real_pattern (p, M_LONG_LONG_REAL, M_LONG_LONG_REAL, item, ref_file); } else if (IS (p, COMPLEX_PATTERN)) { ADDR_T pop_sp = A68_SP; MP_T *z = nil_mp (p, DIGITS (M_LONG_LONG_REAL)); z[0] = (MP_T) INIT_MASK; write_complex_pattern (p, M_LONG_LONG_REAL, M_LONG_LONG_COMPLEX, item, (BYTE_T *) z, ref_file); A68_SP = pop_sp; } else { pattern_error (p, M_LONG_LONG_REAL, ATTRIBUTE (p)); } } //! @brief At end of write purge all insertions. 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 (A68_FP, 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 Write value to file. void genie_write_standard_format (NODE_T * p, MOID_T * mode, BYTE_T * item, A68_REF ref_file, int *formats) { errno = 0; ABEND (mode == NO_MOID, ERROR_INTERNAL_CONSISTENCY, __func__); if (mode == M_FORMAT) { A68_FILE *file; CHECK_REF (p, ref_file, M_REF_FILE); file = FILE_DEREF (&ref_file); // Forget about eventual active formats and set up new one. if (*formats > 0) { purge_format_write (p, ref_file); } (*formats)++; A68_FP = FRAME_POINTER (file); A68_SP = STACK_POINTER (file); open_format_frame (p, ref_file, (A68_FORMAT *) item, NOT_EMBEDDED_FORMAT, A68_TRUE); } else if (mode == M_PROC_REF_FILE_VOID) { diagnostic (A68_RUNTIME_ERROR, p, ERROR_UNDEFINED_TRANSPUT, M_PROC_REF_FILE_VOID); exit_genie (p, A68_RUNTIME_ERROR); } else if (mode == M_SOUND) { diagnostic (A68_RUNTIME_ERROR, p, ERROR_UNDEFINED_TRANSPUT, M_SOUND); exit_genie (p, A68_RUNTIME_ERROR); } else if (mode == M_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, M_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, M_INT, item, ref_file); } else if (IS (pat, INTEGRAL_PATTERN)) { write_integral_pattern (pat, M_INT, M_INT, item, ref_file); } else if (IS (pat, REAL_PATTERN)) { write_real_pattern (pat, M_INT, M_INT, item, ref_file); } else if (IS (pat, COMPLEX_PATTERN)) { A68_REAL re, im; STATUS (&re) = INIT_MASK; VALUE (&re) = (REAL_T) VALUE ((A68_INT *) item); STATUS (&im) = INIT_MASK; VALUE (&im) = 0.0; write_complex_pattern (pat, M_REAL, M_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 == M_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, M_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, M_LONG_INT, item, ref_file); } else if (IS (pat, INTEGRAL_PATTERN)) { write_integral_pattern (pat, M_LONG_INT, M_LONG_INT, item, ref_file); } else if (IS (pat, REAL_PATTERN)) { write_real_pattern (pat, M_LONG_INT, M_LONG_INT, item, ref_file); } else if (IS (pat, COMPLEX_PATTERN)) { #if (A68_LEVEL >= 3) ADDR_T pop_sp = A68_SP; A68_LONG_REAL *z = (A68_LONG_REAL *) STACK_TOP; QUAD_WORD_T im; im.f = 0.0q; PUSH_VALUE (p, im, A68_LONG_REAL); write_complex_pattern (p, M_LONG_REAL, M_LONG_COMPLEX, item, (BYTE_T *) z, ref_file); A68_SP = pop_sp; #else ADDR_T pop_sp = A68_SP; MP_T *z = nil_mp (p, DIGITS (mode)); z[0] = (MP_T) INIT_MASK; write_complex_pattern (pat, M_LONG_REAL, M_LONG_COMPLEX, item, (BYTE_T *) z, ref_file); A68_SP = pop_sp; #endif } else if (IS (pat, CHOICE_PATTERN)) { INT_T k = mp_to_int (p, (MP_T *) item, DIGITS (mode)); int sk; CHECK_INT_SHORTEN (p, k); sk = (int) k; write_choice_pattern (NEXT_SUB (pat), ref_file, &sk); } else { pattern_error (p, mode, ATTRIBUTE (pat)); } } else if (mode == M_LONG_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, M_LONG_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, M_LONG_LONG_INT, item, ref_file); } else if (IS (pat, INTEGRAL_PATTERN)) { write_integral_pattern (pat, M_LONG_LONG_INT, M_LONG_LONG_INT, item, ref_file); } else if (IS (pat, REAL_PATTERN)) { write_real_pattern (pat, M_INT, M_INT, item, ref_file); } else if (IS (pat, REAL_PATTERN)) { write_real_pattern (pat, M_LONG_LONG_INT, M_LONG_LONG_INT, item, ref_file); } else if (IS (pat, COMPLEX_PATTERN)) { ADDR_T pop_sp = A68_SP; MP_T *z = nil_mp (p, DIGITS (M_LONG_LONG_REAL)); z[0] = (MP_T) INIT_MASK; write_complex_pattern (pat, M_LONG_LONG_REAL, M_LONG_LONG_COMPLEX, item, (BYTE_T *) z, ref_file); A68_SP = pop_sp; } else if (IS (pat, CHOICE_PATTERN)) { INT_T k = mp_to_int (p, (MP_T *) item, DIGITS (mode)); int sk; CHECK_INT_SHORTEN (p, k); sk = (int) k; write_choice_pattern (NEXT_SUB (pat), ref_file, &sk); } else { pattern_error (p, mode, ATTRIBUTE (pat)); } } else if (mode == M_REAL) { NODE_T *pat = get_next_format_pattern (p, ref_file, WANT_PATTERN); genie_write_real_format (pat, item, ref_file); } else if (mode == M_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 == M_LONG_LONG_REAL) { NODE_T *pat = get_next_format_pattern (p, ref_file, WANT_PATTERN); genie_write_long_mp_real_format (pat, item, ref_file); } else if (mode == M_COMPLEX) { NODE_T *pat = get_next_format_pattern (p, ref_file, WANT_PATTERN); if (IS (pat, COMPLEX_PATTERN)) { write_complex_pattern (pat, M_REAL, M_COMPLEX, &item[0], &item[SIZE (M_REAL)], ref_file); } else { // Try writing as two REAL values. genie_write_real_format (pat, item, ref_file); genie_write_standard_format (p, M_REAL, &item[SIZE (M_REAL)], ref_file, formats); } } else if (mode == M_LONG_COMPLEX) { NODE_T *pat = get_next_format_pattern (p, ref_file, WANT_PATTERN); if (IS (pat, COMPLEX_PATTERN)) { write_complex_pattern (pat, M_LONG_REAL, M_LONG_COMPLEX, &item[0], &item[SIZE (M_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, M_LONG_REAL, &item[SIZE (M_LONG_REAL)], ref_file, formats); } } else if (mode == M_LONG_LONG_COMPLEX) { NODE_T *pat = get_next_format_pattern (p, ref_file, WANT_PATTERN); if (IS (pat, COMPLEX_PATTERN)) { write_complex_pattern (pat, M_LONG_LONG_REAL, M_LONG_LONG_COMPLEX, &item[0], &item[SIZE (M_LONG_LONG_REAL)], ref_file); } else { // Try writing as two LONG LONG REAL values. genie_write_long_mp_real_format (pat, item, ref_file); genie_write_standard_format (p, M_LONG_LONG_REAL, &item[SIZE (M_LONG_LONG_REAL)], ref_file, formats); } } else if (mode == M_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) { plusab_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) { plusab_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 == M_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, M_BITS, item, ref_file); } else if (IS (pat, BITS_C_PATTERN)) { write_c_pattern (pat, M_BITS, item, ref_file); } else { pattern_error (p, mode, ATTRIBUTE (pat)); } } else if (mode == M_LONG_BITS || mode == M_LONG_LONG_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 == M_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) { plusab_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); plusab_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)) { char zz[2]; zz[0] = VALUE (z); zz[1] = '\0'; (void) c_to_a_string (pat, zz, 1); write_c_pattern (pat, mode, (BYTE_T *) zz, ref_file); } else { pattern_error (p, mode, ATTRIBUTE (pat)); } } else if (mode == M_ROW_CHAR || mode == M_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_UNION (mode)) { A68_UNION *z = (A68_UNION *) item; genie_write_standard_format (p, (MOID_T *) (VALUE (z)), &item[A68_UNION_SIZE], ref_file, formats); } else if (IS_STRUCT (mode)) { 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, formats); } } else if (IS_ROW (mode) || IS_FLEX (mode)) { MOID_T *deflexed = DEFLEX (mode); A68_ARRAY *arr; A68_TUPLE *tup; CHECK_INIT (p, INITIALISED ((A68_REF *) item), M_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 a68_index = calculate_internal_index (tup, DIM (arr)); ADDR_T elem_addr = ROW_ELEMENT (arr, a68_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, formats); done = increment_internal_index (tup, DIM (arr)); } } } if (errno != 0) { transput_error (p, ref_file, mode); } } //! @brief PROC ([] SIMPLOUT) VOID print f, write f 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 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 pop_fp, pop_sp; POP_REF (p, &row); CHECK_REF (p, row, M_ROW_SIMPLOUT); GET_DESCRIPTOR (arr, tup, &row); elems = ROW_SIZE (tup); POP_REF (p, &ref_file); CHECK_REF (p, ref_file, M_REF_FILE); file = FILE_DEREF (&ref_file); CHECK_INIT (p, INITIALISED (file), M_FILE); if (!OPENED (file)) { diagnostic (A68_RUNTIME_ERROR, p, ERROR_FILE_NOT_OPEN); exit_genie (p, A68_RUNTIME_ERROR); } if (DRAW_MOOD (file)) { diagnostic (A68_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "draw"); exit_genie (p, A68_RUNTIME_ERROR); } if (READ_MOOD (file)) { diagnostic (A68_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "read"); exit_genie (p, A68_RUNTIME_ERROR); } if (!PUT (&CHANNEL (file))) { diagnostic (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 (A68_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "binary"); exit_genie (p, A68_RUNTIME_ERROR); } // Save stack state since formats have frames. pop_fp = FRAME_POINTER (file); pop_sp = STACK_POINTER (file); FRAME_POINTER (file) = A68_FP; STACK_POINTER (file) = A68_SP; // 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]); genie_write_standard_format (p, mode, item, ref_file, &formats); elem_index += SIZE (M_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. A68_FP = FRAME_POINTER (file); A68_SP = STACK_POINTER (file); FRAME_POINTER (file) = pop_fp; STACK_POINTER (file) = pop_sp; } //! @brief Give a value error in case a character is not among expected ones. BOOL_T expect (NODE_T * p, MOID_T * m, A68_REF ref_file, const char *items, char ch) { if (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. 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_VALUE (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. 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)) { plusab_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. 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. 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; plusab_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, M_INT, ref_file); return 0; } } //! @brief Read value according to a general-pattern. 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. 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)) { plusab_transput_buffer (p, INPUT_BUFFER, (char) ch); } else { plusab_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 (strchr (SIGN_DIGITS, ch) != NO_TEXT) { if (ch == '+') { *sign = 1; } else if (ch == '-') { *sign = -1; } else if (ch == BLANK_CHAR) { ; } } else if (expect (p, m, ref_file, INT_DIGITS, (char) ch)) { plusab_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. 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 == M_BITS || m == M_LONG_BITS || m == M_LONG_LONG_BITS) ? BITS_DIGITS_BLANK : INT_DIGITS_BLANK; if (expect (p, m, ref_file, digits, (char) ch)) { plusab_transput_buffer (p, INPUT_BUFFER, (char) ((ch == BLANK_CHAR) ? '0' : ch)); } else { plusab_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 == M_BITS || m == M_LONG_BITS || m == M_LONG_LONG_BITS) ? BITS_DIGITS : INT_DIGITS; if (expect (p, m, ref_file, digits, (char) ch)) { plusab_transput_buffer (p, INPUT_BUFFER, (char) ch); } else { plusab_transput_buffer (p, INPUT_BUFFER, '0'); } } else if (IS (p, FORMAT_ITEM_S)) { plusab_transput_buffer (p, INPUT_BUFFER, '0'); } else { read_integral_mould (SUB (p), m, ref_file); } } } //! @brief Read mould according current format. 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; plusab_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. 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)) { plusab_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)) { plusab_transput_buffer (p, INPUT_BUFFER, sym[0]); } else { plusab_transput_buffer (p, INPUT_BUFFER, sym[0]); } } } } //! @brief Read REAL value using real pattern. 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; plusab_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; plusab_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. 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. 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 (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. 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 At end of read purge all insertions. 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 ((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 (A68_FP, 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 Read object with from file and store. void genie_read_standard_format (NODE_T * p, MOID_T * mode, BYTE_T * item, A68_REF ref_file, int *formats) { errno = 0; reset_transput_buffer (INPUT_BUFFER); if (mode == M_FORMAT) { A68_FILE *file; CHECK_REF (p, ref_file, M_REF_FILE); file = FILE_DEREF (&ref_file); // Forget about eventual active formats and set up new one. if (*formats > 0) { purge_format_read (p, ref_file); } (*formats)++; A68_FP = FRAME_POINTER (file); A68_SP = STACK_POINTER (file); open_format_frame (p, ref_file, (A68_FORMAT *) item, NOT_EMBEDDED_FORMAT, A68_TRUE); } else if (mode == M_PROC_REF_FILE_VOID) { diagnostic (A68_RUNTIME_ERROR, p, ERROR_UNDEFINED_TRANSPUT, M_PROC_REF_FILE_VOID); exit_genie (p, A68_RUNTIME_ERROR); } else if (mode == M_REF_SOUND) { diagnostic (A68_RUNTIME_ERROR, p, ERROR_UNDEFINED_TRANSPUT, M_REF_SOUND); exit_genie (p, A68_RUNTIME_ERROR); } else if (IS_REF (mode)) { CHECK_REF (p, *(A68_REF *) item, mode); genie_read_standard_format (p, SUB (mode), ADDRESS ((A68_REF *) item), ref_file, formats); } else if (mode == M_INT || mode == M_LONG_INT || mode == M_LONG_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_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 == M_INT) { A68_INT *z = (A68_INT *) item; VALUE (z) = k; STATUS (z) = (STATUS_MASK_T) ((VALUE (z) > 0) ? INIT_MASK : NULL_MASK); } else { diagnostic (A68_RUNTIME_ERROR, p, ERROR_DEPRECATED, mode); exit_genie (p, A68_RUNTIME_ERROR); } } else { pattern_error (p, mode, ATTRIBUTE (pat)); } } else if (mode == M_REAL || mode == M_LONG_REAL || mode == M_LONG_LONG_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 == M_COMPLEX) { NODE_T *pat = get_next_format_pattern (p, ref_file, WANT_PATTERN); if (IS (pat, COMPLEX_PATTERN)) { read_complex_pattern (pat, mode, M_REAL, item, &item[SIZE (M_REAL)], ref_file); } else { // Try reading as two REAL values. genie_read_real_format (pat, M_REAL, item, ref_file); genie_read_standard_format (p, M_REAL, &item[SIZE (M_REAL)], ref_file, formats); } } else if (mode == M_LONG_COMPLEX) { NODE_T *pat = get_next_format_pattern (p, ref_file, WANT_PATTERN); if (IS (pat, COMPLEX_PATTERN)) { read_complex_pattern (pat, mode, M_LONG_REAL, item, &item[SIZE (M_LONG_REAL)], ref_file); } else { // Try reading as two LONG REAL values. genie_read_real_format (pat, M_LONG_REAL, item, ref_file); genie_read_standard_format (p, M_LONG_REAL, &item[SIZE (M_LONG_REAL)], ref_file, formats); } } else if (mode == M_LONG_LONG_COMPLEX) { NODE_T *pat = get_next_format_pattern (p, ref_file, WANT_PATTERN); if (IS (pat, COMPLEX_PATTERN)) { read_complex_pattern (pat, mode, M_LONG_LONG_REAL, item, &item[SIZE (M_LONG_LONG_REAL)], ref_file); } else { // Try reading as two LONG LONG REAL values. genie_read_real_format (pat, M_LONG_LONG_REAL, item, ref_file); genie_read_standard_format (p, M_LONG_LONG_REAL, &item[SIZE (M_LONG_LONG_REAL)], ref_file, formats); } } else if (mode == M_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 == M_BITS || mode == M_LONG_BITS || mode == M_LONG_LONG_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 == M_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, M_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 == M_ROW_CHAR || mode == M_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_UNION (mode)) { A68_UNION *z = (A68_UNION *) item; genie_read_standard_format (p, (MOID_T *) (VALUE (z)), &item[A68_UNION_SIZE], ref_file, formats); } else if (IS_STRUCT (mode)) { 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, formats); } } else if (IS_ROW (mode) || IS_FLEX (mode)) { MOID_T *deflexed = DEFLEX (mode); A68_ARRAY *arr; A68_TUPLE *tup; CHECK_INIT (p, INITIALISED ((A68_REF *) item), M_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 a68_index = calculate_internal_index (tup, DIM (arr)); ADDR_T elem_addr = ROW_ELEMENT (arr, a68_index); BYTE_T *elem = &base_addr[elem_addr]; genie_read_standard_format (p, SUB (deflexed), elem, ref_file, formats); done = increment_internal_index (tup, DIM (arr)); } } } if (errno != 0) { transput_error (p, ref_file, mode); } } //! @brief PROC ([] SIMPLIN) VOID read f 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 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 pop_fp, pop_sp; POP_REF (p, &row); CHECK_REF (p, row, M_ROW_SIMPLIN); GET_DESCRIPTOR (arr, tup, &row); elems = ROW_SIZE (tup); POP_REF (p, &ref_file); CHECK_REF (p, ref_file, M_REF_FILE); file = FILE_DEREF (&ref_file); CHECK_INIT (p, INITIALISED (file), M_FILE); if (!OPENED (file)) { diagnostic (A68_RUNTIME_ERROR, p, ERROR_FILE_NOT_OPEN); exit_genie (p, A68_RUNTIME_ERROR); } if (DRAW_MOOD (file)) { diagnostic (A68_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "draw"); exit_genie (p, A68_RUNTIME_ERROR); } if (WRITE_MOOD (file)) { diagnostic (A68_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "write"); exit_genie (p, A68_RUNTIME_ERROR); } if (!GET (&CHANNEL (file))) { diagnostic (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 (A68_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "binary"); exit_genie (p, A68_RUNTIME_ERROR); } // Save stack state since formats have frames. pop_fp = FRAME_POINTER (file); pop_sp = STACK_POINTER (file); FRAME_POINTER (file) = A68_FP; STACK_POINTER (file) = A68_SP; // 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]); genie_read_standard_format (p, mode, item, ref_file, &formats); elem_index += SIZE (M_SIMPLIN); } // Empty the format to purge insertions. purge_format_read (p, ref_file); BODY (&FORMAT (file)) = NO_NODE; // Forget about active formats. A68_FP = FRAME_POINTER (file); A68_SP = STACK_POINTER (file); FRAME_POINTER (file) = pop_fp; STACK_POINTER (file) = pop_sp; } algol68g-3.1.2/src/a68g/parallel.c0000644000175000017500000004011214361065320013353 00000000000000//! @file parallel.c //! @author J. Marcel van der Veer // //! @section Copyright // // This file is part of Algol68G - an Algol 68 compiler-interpreter. // Copyright 2001-2023 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" #include "a68g-genie.h" #include "a68g-frames.h" #include "a68g-prelude.h" #include "a68g-mp.h" #include "a68g-double.h" #include "a68g-parser.h" #include "a68g-transput.h" // This code implements a parallel clause for Algol68G. // The parallel clause has been included for educational purposes; // this implementation is not the most efficient one. // // 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. #if defined (BUILD_PARALLEL_CLAUSE) // static pthread_mutex_t unit_sema = PTHREAD_MUTEX_INITIALIZER; void save_stacks (pthread_t); 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) {\ a68_free (SWAP (s));\ }\ SWAP (s) = (BYTE_T *) get_heap_space ((size_t) size);\ ABEND (SWAP (s) == NULL, ERROR_OUT_OF_CORE, __func__);\ }\ START (s) = start;\ BYTES (s) = size;\ COPY (SWAP (s), start, size);\ } else {\ START (s) = start;\ BYTES (s) = 0;\ if (SWAP (s) != NO_BYTE) {\ a68_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_ < A68_PAR (context_index) && (z) == -1; _k_++) {\ if (SAME_THREAD (_tid_, ID (&(A68_PAR (context)[_k_])))) {\ (z) = _k_;\ }\ }\ ABEND ((z) == -1, ERROR_INTERNAL_CONSISTENCY, __func__);\ } #define ERROR_THREAD_FAULT "thread fault" #define LOCK_THREAD {\ ABEND (pthread_mutex_lock (&A68_PAR (unit_sema)) != 0, ERROR_THREAD_FAULT, __func__);\ } #define UNLOCK_THREAD {\ ABEND (pthread_mutex_unlock (&A68_PAR (unit_sema)) != 0, ERROR_THREAD_FAULT, __func__);\ } //! @brief Does system stack grow up or down?. static inline int stack_direction (BYTE_T * lwb) { BYTE_T upb; if (&upb > lwb) { return (int) sizeof (BYTE_T); } else if (&upb < lwb) { return - (int) sizeof (BYTE_T); } else { ASSERT (A68_FALSE); return 0; // Pro forma } } //! @brief Whether we are in the main thread. BOOL_T is_main_thread (void) { return SAME_THREAD (A68_PAR (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 (&(A68_PAR (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) { A68_PAR (abend_all_threads) = A68_TRUE; A68_PAR (exit_from_threads) = A68_TRUE; A68_PAR (par_return_code) = ret; genie_abend_thread (); } //! @brief When we jump out of a parallel clause we zap all threads. void genie_abend_all_threads (NODE_T * p, jmp_buf * jump_stat, NODE_T * label) { (void) p; A68_PAR (abend_all_threads) = A68_TRUE; A68_PAR (exit_from_threads) = A68_FALSE; A68_PAR (jump_buffer) = jump_stat; A68_PAR (jump_label) = label; if (!is_main_thread ()) { genie_abend_thread (); } } //! @brief Save this thread and try to start another. void try_change_thread (NODE_T * p) { if (is_main_thread ()) { diagnostic (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. 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 (&(A68_PAR (context)[k]))) = A68_FP; CUR_PTR (&STACK (&(A68_PAR (context)[k]))) = A68_SP; // Swap out evaluation stack. p = A68_SP; q = INI_PTR (&STACK (&(A68_PAR (context)[k]))); SAVE_STACK (&(STACK (&(A68_PAR (context)[k]))), STACK_ADDRESS (q), p - q); // Swap out frame stack. p = A68_FP; q = INI_PTR (&FRAME (&(A68_PAR (context)[k]))); u = p + FRAME_SIZE (p); v = q + FRAME_SIZE (q); // Consider the embedding thread. SAVE_STACK (&(FRAME (&(A68_PAR (context)[k]))), FRAME_ADDRESS (v), u - v); } //! @brief Restore stacks of thread. void restore_stacks (pthread_t t) { if (ERROR_COUNT (&A68_JOB) > 0 || A68_PAR (abend_all_threads)) { genie_abend_thread (); } else { int k; GET_THREAD_INDEX (k, t); // Restore stack pointers. get_stack_size (); A68 (system_stack_offset) = THREAD_STACK_OFFSET (&(A68_PAR (context)[k])); A68_FP = CUR_PTR (&FRAME (&(A68_PAR (context)[k]))); A68_SP = CUR_PTR (&STACK (&(A68_PAR (context)[k]))); // Restore stacks. RESTORE_STACK (&(STACK (&(A68_PAR (context)[k])))); RESTORE_STACK (&(FRAME (&(A68_PAR (context)[k])))); } } //! @brief Check whether parallel units have terminated. void check_parallel_units (BOOL_T * active, pthread_t parent) { int k; for (k = 0; k < A68_PAR (context_index); k++) { if (parent == PARENT (&(A68_PAR (context)[k]))) { (*active) |= ACTIVE (&(A68_PAR (context)[k])); } } } //! @brief Execute one unit from a PAR clause. 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 (&(A68_PAR (context)[k])) = (BYTE_T *) (&stack_offset - stack_direction (&stack_offset) * STACK_USED (&A68_PAR (context)[k])); restore_stacks (t); p = (NODE_T *) (UNIT (&(A68_PAR (context)[k]))); EXECUTE_UNIT_TRACE (p); genie_abend_thread (); return (void *) NULL; } //! @brief Execute parallel units. 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 (A68_PAR (context_index) >= THREAD_MAX) { static char msg[BUFFER_SIZE]; snprintf (msg, SNPRINTF_SIZE, "platform supports %d parallel units", THREAD_MAX); diagnostic (A68_RUNTIME_ERROR, p, ERROR_PARALLEL_OVERFLOW, msg); exit_genie (p, A68_RUNTIME_ERROR); } // Fill out a context for this thread. u = &((A68_PAR (context)[A68_PAR (context_index)])); UNIT (u) = p; STACK_USED (u) = SYSTEM_STACK_USED; THREAD_STACK_OFFSET (u) = NO_BYTE; CUR_PTR (&STACK (u)) = A68_SP; CUR_PTR (&FRAME (u)) = A68_FP; INI_PTR (&STACK (u)) = A68_PAR (sp0); INI_PTR (&FRAME (u)) = A68_PAR (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. errno = 0; if (pthread_attr_init (&new_at) != 0) { diagnostic (A68_RUNTIME_ERROR, p, ERROR_THREAD_FAULT); exit_genie (p, A68_RUNTIME_ERROR); } if (pthread_attr_setstacksize (&new_at, (size_t) A68 (stack_size)) != 0) { diagnostic (A68_RUNTIME_ERROR, p, ERROR_THREAD_FAULT); exit_genie (p, A68_RUNTIME_ERROR); } if (pthread_attr_getstacksize (&new_at, &ss) != 0) { diagnostic (A68_RUNTIME_ERROR, p, ERROR_THREAD_FAULT); exit_genie (p, A68_RUNTIME_ERROR); } ABEND ((size_t) ss != (size_t) A68 (stack_size), ERROR_ACTION, __func__); if (pthread_create (&new_id, &new_at, start_unit, NULL) != 0) { diagnostic (A68_RUNTIME_ERROR, p, ERROR_PARALLEL_CANNOT_CREATE); exit_genie (p, A68_RUNTIME_ERROR); } PARENT (u) = parent; ID (u) = new_id; A68_PAR (context_index)++; save_stacks (new_id); } else { start_parallel_units (SUB (p), parent); } } } //! @brief Execute one unit from a PAR clause. 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 (&(A68_PAR (context)[k])) = (BYTE_T *) (&stack_offset - stack_direction (&stack_offset) * STACK_USED (&(A68_PAR (context)[k]))); restore_stacks (t); p = (NODE_T *) (UNIT (&(A68_PAR (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. 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; 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; A68_PAR (abend_all_threads) = A68_FALSE; A68_PAR (exit_from_threads) = A68_FALSE; A68_PAR (par_return_code) = 0; A68_PAR (sp0) = stack_s = A68_SP; A68_PAR (fp0) = frame_s = A68_FP; system_stack_offset_s = A68 (system_stack_offset); A68_PAR (context_index) = 0; // Set up a thread for this unit. u = &(A68_PAR (context)[A68_PAR (context_index)]); UNIT (u) = p; STACK_USED (u) = SYSTEM_STACK_USED; THREAD_STACK_OFFSET (u) = NO_BYTE; CUR_PTR (&STACK (u)) = A68_SP; CUR_PTR (&FRAME (u)) = A68_FP; INI_PTR (&STACK (u)) = A68_PAR (sp0); INI_PTR (&FRAME (u)) = A68_PAR (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. errno = 0; if (pthread_attr_init (&new_at) != 0) { diagnostic (A68_RUNTIME_ERROR, p, ERROR_THREAD_FAULT); exit_genie (p, A68_RUNTIME_ERROR); } if (pthread_attr_setstacksize (&new_at, (size_t) A68 (stack_size)) != 0) { diagnostic (A68_RUNTIME_ERROR, p, ERROR_THREAD_FAULT); exit_genie (p, A68_RUNTIME_ERROR); } if (pthread_attr_getstacksize (&new_at, &ss) != 0) { diagnostic (A68_RUNTIME_ERROR, p, ERROR_THREAD_FAULT); exit_genie (p, A68_RUNTIME_ERROR); } ABEND ((size_t) ss != (size_t) A68 (stack_size), ERROR_ACTION, __func__); if (pthread_create (&A68_PAR (parent_thread_id), &new_at, start_genie_parallel, NULL) != 0) { diagnostic (A68_RUNTIME_ERROR, p, ERROR_PARALLEL_CANNOT_CREATE); exit_genie (p, A68_RUNTIME_ERROR); } if (errno != 0) { diagnostic (A68_RUNTIME_ERROR, p, ERROR_THREAD_FAULT); exit_genie (p, A68_RUNTIME_ERROR); } PARENT (u) = A68_PAR (main_thread_id); ID (u) = A68_PAR (parent_thread_id); A68_PAR (context_index)++; save_stacks (A68_PAR (parent_thread_id)); UNLOCK_THREAD; if (pthread_join (A68_PAR (parent_thread_id), NULL) != 0) { diagnostic (A68_RUNTIME_ERROR, p, ERROR_THREAD_FAULT); exit_genie (p, A68_RUNTIME_ERROR); } // The first spawned thread has completed, now clean up. for (j = 0; j < A68_PAR (context_index); j++) { if (ACTIVE (&(A68_PAR (context)[j])) && OTHER_THREAD (ID (&(A68_PAR (context)[j])), A68_PAR (main_thread_id)) && OTHER_THREAD (ID (&(A68_PAR (context)[j])), A68_PAR (parent_thread_id))) { // If threads are zapped it is possible that some are active at this point!. if (pthread_join (ID (&(A68_PAR (context)[j])), NULL) != 0) { diagnostic (A68_RUNTIME_ERROR, p, ERROR_THREAD_FAULT); exit_genie (p, A68_RUNTIME_ERROR); } } if (SWAP (&STACK (&(A68_PAR (context)[j]))) != NO_BYTE) { a68_free (SWAP (&STACK (&(A68_PAR (context)[j])))); SWAP (&STACK (&(A68_PAR (context)[j]))) = NO_BYTE; } if (SWAP (&STACK (&(A68_PAR (context)[j]))) != NO_BYTE) { a68_free (SWAP (&STACK (&(A68_PAR (context)[j])))); SWAP (&STACK (&(A68_PAR (context)[j]))) = NO_BYTE; } } // Now every thread should have ended. A68_PAR (context_index) = 0; A68_SP = stack_s; A68_FP = frame_s; get_stack_size (); A68 (system_stack_offset) = system_stack_offset_s; // See if we ended execution in parallel clause. if (is_main_thread () && A68_PAR (exit_from_threads)) { exit_genie (p, A68_PAR (par_return_code)); } if (is_main_thread () && ERROR_COUNT (&A68_JOB) > 0) { exit_genie (p, A68_RUNTIME_ERROR); } // See if we jumped out of the parallel clause(s). if (is_main_thread () && A68_PAR (abend_all_threads)) { JUMP_TO (TABLE (TAX (A68_PAR (jump_label)))) = UNIT (TAX (A68_PAR (jump_label))); longjmp (*(A68_PAR (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); } return GPROP (p); } //! @brief OP LEVEL = (INT) SEMA void genie_level_sema_int (NODE_T * p) { A68_INT k; A68_REF s; POP_OBJECT (p, &k, A68_INT); s = heap_generator (p, M_INT, SIZE (M_INT)); *DEREF (A68_INT, &s) = k; PUSH_REF (p, s); } //! @brief OP LEVEL = (SEMA) INT void genie_level_int_sema (NODE_T * p) { A68_REF s; POP_REF (p, &s); CHECK_INIT (p, INITIALISED (&s), M_SEMA); PUSH_VALUE (p, VALUE (DEREF (A68_INT, &s)), A68_INT); } //! @brief OP UP = (SEMA) VOID void genie_up_sema (NODE_T * p) { A68_REF s; if (is_main_thread ()) { diagnostic (A68_RUNTIME_ERROR, p, ERROR_PARALLEL_OUTSIDE); exit_genie (p, A68_RUNTIME_ERROR); } POP_REF (p, &s); CHECK_INIT (p, INITIALISED (&s), M_SEMA); VALUE (DEREF (A68_INT, &s))++; } //! @brief OP DOWN = (SEMA) VOID void genie_down_sema (NODE_T * p) { A68_REF s; A68_INT *k; BOOL_T cont = A68_TRUE; if (is_main_thread ()) { diagnostic (A68_RUNTIME_ERROR, p, ERROR_PARALLEL_OUTSIDE); exit_genie (p, A68_RUNTIME_ERROR); } POP_REF (p, &s); CHECK_INIT (p, INITIALISED (&s), M_SEMA); while (cont) { k = DEREF (A68_INT, &s); if (VALUE (k) <= 0) { save_stacks (pthread_self ()); while (VALUE (k) <= 0) { if (ERROR_COUNT (&A68_JOB) > 0 || A68_PAR (abend_all_threads)) { genie_abend_thread (); } UNLOCK_THREAD; // Waiting a bit relaxes overhead. int rc = usleep (10); ASSERT (rc == 0 || errno == EINTR); 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-3.1.2/src/a68g/equivalence.c0000644000175000017500000001151714361065320014067 00000000000000//! @file equivalence.c //! @author J. Marcel van der Veer // //! @section Copyright // // This file is part of Algol68G - an Algol 68 compiler-interpreter. // Copyright 2001-2023 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" #include "a68g-postulates.h" #include "a68g-parser.h" // Routines for establishing equivalence of modes. // // After I made this mode equivalencer (in 1993), I found: // Algol Bulletin 30.3.3 C.H.A. Koster: On infinite modes, 86-89 [1969], // which essentially concurs with this test on mode equivalence I wrote. // It is elementary logic anyway: prove equivalence, assuming equivalence. //! @brief Whether packs are equivalent, same sequence of equivalence modes. 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. BOOL_T is_united_packs_equivalent (PACK_T * s, PACK_T * t) { PACK_T *p; // whether s is a subset of t .... for (p = s; p != NO_PACK; FORWARD (p)) { BOOL_T f; PACK_T *q; 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)) { BOOL_T f; PACK_T *q; 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. 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 == M_ERROR || b == M_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 (A68 (top_postulate), a, b) || is_postulated_pair (A68 (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 = A68 (top_postulate); make_postulate (&A68 (top_postulate), a, b); z = is_packs_equivalent (PACK (a), PACK (b)); free_postulate_list (A68 (top_postulate), save); A68 (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 = A68 (top_postulate); make_postulate (&A68 (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 (A68 (top_postulate), save); A68 (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. 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 = A68 (top_postulate); BOOL_T z = is_modes_equivalent (p, q); free_postulate_list (A68 (top_postulate), save); A68 (top_postulate) = save; return z; } algol68g-3.1.2/src/a68g/taxes.c0000644000175000017500000021213714361065320012713 00000000000000//! @file taxes.c //! @author J. Marcel van der Veer // //! @section Copyright // // This file is part of Algol68G - an Algol 68 compiler-interpreter. // Copyright 2001-2023 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" #include "a68g-postulates.h" #include "a68g-parser.h" #include "a68g-prelude.h" // Mode collection, equivalencing and derived modes. // Mode service routines. //! @brief Count bounds in declarer in tree. 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. 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. 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. void resolve_equivalent (MOID_T ** m) { while ((*m) != NO_MOID && EQUIVALENT ((*m)) != NO_MOID && (*m) != EQUIVALENT (*m)) { (*m) = EQUIVALENT (*m); } } //! @brief Reset moid. 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. void renumber_moids (MOID_T * p, int n) { if (p != NO_MOID) { NUMBER (p) = n; renumber_moids (NEXT (p), n + 1); } } //! @brief Register mode in the global mode table, if mode is unique. MOID_T *register_extra_mode (MOID_T ** z, MOID_T * u) { MOID_T *head = TOP_MOID (&A68_JOB); // 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) = A68 (mode_count)++; NEXT (u) = (*z); return *z = u; } //! @brief Add mode "sub" to chain "z". 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 (); if (sub == NO_MOID) { ABEND (att == REF_SYMBOL, ERROR_INTERNAL_CONSISTENCY, __func__); ABEND (att == FLEX_SYMBOL, ERROR_INTERNAL_CONSISTENCY, __func__); ABEND (att == ROW_SYMBOL, ERROR_INTERNAL_CONSISTENCY, __func__); } 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. 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. 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 Add row and its slices to chain, recursively. 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. 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. 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. 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 . 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. MOID_T *search_standard_mode (int sizety, NODE_T * indicant) { MOID_T *p = TOP_MOID (&A68_JOB); // 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. 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. 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. 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. 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. MOID_T *get_mode_from_declarer (NODE_T * p) { if (p == NO_NODE) { return NO_MOID; } else { if (IS (p, DECLARER)) { if (MOID (p) != NO_MOID) { return MOID (p); } else { return MOID (p) = get_mode_from_declarer (SUB (p)); } } else { if (IS (p, VOID_SYMBOL)) { MOID (p) = M_VOID; return MOID (p); } else if (IS (p, LONGETY)) { if (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 (A68_ERROR, p, ERROR_UNDECLARED_TAG_2, NSYMBOL (p)); } else { MOID (p) = add_mode (&TOP_MOID (&A68_JOB), INDICANT, 0, NODE (y), NO_MOID, NO_PACK); } } return MOID (p); } else if (IS_REF (p)) { MOID_T *new_one = get_mode_from_declarer (NEXT (p)); MOID (p) = add_mode (&TOP_MOID (&A68_JOB), REF_SYMBOL, 0, p, new_one, NO_PACK); return MOID (p); } else if (IS_FLEX (p)) { MOID_T *new_one = get_mode_from_declarer (NEXT (p)); MOID (p) = add_mode (&TOP_MOID (&A68_JOB), FLEX_SYMBOL, 0, p, new_one, NO_PACK); SLICE (MOID (p)) = SLICE (new_one); return MOID (p); } else if (IS (p, FORMAL_BOUNDS)) { MOID_T *new_one = get_mode_from_declarer (NEXT (p)); MOID (p) = add_row (&TOP_MOID (&A68_JOB), 1 + 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 (&A68_JOB), 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 (&A68_JOB), 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 (&A68_JOB), 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 (&A68_JOB), 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. 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 (&A68_JOB), PROC_SYMBOL, count_pack_members (u), q, n, u); } //! @brief Collect modes from operator-plan. 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 (&A68_JOB), PROC_SYMBOL, count_pack_members (u), save, new_one, u); return MOID (p); } //! @brief Collect mode from denotation. 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) = M_CHAR; } else { MOID (p) = M_ROW_CHAR; } } else if (IS (p, TRUE_SYMBOL) || IS (p, FALSE_SYMBOL)) { MOID (p) = M_BOOL; } else if (IS (p, INT_DENOTATION)) { if (sizety == 0) { MOID (p) = M_INT; } else if (sizety == 1) { MOID (p) = M_LONG_INT; } else if (sizety == 2) { MOID (p) = M_LONG_LONG_INT; } else { MOID (p) = (sizety > 0 ? M_LONG_LONG_INT : M_INT); } } else if (IS (p, REAL_DENOTATION)) { if (sizety == 0) { MOID (p) = M_REAL; } else if (sizety == 1) { MOID (p) = M_LONG_REAL; } else if (sizety == 2) { MOID (p) = M_LONG_LONG_REAL; } else { MOID (p) = (sizety > 0 ? M_LONG_LONG_REAL : M_REAL); } } else if (IS (p, BITS_DENOTATION)) { if (sizety == 0) { MOID (p) = M_BITS; } else if (sizety == 1) { MOID (p) = M_LONG_BITS; } else if (sizety == 2) { MOID (p) = M_LONG_LONG_BITS; } else { MOID (p) = (sizety > 0 ? M_LONG_LONG_BITS : M_BITS); } } else if (IS (p, LONGETY) || IS (p, SHORTETY)) { get_mode_from_denotation (NEXT (p), count_sizety (SUB (p))); MOID (p) = MOID (NEXT (p)); } else if (IS (p, EMPTY_SYMBOL)) { MOID (p) = M_VOID; } } } //! @brief Collect modes from the syntax tree. 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) = M_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 (&A68_JOB), REF_SYMBOL, 0, NO_NODE, new_one, NO_PACK); } else { MOID (q) = get_mode_from_declarer (q); } } else if (IS (q, ROUTINE_TEXT)) { MOID (q) = get_mode_from_routine_text (SUB (q)); } else if (IS (q, OPERATOR_PLAN)) { MOID (q) = get_mode_from_operator (SUB (q)); } else if (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 (&A68_JOB), REF_SYMBOL, 0, NO_NODE, new_one, NO_PACK); } } else { if (attribute == DENOTATION) { get_mode_from_denotation (q, 0); } } } if (attribute != DENOTATION) { for (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. 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 (&A68_JOB), REF_SYMBOL, 0, p, new_one, NO_PACK); } } } //! @brief Collect modes from proc variable declarations. 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. 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 == M_VOID ? video : A68_TRUE; } else if (z == M_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 == M_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_REF (z)) { 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_ROW (z)) { return is_well_formed (def, SUB (z), yin, yang, A68_FALSE); } else if (IS_FLEX (z)) { 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). 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. 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. 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. 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. 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. 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. 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. 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. 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. 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. 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_ROW (m) || IS_FLEX (m)); } } //! @brief Compute derived modes. 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_REF (z) && 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_ROW (z) && 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_FLEX (z) && DEFLEXED (SUB (z)) != NO_MOID) { DEFLEXED (z) = DEFLEXED (SUB (z)); } else if (IS_FLEX (z)) { DEFLEXED (z) = SUB (z); } else { DEFLEXED (z) = z; } } } // Derived modes for stowed modes. for (z = TOP_MOID (mod); z != NO_MOID; FORWARD (z)) { if (NAME (z) == NO_MOID && IS_REF (z)) { if (IS (SUB (z), STRUCT_SYMBOL)) { NAME (z) = make_name_struct (SUB (z), &TOP_MOID (mod)); } else if (IS_ROW (SUB (z))) { NAME (z) = make_name_row (SUB (z), &TOP_MOID (mod)); } else if (IS_FLEX (SUB (z)) && SUB_SUB (z) != NO_MOID) { NAME (z) = make_name_row (SUB_SUB (z), &TOP_MOID (mod)); } } if (MULTIPLE (z) != NO_MOID) { ; } else if (IS_REF (z)) { if (MULTIPLE (SUB (z)) != NO_MOID) { MULTIPLE (z) = make_name_struct (MULTIPLE (SUB (z)), &TOP_MOID (mod)); } } else if (IS_ROW (z)) { if (IS (SUB (z), STRUCT_SYMBOL)) { MULTIPLE (z) = make_multiple_struct (SUB (z), &TOP_MOID (mod), DIM (z)); } } } for (z = TOP_MOID (mod); z != NO_MOID; FORWARD (z)) { if (TRIM (z) == NO_MOID && IS_FLEX (z)) { TRIM (z) = SUB (z); } if (TRIM (z) == NO_MOID && IS_REF_FLEX (z)) { TRIM (z) = add_mode (&TOP_MOID (mod), REF_SYMBOL, 0, NODE (z), SUB_SUB (z), NO_PACK); } } // Fill out stuff for rows, f.i. inverse relations. for (z = TOP_MOID (mod); z != NO_MOID; FORWARD (z)) { if (IS_ROW (z) && DIM (z) > 0 && SUB (z) != NO_MOID && !DERIVATE (z)) { (void) add_row (&TOP_MOID (mod), DIM (z) + 1, SUB (z), NODE (z), A68_TRUE); } else if (IS_REF (z) && IS (SUB (z), ROW_SYMBOL) && !DERIVATE (SUB (z))) { MOID_T *x = add_row (&TOP_MOID (mod), DIM (SUB (z)) + 1, SUB_SUB (z), NODE (SUB (z)), 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_ROW (z) && SLICE (z) != NO_MOID) { ROWED (SLICE (z)) = z; } if (IS_REF (z)) { MOID_T *y = SUB (z); if (SLICE (y) != NO_MOID && IS_ROW (SLICE (y)) && NAME (z) != NO_MOID) { ROWED (NAME (z)) = z; } } } bind_modes (TOP_NODE (mod)); for (z = TOP_MOID (mod); z != NO_MOID; FORWARD (z)) { if (IS (z, INDICANT) && NODE (z) != NO_NODE) { EQUIVALENT (z) = MOID (NODE (z)); } } for (z = TOP_MOID (mod); z != NO_MOID; FORWARD (z)) { resolve_eq_members (z); } resolve_eq_tags (INDICANTS (A68_STANDENV)); resolve_eq_tags (IDENTIFIERS (A68_STANDENV)); resolve_eq_tags (OPERATORS (A68_STANDENV)); resolve_equivalent (&M_STRING); resolve_equivalent (&M_COMPLEX); resolve_equivalent (&M_COMPL); resolve_equivalent (&M_LONG_COMPLEX); resolve_equivalent (&M_LONG_COMPL); resolve_equivalent (&M_LONG_LONG_COMPLEX); resolve_equivalent (&M_LONG_LONG_COMPL); resolve_equivalent (&M_SEMA); resolve_equivalent (&M_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_FLEX (z) && SUB (z) != NO_MOID) { if (SUB_SUB (z) != NO_MOID && IS (SUB_SUB (z), STRUCT_SYMBOL)) { MULTIPLE (z) = make_flex_multiple_struct (SUB_SUB (z), &TOP_MOID (mod), DIM (SUB (z))); } } } // See what new known modes we have generated by resolving.. for (z = TOP_MOID (mod); z != STANDENV_MOID (&A68_JOB); FORWARD (z)) { MOID_T *v; for (v = NEXT (z); v != NO_MOID; FORWARD (v)) { if (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 (M_STRING != M_FLEX_ROW_CHAR, ERROR_INTERNAL_CONSISTENCY, __func__); // Find out what modes contain rows. for (z = TOP_MOID (mod); z != NO_MOID; FORWARD (z)) { HAS_ROWS (z) = is_mode_has_row (z); } // Check flexible modes. for (z = TOP_MOID (mod); z != NO_MOID; FORWARD (z)) { if (IS_FLEX (z) && !IS (SUB (z), ROW_SYMBOL)) { diagnostic (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 (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 (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 (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 (A68_ERROR, NODE (z), ERROR_SUBSET_RELATED, z, n); } } } } // Wrap up and exit. free_postulate_list (A68 (top_postulate), NO_POSTULATE); A68 (top_postulate) = NO_POSTULATE; } //! @brief Make list of all modes in the program. 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_INTERNAL_CONSISTENCY, __func__); ABEND (NEXT_NEXT (u) == NO_NODE, ERROR_INTERNAL_CONSISTENCY, __func__); ABEND (MOID (NEXT_NEXT (u)) == NO_MOID, ERROR_INTERNAL_CONSISTENCY, __func__); 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 (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 (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, __func__); } if (ERROR_COUNT (mod) != 0) { return; } compute_derived_modes (mod); init_postulates (); } // Symbol table handling, managing TAGS. //! @brief Set level for procedures. 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. 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. void tax_tags (NODE_T *); void tax_specifier_list (NODE_T *); void tax_parameter_list (NODE_T *); void tax_format_texts (NODE_T *); //! @brief Find a tag, searching symbol tables towards the root. 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 (A68_WARNING | A68_FORCE_DIAGNOSTICS, p, WARNING_TAG_NOT_PORTABLE);\ }} //! @brief Check portability of sub tree. void portcheck (NODE_T * p) { for (; p != NO_NODE; FORWARD (p)) { portcheck (SUB (p)); if (OPTION_PORTCHECK (&A68_JOB)) { 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; } else if (IS (p, ASSERTION)) { diagnostic (A68_WARNING | A68_FORCE_DIAGNOSTICS, p, WARNING_TAG_NOT_PORTABLE); } } } } //! @brief Whether routine can be "lengthety-mapped". 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, "arccosdg"); ACCEPT (z, "arccot"); ACCEPT (z, "arccotdg"); ACCEPT (z, "arcsin"); ACCEPT (z, "arcsindg"); ACCEPT (z, "arctan"); ACCEPT (z, "arctandg"); ACCEPT (z, "beta"); ACCEPT (z, "betainc"); ACCEPT (z, "cbrt"); ACCEPT (z, "cos"); ACCEPT (z, "cosdg"); ACCEPT (z, "cospi"); ACCEPT (z, "cot"); ACCEPT (z, "cot"); ACCEPT (z, "cotdg"); ACCEPT (z, "cotpi"); ACCEPT (z, "curt"); ACCEPT (z, "erf"); ACCEPT (z, "erfc"); ACCEPT (z, "exp"); ACCEPT (z, "gamma"); ACCEPT (z, "gammainc"); ACCEPT (z, "gammaincg"); ACCEPT (z, "gammaincgf"); ACCEPT (z, "ln"); ACCEPT (z, "log"); ACCEPT (z, "pi"); ACCEPT (z, "sin"); ACCEPT (z, "sindg"); ACCEPT (z, "sinpi"); ACCEPT (z, "sqrt"); ACCEPT (z, "tan"); ACCEPT (z, "tandg"); ACCEPT (z, "tanpi"); // Random generator. ACCEPT (z, "nextrandom"); ACCEPT (z, "random"); // BITS. ACCEPT (z, "bitspack"); // Enquiries. ACCEPT (z, "maxint"); ACCEPT (z, "intwidth"); ACCEPT (z, "maxreal"); ACCEPT (z, "realwidth"); ACCEPT (z, "expwidth"); ACCEPT (z, "maxbits"); ACCEPT (z, "bitswidth"); ACCEPT (z, "byteswidth"); ACCEPT (z, "smallreal"); return A68_FALSE; #undef ACCEPT } //! @brief Map "short sqrt" onto "sqrt" etcetera. 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 (&A68 (top_token), u)); w = find_tag_local (A68_STANDENV, IDENTIFIER, v); if (w != NO_TAG && is_mappable_routine (v)) { return w; } } while (CAR (u, "short")); } else if (CAR (u, "long")) { do { char *v; TAG_T *w; u = &u[strlen ("long")]; v = TEXT (add_token (&A68 (top_token), u)); w = find_tag_local (A68_STANDENV, IDENTIFIER, v); if (w != NO_TAG && is_mappable_routine (v)) { return w; } } while (CAR (u, "long")); } return NO_TAG; #undef CAR } //! @brief Bind identifier tags to the symbol table. 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); } 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 (A68_ERROR, p, ERROR_UNDECLARED_TAG); z = add_tag (TABLE (p), IDENTIFIER, p, M_ERROR, NORMAL_IDENTIFIER); MOID (p) = M_ERROR; } TAX (p) = z; if (IS (p, DEFINING_IDENTIFIER)) { NODE (z) = p; } } } } } //! @brief Bind indicant tags to the symbol table. 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. 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. 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. 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. 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. 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, M_INT, LOOP_IDENTIFIER); } } } } //! @brief Enter routine texts in the symbol table. 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. 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, M_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, M_FORMAT, FORMAT_IDENTIFIER); TAX (p) = z; USE (z) = A68_TRUE; } } } //! @brief Enter FORMAT pictures in the symbol table. 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, M_COLLITEM, FORMAT_IDENTIFIER); } } } //! @brief Enter generators in the symbol table. 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. 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. void test_firmly_related_ops_local (NODE_T * p, TAG_T * s) { if (s != NO_TAG) { PACK_T *u = PACK (MOID (s)); if (u != NO_PACK) { MOID_T *l = MOID (u); MOID_T *r = (NEXT (u) != NO_PACK ? MOID (NEXT (u)) : NO_MOID); TAG_T *t = find_firmly_related_op (TAG_TABLE (s), NSYMBOL (NODE (s)), l, r, s); if (t != NO_TAG) { if (TAG_TABLE (t) == A68_STANDENV) { diagnostic (A68_ERROR, p, ERROR_OPERATOR_RELATED, MOID (s), NSYMBOL (NODE (s)), MOID (t), NSYMBOL (NODE (t))); ABEND (A68_TRUE, ERROR_INTERNAL_CONSISTENCY, __func__); } else { diagnostic (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. 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. 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 (A68_STANDENV)); } //! @brief Whether tag has already been declared in this range. void already_declared (NODE_T * n, int a) { if (find_tag_local (TABLE (n), a, NSYMBOL (n)) != NO_TAG) { diagnostic (A68_ERROR, n, ERROR_MULTIPLE_TAG); } } //! @brief Whether tag has already been declared in this range. void already_declared_hidden (NODE_T * n, int a) { TAG_T *s; if (find_tag_local (TABLE (n), a, NSYMBOL (n)) != NO_TAG) { diagnostic (A68_ERROR, n, ERROR_MULTIPLE_TAG); } if ((s = find_tag_global (PREVIOUS (TABLE (n)), a, NSYMBOL (n))) != NO_TAG) { if (TAG_TABLE (s) == A68_STANDENV) { diagnostic (A68_WARNING, n, WARNING_HIDES_PRELUDE, MOID (s), NSYMBOL (n)); } else { diagnostic (A68_WARNING, n, WARNING_HIDES, NSYMBOL (n)); } } } //! @brief Add tag to local 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, __func__); } } return z; } else { return NO_TAG; } } //! @brief Find a tag, searching symbol tables towards the root. 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, ERROR_INTERNAL_CONSISTENCY, __func__); 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. 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. 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, ERROR_INTERNAL_CONSISTENCY, __func__); } 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. 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. 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. 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. 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. 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. 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 (A68_SYNTAX_ERROR, p, ERROR_OPERAND_NUMBER); k = 0; } if (k == 1 && strchr (NOMADS, NSYMBOL (p)[0]) != NO_TEXT) { diagnostic (A68_SYNTAX_ERROR, p, ERROR_OPERATOR_INVALID, NOMADS); } else if (k == 2 && !find_tag_global (TABLE (p), PRIO_SYMBOL, NSYMBOL (p))) { diagnostic (A68_SYNTAX_ERROR, p, ERROR_DYADIC_PRIORITY); } } //! @brief Enter operator declarations in the symbol table. 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. 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. 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. 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. 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))) = A68 (symbol_table_count)++; } reset_symbol_table_nest_count (SUB (p)); } } //! @brief Bind routines in symbol table to the 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. 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. 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". 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. 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. 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. 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. 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. 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. void unused (TAG_T * s) { for (; s != NO_TAG; FORWARD (s)) { if (LINE_NUMBER (NODE (s)) > 0 && !USE (s)) { diagnostic (A68_WARNING, NODE (s), WARNING_TAG_UNUSED, NODE (s)); } } } //! @brief Driver for traversing tree and warn for unused tags. 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. 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 (A68_ERROR, u, ERROR_UNDECLARED_TAG); } else { USE (TAX (u)) = A68_TRUE; } } else { jumps_from_procs (SUB (p)); } } } //! @brief Assign offset tags. 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, ERROR_INTERNAL_CONSISTENCY, 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. 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. 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. 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); } } } } algol68g-3.1.2/src/a68g/single-mathlib.c0000644000175000017500000004201314361065320014460 00000000000000//! @file single-mathlib.c //! @author J. Marcel van der Veer // //! @section Copyright // // This file is part of Algol68G - an Algol 68 compiler-interpreter. // Copyright 2001-2023 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" // This file contains bindings to the GNU R standalone mathematical library. #if defined (HAVE_MATHLIB) #include "a68g-genie.h" #include "a68g-prelude.h" #include //! @brief PROC (REAL) REAL r digamma void genie_R_digamma_real (NODE_T * p) { C_FUNCTION (p, digamma); } //! @brief PROC (REAL) REAL r trigamma void genie_R_trigamma_real (NODE_T * p) { C_FUNCTION (p, trigamma); } //! @brief PROC (REAL) REAL r tetragamma void genie_R_tetragamma_real (NODE_T * p) { C_FUNCTION (p, tetragamma); } //! @brief PROC (REAL) REAL r pentagamma void genie_R_pentagamma_real (NODE_T * p) { C_FUNCTION (p, pentagamma); } //! @brief PROC (REAL, REAL) REAL r psigamma void genie_R_psigamma_real (NODE_T * p) { A68 (f_entry) = p; A68_REAL *x, *s; POP_OPERAND_ADDRESSES (p, x, s, A68_REAL); errno = 0; VALUE (x) = psigamma (VALUE (x), (int) VALUE (s)); PRELUDE_ERROR (errno != 0, p, ERROR_MATH_EXCEPTION, NO_TEXT); } #define D_3(a68_fun, R_fun)\ void a68_fun (NODE_T * p)\ {\ A68 (f_entry) = p;\ A68_BOOL give_log;\ A68_REAL a, b;\ POP_OBJECT (p, &give_log, A68_BOOL);\ POP_OBJECT (p, &b, A68_REAL);\ POP_OBJECT (p, &a, A68_REAL);\ errno = 0;\ PUSH_VALUE (p, R_fun (VALUE (&a), VALUE (&b),\ (VALUE (&give_log) == A68_TRUE ? 1 : 0)), A68_REAL);\ PRELUDE_ERROR (errno != 0, p, ERROR_MATH_EXCEPTION, NO_TEXT);\ } #define D_4(a68_fun, R_fun)\ void a68_fun (NODE_T * p)\ {\ A68 (f_entry) = p;\ A68_BOOL give_log;\ A68_REAL a, b, c;\ POP_OBJECT (p, &give_log, A68_BOOL);\ POP_OBJECT (p, &c, A68_REAL);\ POP_OBJECT (p, &b, A68_REAL);\ POP_OBJECT (p, &a, A68_REAL);\ errno = 0;\ PUSH_VALUE (p, R_fun (VALUE (&a), VALUE (&b), VALUE (&c),\ (VALUE (&give_log) == A68_TRUE ? 1 : 0)), A68_REAL);\ PRELUDE_ERROR (errno != 0, p, ERROR_MATH_EXCEPTION, NO_TEXT);\ } #define D_5(a68_fun, R_fun)\ void a68_fun (NODE_T * p)\ {\ A68 (f_entry) = p;\ A68_BOOL give_log;\ A68_REAL a, b, c, d;\ POP_OBJECT (p, &give_log, A68_BOOL);\ POP_OBJECT (p, &d, A68_REAL);\ POP_OBJECT (p, &c, A68_REAL);\ POP_OBJECT (p, &b, A68_REAL);\ POP_OBJECT (p, &a, A68_REAL);\ errno = 0;\ PUSH_VALUE (p, R_fun (VALUE (&a), VALUE (&b), VALUE (&c), VALUE (&d),\ (VALUE (&give_log) == A68_TRUE ? 1 : 0)), A68_REAL);\ PRELUDE_ERROR (errno != 0, p, ERROR_MATH_EXCEPTION, NO_TEXT);\ } #define PQ_4(a68_fun, R_fun)\ void a68_fun (NODE_T * p)\ {\ A68 (f_entry) = p;\ A68_BOOL lower_tail, log_p;\ A68_REAL x, a;\ POP_OBJECT (p, &log_p, A68_BOOL);\ POP_OBJECT (p, &lower_tail, A68_BOOL);\ POP_OBJECT (p, &a, A68_REAL);\ POP_OBJECT (p, &x, A68_REAL);\ errno = 0;\ PUSH_VALUE (p, R_fun (VALUE (&x), VALUE (&a),\ (VALUE (&lower_tail) == A68_TRUE ? 1 : 0),\ (VALUE (&log_p) == A68_TRUE ? 1 : 0)), A68_REAL);\ PRELUDE_ERROR (errno != 0, p, ERROR_MATH_EXCEPTION, NO_TEXT);\ } #define PQ_5(a68_fun, R_fun)\ void a68_fun (NODE_T * p)\ {\ A68 (f_entry) = p;\ A68_BOOL lower_tail, log_p;\ A68_REAL x, a, b;\ POP_OBJECT (p, &log_p, A68_BOOL);\ POP_OBJECT (p, &lower_tail, A68_BOOL);\ POP_OBJECT (p, &b, A68_REAL);\ POP_OBJECT (p, &a, A68_REAL);\ POP_OBJECT (p, &x, A68_REAL);\ errno = 0;\ PUSH_VALUE (p, R_fun (VALUE (&x), VALUE (&a), VALUE (&b),\ (VALUE (&lower_tail) == A68_TRUE ? 1 : 0),\ (VALUE (&log_p) == A68_TRUE ? 1 : 0)), A68_REAL);\ PRELUDE_ERROR (errno != 0, p, ERROR_MATH_EXCEPTION, NO_TEXT);\ } #define PQ_6(a68_fun, R_fun)\ void a68_fun (NODE_T * p)\ {\ A68 (f_entry) = p;\ A68_BOOL lower_tail, log_p;\ A68_REAL x, a, b, c;\ POP_OBJECT (p, &log_p, A68_BOOL);\ POP_OBJECT (p, &lower_tail, A68_BOOL);\ POP_OBJECT (p, &c, A68_REAL);\ POP_OBJECT (p, &b, A68_REAL);\ POP_OBJECT (p, &a, A68_REAL);\ POP_OBJECT (p, &x, A68_REAL);\ errno = 0;\ PUSH_VALUE (p, R_fun (VALUE (&x), VALUE (&a), VALUE (&b), VALUE (&c),\ (VALUE (&lower_tail) == A68_TRUE ? 1 : 0),\ (VALUE (&log_p) == A68_TRUE ? 1 : 0)), A68_REAL);\ PRELUDE_ERROR (errno != 0, p, ERROR_MATH_EXCEPTION, NO_TEXT);\ } #define R_1(a68_fun, R_fun)\ void a68_fun (NODE_T * p)\ {\ A68 (f_entry) = p;\ A68_REAL a;\ POP_OBJECT (p, &a, A68_REAL);\ errno = 0;\ PUSH_VALUE (p, R_fun (VALUE (&a)), A68_REAL);\ PRELUDE_ERROR (errno != 0, p, ERROR_MATH_EXCEPTION, NO_TEXT);\ } #define R_2(a68_fun, R_fun)\ void a68_fun (NODE_T * p)\ {\ A68 (f_entry) = p;\ A68_REAL a, b;\ POP_OBJECT (p, &b, A68_REAL);\ POP_OBJECT (p, &a, A68_REAL);\ errno = 0;\ PUSH_VALUE (p, R_fun (VALUE (&a), VALUE (&b)), A68_REAL);\ PRELUDE_ERROR (errno != 0, p, ERROR_MATH_EXCEPTION, NO_TEXT);\ } #define R_3(a68_fun, R_fun)\ void a68_fun (NODE_T * p)\ {\ A68 (f_entry) = p;\ A68_REAL a, b, c;\ POP_OBJECT (p, &c, A68_REAL);\ POP_OBJECT (p, &b, A68_REAL);\ POP_OBJECT (p, &a, A68_REAL);\ errno = 0;\ PUSH_VALUE (p, R_fun (VALUE (&a), VALUE (&b), VALUE (&c)), A68_REAL);\ PRELUDE_ERROR (errno != 0, p, ERROR_MATH_EXCEPTION, NO_TEXT);\ } // // Distribution functions // // Chi squared //! @brief PROC dchisq = (REAL x, df, BOOL give log) REAL //! @brief PROC pchisq = (REAL x, df, BOOL lower tail, log p) REAL //! @brief PROC qchisq = (REAL p, df, BOOL lower tail, log p) REAL //! @brief PROC rchisq = (REAL df) REAL D_3 (genie_R_dchisq_real, dchisq); PQ_4 (genie_R_pchisq_real, pchisq); PQ_4 (genie_R_qchisq_real, qchisq); R_1 (genie_R_rchisq_real, rchisq); // Exponential //! @brief PROC dexp = (REAL x, scale, BOOL give log) REAL //! @brief PROC pexp = (REAL x, scale, BOOL lower tail, log p) REAL //! @brief PROC qexp = (REAL p, scale, BOOL lower tail, log p) REAL //! @brief PROC rexp = (REAL scale) REAL D_3 (genie_R_dexp_real, dexp); PQ_4 (genie_R_pexp_real, pexp); PQ_4 (genie_R_qexp_real, qexp); R_1 (genie_R_rexp_real, rexp); // Geometric //! @brief PROC dgeom = (REAL x, p, BOOL give log) REAL //! @brief PROC pgeom = (REAL x, p, BOOL lower tail, log p) REAL //! @brief PROC qgeom = (REAL p, p, BOOL lower tail, log p) REAL //! @brief PROC rgeom = (REAL p) REAL D_3 (genie_R_dgeom_real, dgeom); PQ_4 (genie_R_pgeom_real, pgeom); PQ_4 (genie_R_qgeom_real, qgeom); R_1 (genie_R_rgeom_real, rgeom); // Poisson //! @brief PROC dpois = (REAL x, lambda, BOOL give log) REAL //! @brief PROC ppois = (REAL x, lambda, BOOL lower tail, log p) REAL //! @brief PROC qpois = (REAL p, lambda, BOOL lower tail, log p) REAL //! @brief PROC rpois = (REAL lambda) REAL D_3 (genie_R_dpois_real, dpois); PQ_4 (genie_R_ppois_real, ppois); PQ_4 (genie_R_qpois_real, qpois); R_1 (genie_R_rpois_real, rpois); // Student //! @brief PROC dt = (REAL x, n, BOOL give log) REAL //! @brief PROC pt = (REAL x, n, BOOL lower tail, log p) REAL //! @brief PROC qt = (REAL p, n, BOOL lower tail, log p) REAL //! @brief PROC rt = (REAL n) REAL D_3 (genie_R_dt_real, dt); PQ_4 (genie_R_pt_real, pt); PQ_4 (genie_R_qt_real, qt); R_1 (genie_R_rt_real, rt); // Beta //! @brief PROC dbeta = (REAL x, a, b, BOOL give log) REAL //! @brief PROC pbeta = (REAL x, a, b, BOOL lower tail, log p) REAL //! @brief PROC qbeta = (REAL p, a, b, BOOL lower tail, log p) REAL //! @brief PROC rbeta = (REAL p, a, b) REAL D_4 (genie_R_dbeta_real, dbeta); PQ_5 (genie_R_pbeta_real, pbeta); PQ_5 (genie_R_qbeta_real, qbeta); R_2 (genie_R_rbeta_real, rbeta); // Binomial //! @brief PROC dbinom = (REAL x, n, p, BOOL give log) REAL //! @brief PROC pbinom = (REAL x, n, p, BOOL lower tail, log p) REAL //! @brief PROC qbinom = (REAL p, n, p, BOOL lower tail, log p) REAL //! @brief PROC rbinom = (REAL p, n, p) REAL D_4 (genie_R_dbinom_real, dbinom); PQ_5 (genie_R_pbinom_real, pbinom); PQ_5 (genie_R_qbinom_real, qbinom); R_2 (genie_R_rbinom_real, rbinom); // Chi squared, non central //! @brief PROC dnchisq = (REAL x, df, ncp, BOOL give log) REAL //! @brief PROC pnchisq = (REAL x, df, ncp, BOOL lower tail, log p) REAL //! @brief PROC qnchisq = (REAL p, df, ncp, BOOL lower tail, log p) REAL //! @brief PROC rnchisq = (REAL p, df, ncp) REAL D_4 (genie_R_dnchisq_real, dnchisq); PQ_5 (genie_R_pnchisq_real, pnchisq); PQ_5 (genie_R_qnchisq_real, qnchisq); // Cauchy //! @brief PROC dcauchy = (REAL x, location, scale, BOOL give log) REAL //! @brief PROC pcauchy = (REAL x, location, scale, BOOL lower tail, log p) REAL //! @brief PROC qcauchy = (REAL p, location, scale, BOOL lower tail, log p) REAL //! @brief PROC rcauchy = (REAL p, location, scale) REAL D_4 (genie_R_dcauchy_real, dcauchy); PQ_5 (genie_R_pcauchy_real, pcauchy); PQ_5 (genie_R_qcauchy_real, qcauchy); R_2 (genie_R_rcauchy_real, rcauchy); // F //! @brief PROC df = (REAL x, n1, n2, BOOL give log) REAL //! @brief PROC pf = (REAL x, n1, n2, BOOL lower tail, log p) REAL //! @brief PROC qf = (REAL p, n1, n2, BOOL lower tail, log p) REAL //! @brief PROC rf = (REAL p, n1, n2) REAL D_4 (genie_R_df_real, df); PQ_5 (genie_R_pf_real, pf); PQ_5 (genie_R_qf_real, qf); R_2 (genie_R_rf_real, rf); // Logistic //! @brief PROC dlogis = (REAL x, location, scale, BOOL give log) REAL //! @brief PROC plogis = (REAL x, location, scale, BOOL lower tail, log p) REAL //! @brief PROC qlogis = (REAL p, location, scale, BOOL lower tail, log p) REAL //! @brief PROC rlogis = (REAL p, location, scale) REAL D_4 (genie_R_dlogis_real, dlogis); PQ_5 (genie_R_plogis_real, plogis); PQ_5 (genie_R_qlogis_real, qlogis); R_2 (genie_R_rlogis_real, rlogis); // Log-normal //! @brief PROC dlnorm = (REAL x, logmu, logsd, BOOL give log) REAL //! @brief PROC plnorm = (REAL x, logmu, logsd, BOOL lower tail, log p) REAL //! @brief PROC qlnorm = (REAL p, logmu, logsd, BOOL lower tail, log p) REAL //! @brief PROC rlnorm = (REAL p, logmu, logsd) REAL D_4 (genie_R_dlnorm_real, dlnorm); PQ_5 (genie_R_plnorm_real, plnorm); PQ_5 (genie_R_qlnorm_real, qlnorm); R_2 (genie_R_rlnorm_real, rlnorm); // Negative binomial //! @brief PROC dnbinom = (REAL x, size, prob, BOOL give log) REAL //! @brief PROC pnbinom = (REAL x, size, prob, BOOL lower tail, log p) REAL //! @brief PROC qnbinom = (REAL p, size, prob, BOOL lower tail, log p) REAL //! @brief PROC rnbinom = (REAL p, size, prob) REAL D_4 (genie_R_dnbinom_real, dnbinom); PQ_5 (genie_R_pnbinom_real, pnbinom); PQ_5 (genie_R_qnbinom_real, qnbinom); R_2 (genie_R_rnbinom_real, rnbinom); // t, non-central //! @brief PROC dnt = (REAL x, df, delta, BOOL give log) REAL //! @brief PROC pnt = (REAL x, df, delta, BOOL lower tail, log p) REAL //! @brief PROC qnt = (REAL p, df, delta, BOOL lower tail, log p) REAL D_4 (genie_R_dnt_real, dnt); PQ_5 (genie_R_pnt_real, pnt); PQ_5 (genie_R_qnt_real, qnt); // Normal //! @brief PROC dnorm = (REAL x, mu, sigma, BOOL give log) REAL //! @brief PROC pnorm = (REAL x, mu, sigma, BOOL lower tail, log p) REAL //! @brief PROC qnorm = (REAL p, mu, sigma, BOOL lower tail, log p) REAL //! @brief PROC rnorm = (REAL p, mu, sigma) REAL D_4 (genie_R_dnorm_real, dnorm); PQ_5 (genie_R_pnorm_real, pnorm); PQ_5 (genie_R_qnorm_real, qnorm); R_2 (genie_R_rnorm_real, rnorm); // Uniform //! @brief PROC dunif = (REAL x, a, b, BOOL give log) REAL //! @brief PROC punif = (REAL x, a, b, BOOL lower tail, log p) REAL //! @brief PROC qunif = (REAL p, a, b, BOOL lower tail, log p) REAL //! @brief PROC runif = (REAL p, a, b) REAL D_4 (genie_R_dunif_real, dunif); PQ_5 (genie_R_punif_real, punif); PQ_5 (genie_R_qunif_real, qunif); R_2 (genie_R_runif_real, runif); // Weibull //! @brief PROC dweibull = (REAL x, shape, scale, BOOL give log) REAL //! @brief PROC pweibull = (REAL x, shape, scale, BOOL lower tail, log p) REAL //! @brief PROC qweibull = (REAL p, shape, scale, BOOL lower tail, log p) REAL //! @brief PROC rweibull = (REAL p, shape, scale) REAL D_4 (genie_R_dweibull_real, dweibull); PQ_5 (genie_R_pweibull_real, pweibull); PQ_5 (genie_R_qweibull_real, qweibull); R_2 (genie_R_rweibull_real, rweibull); // F, non central //! @brief PROC dnf = (REAL x, n1, n2, ncp, BOOL give log) REAL //! @brief PROC pnf = (REAL x, n1, n2, ncp, BOOL lower tail, log p) REAL //! @brief PROC qnf = (REAL p, n1, n2, ncp, BOOL lower tail, log p) REAL D_5 (genie_R_dnf_real, dnf); PQ_6 (genie_R_pnf_real, pnf); PQ_6 (genie_R_qnf_real, qnf); // Hyper geometric //! @brief PROC dhyper = (REAL x, nr, nb, n, BOOL give log) REAL //! @brief PROC phyper = (REAL x, nr, nb, n, BOOL lower tail, log p) REAL //! @brief PROC qhyper = (REAL p, nr, nb, n, BOOL lower tail, log p) REAL //! @brief PROC rhyper = (REAL x, nr, nb, n, BOOL give log) REAL D_5 (genie_R_dhyper_real, dhyper); PQ_6 (genie_R_phyper_real, phyper); PQ_6 (genie_R_qhyper_real, qhyper); R_3 (genie_R_rhyper_real, rhyper); // Tukey //! @brief PROC ptukey = (REAL x, groups, df, treatments, BOOL lower tail, log p) REAL //! @brief PROC qtukey = (REAL p, groups, df, treatments, BOOL lower tail, log p) REAL PQ_6 (genie_R_ptukey_real, ptukey); PQ_6 (genie_R_qtukey_real, qtukey); // Wilcoxon //! @brief PROC dwilcox = (REAL x, m, n, BOOL give log) REAL //! @brief PROC pwilcox = (REAL x, m, n, BOOL lower tail, log p) REAL //! @brief PROC qwilcox = (REAL p, m, n, BOOL lower tail, log p) REAL //! @brief PROC rwilcox = (REAL p, m, n) REAL void genie_R_dwilcox (NODE_T * p) { A68 (f_entry) = p; A68_BOOL give_log; A68_REAL a, b, c; extern void wilcox_free (void); POP_OBJECT (p, &give_log, A68_BOOL); POP_OBJECT (p, &c, A68_REAL); POP_OBJECT (p, &b, A68_REAL); POP_OBJECT (p, &a, A68_REAL); errno = 0; PUSH_VALUE (p, dwilcox (VALUE (&a), VALUE (&b), VALUE (&c), (VALUE (&give_log) == A68_TRUE ? 1 : 0)), A68_REAL); wilcox_free (); PRELUDE_ERROR (errno != 0, p, ERROR_MATH_EXCEPTION, NO_TEXT); } void genie_R_pwilcox (NODE_T * p) { A68 (f_entry) = p; A68_BOOL lower_tail, log_p; A68_REAL x, a, b; extern void wilcox_free (void); POP_OBJECT (p, &log_p, A68_BOOL); POP_OBJECT (p, &lower_tail, A68_BOOL); POP_OBJECT (p, &b, A68_REAL); POP_OBJECT (p, &a, A68_REAL); POP_OBJECT (p, &x, A68_REAL); errno = 0; PUSH_VALUE (p, pwilcox (VALUE (&x), VALUE (&a), VALUE (&b), (VALUE (&lower_tail) == A68_TRUE ? 1 : 0), (VALUE (&log_p) == A68_TRUE ? 1 : 0)), A68_REAL); wilcox_free (); PRELUDE_ERROR (errno != 0, p, ERROR_MATH_EXCEPTION, NO_TEXT); } void genie_R_qwilcox (NODE_T * p) { A68_BOOL lower_tail, log_p; A68_REAL x, a, b; extern void wilcox_free (void); POP_OBJECT (p, &log_p, A68_BOOL); POP_OBJECT (p, &lower_tail, A68_BOOL); POP_OBJECT (p, &b, A68_REAL); POP_OBJECT (p, &a, A68_REAL); POP_OBJECT (p, &x, A68_REAL); errno = 0; PUSH_VALUE (p, qwilcox (VALUE (&x), VALUE (&a), VALUE (&b), (VALUE (&lower_tail) == A68_TRUE ? 1 : 0), (VALUE (&log_p) == A68_TRUE ? 1 : 0)), A68_REAL); wilcox_free (); PRELUDE_ERROR (errno != 0, p, ERROR_MATH_EXCEPTION, NO_TEXT); } R_2 (genie_R_rwilcox_real, rwilcox); // Wilcoxon sign rank //! @brief PROC dsignrank = (REAL x, n, BOOL give log) REAL //! @brief PROC psignrank = (REAL x, n, BOOL lower tail, log p) REAL //! @brief PROC qsignrank = (REAL p, n, BOOL lower tail, log p) REAL //! @brief PROC rsignrank = (REAL p, n) REAL void genie_R_dsignrank (NODE_T * p) { A68_BOOL give_log; A68_REAL a, b; extern void signrank_free (void); POP_OBJECT (p, &give_log, A68_BOOL); POP_OBJECT (p, &b, A68_REAL); POP_OBJECT (p, &a, A68_REAL); errno = 0; PUSH_VALUE (p, dsignrank (VALUE (&a), VALUE (&b), (VALUE (&give_log) == A68_TRUE ? 1 : 0)), A68_REAL); signrank_free (); PRELUDE_ERROR (errno != 0, p, ERROR_MATH_EXCEPTION, NO_TEXT); } void genie_R_psignrank (NODE_T * p) { A68_BOOL lower_tail, log_p; A68_REAL x, a; extern void signrank_free (void); POP_OBJECT (p, &log_p, A68_BOOL); POP_OBJECT (p, &lower_tail, A68_BOOL); POP_OBJECT (p, &a, A68_REAL); POP_OBJECT (p, &x, A68_REAL); errno = 0; PUSH_VALUE (p, psignrank (VALUE (&x), VALUE (&a), (VALUE (&lower_tail) == A68_TRUE ? 1 : 0), (VALUE (&log_p) == A68_TRUE ? 1 : 0)), A68_REAL); signrank_free (); PRELUDE_ERROR (errno != 0, p, ERROR_MATH_EXCEPTION, NO_TEXT); } void genie_R_qsignrank (NODE_T * p) { A68_BOOL lower_tail, log_p; A68_REAL x, a; extern void signrank_free (void); POP_OBJECT (p, &log_p, A68_BOOL); POP_OBJECT (p, &lower_tail, A68_BOOL); POP_OBJECT (p, &a, A68_REAL); POP_OBJECT (p, &x, A68_REAL); errno = 0; PUSH_VALUE (p, qsignrank (VALUE (&x), VALUE (&a), (VALUE (&lower_tail) == A68_TRUE ? 1 : 0), (VALUE (&log_p) == A68_TRUE ? 1 : 0)), A68_REAL); signrank_free (); PRELUDE_ERROR (errno != 0, p, ERROR_MATH_EXCEPTION, NO_TEXT); } R_1 (genie_R_rsignrank_real, rsignrank); #endif algol68g-3.1.2/src/a68g/enquiries.c0000644000175000017500000000537514361065320013577 00000000000000//! @file enquiries.c //! @author J. Marcel van der Veer // //! @section Copyright // // This file is part of Algol68G - an Algol 68 compiler-interpreter. // Copyright 2001-2023 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" #include "a68g-genie.h" #include "a68g-prelude.h" #include "a68g-physics.h" #include "a68g-numbers.h" #include "a68g-mp.h" // 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); #if (A68_LEVEL >= 3) A68_ENV_INT (genie_bits_lengths, 2); #else A68_ENV_INT (genie_bits_lengths, 3); #endif 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_long_mp_int_width, LONG_LONG_INT_WIDTH); A68_ENV_INT (genie_real_width, REAL_WIDTH); A68_ENV_INT (genie_long_real_width, LONG_REAL_WIDTH); A68_ENV_INT (genie_long_mp_real_width, LONG_LONG_REAL_WIDTH); A68_ENV_INT (genie_exp_width, EXP_WIDTH); A68_ENV_INT (genie_long_exp_width, LONG_EXP_WIDTH); A68_ENV_INT (genie_long_mp_exp_width, LONG_LONG_EXP_WIDTH); A68_ENV_INT (genie_bits_width, BITS_WIDTH); #if (A68_LEVEL >= 3) A68_ENV_INT (genie_long_bits_width, LONG_BITS_WIDTH); #else A68_ENV_INT (genie_long_bits_width, get_mp_bits_width (M_LONG_BITS)); A68_ENV_INT (genie_long_mp_bits_width, get_mp_bits_width (M_LONG_LONG_BITS)); #endif 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_INT (genie_mp_radix, MP_RADIX); A68_ENV_INT (genie_stack_pointer, A68_SP); A68_ENV_INT (genie_system_stack_size, A68 (stack_size)); A68_ENV_REAL (genie_cputime, seconds () - A68 (cputime_0)); A68_ENV_REAL (genie_max_real, REAL_MAX); A68_ENV_REAL (genie_min_real, REAL_MIN); A68_ENV_REAL (genie_pi, CONST_PI); A68_ENV_REAL (genie_small_real, REAL_EPSILON); algol68g-3.1.2/src/a68g/double.c0000644000175000017500000016027614361065320013047 00000000000000//! @file double.c //! @author J. Marcel van der Veer // //! @section Copyright // // This file is part of Algol68G - an Algol 68 compiler-interpreter. // Copyright 2001-2023 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" #include "a68g-genie.h" #include "a68g-prelude.h" #include "a68g-transput.h" #include "a68g-mp.h" #include "a68g-double.h" #include "a68g-lib.h" #include "a68g-numbers.h" #if (A68_LEVEL >= 3) // 128-bit REAL*16 stuff. #define RADIX (65536) #define RADIX_Q (65536.0q) #define CONST_2_UP_112_Q (5192296858534827628530496329220096.0q) #define IS_ZERO(u) (HW (u) == 0 && LW (u) == 0) #define EQ(u, v) (HW (u) == HW (v) && LW (u) == LW (v)) #define GT(u, v) (HW (u) != HW (v) ? HW (u) > HW (v) : LW (u) > LW (v)) #define GE(u, v) (HW (u) != HW (v) ? HW (u) >= HW (v) : LW (u) >= LW (v)) QUAD_WORD_T double_ssub (NODE_T *, QUAD_WORD_T, QUAD_WORD_T); void m64to128 (QUAD_WORD_T * w, UNSIGNED_T u, UNSIGNED_T v) { // Knuth's 'M' algorithm. #define M (0xffffffff) #define N 32 UNSIGNED_T k, t, w1, w2, w3; UNSIGNED_T hu = u >> N, lu = u & M, hv = v >> N, lv = v & M; t = lu * lv; w3 = t & M; k = t >> N; t = hu * lv + k; w2 = t & M; w1 = t >> N; t = lu * hv + w2; k = t >> N; HW (*w) = hu * hv + w1 + k; LW (*w) = (t << N) + w3; #undef M #undef N } void m128to128 (NODE_T * p, MOID_T * m, QUAD_WORD_T * w, QUAD_WORD_T u, QUAD_WORD_T v) { // Knuth's 'M' algorithm. QUAD_WORD_T w1, w2, w3; QUAD_WORD_T k, t, h; UNSIGNED_T hu = HW (u), lu = LW (u), hv = HW (v), lv = LW (v); if (lu == 0 || lv == 0) { set_lw (t, 0); } else { m64to128 (&t, lu, lv); } set_lw (w3, LW (t)); set_lw (k, HW (t)); if (hu == 0 || lv == 0) { set_lw (t, 0); } else { m64to128 (&t, hu, lv); } add_double (p, m, t, t, k); set_lw (w2, LW (t)); set_lw (w1, HW (t)); if (lu == 0 || hv == 0) { set_lw (t, 0); } else { m64to128 (&t, lu, hv); } add_double (p, m, t, t, w2); set_lw (k, HW (t)); if (hu == 0 || hv == 0) { set_lw (h, 0); } else { m64to128 (&h, hu, hv); } add_double (p, m, h, h, w1); add_double (p, m, h, h, k); set_hw (*w, LW (t)); add_double (p, m, *w, *w, w3); PRELUDE_ERROR (MODCHK (p, m, HW (h) != 0 || LW (h) != 0), p, ERROR_MATH, M_LONG_INT) } QUAD_WORD_T double_udiv (NODE_T * p, MOID_T * m, QUAD_WORD_T n, QUAD_WORD_T d, int mode) { // A bit naive long division. int k; UNSIGNED_T carry; QUAD_WORD_T q, r; // Special cases. PRELUDE_ERROR (IS_ZERO (d), p, ERROR_DIVISION_BY_ZERO, M_LONG_INT); if (IS_ZERO (n)) { if (mode == 0) { set_lw (q, 0); return q; } else { set_lw (r, 0); return r; } } // Would n and d be random, then ~50% of the divisions is trivial. if (EQ (n, d)) { if (mode == 0) { set_lw (q, 1); return q; } else { set_lw (r, 0); return r; } } else if (GT (d, n)) { if (mode == 0) { set_lw (q, 0); return q; } else { return n; } } // Halfword divide. if (HW (n) == 0 && HW (d) == 0) { if (mode == 0) { set_lw (q, LW (n) / LW (d)); return q; } else { set_lw (r, LW (n) % LW (d)); return r; } } // We now know that n and d both have > 64 bits. // Full divide. set_lw (q, 0); set_lw (r, 0); for (k = 128; k > 0; k--) { { carry = (LW (q) & D_SIGN) ? 0x1 : 0x0; LW (q) <<= 1; HW (q) = (HW (q) << 1) | carry; } // Left-shift r { carry = (LW (r) & D_SIGN) ? 0x1 : 0x0; LW (r) <<= 1; HW (r) = (HW (r) << 1) | carry; } // r[0] = n[k] { if (HW (n) & D_SIGN) { LW (r) |= 0x1; } carry = (LW (n) & D_SIGN) ? 0x1 : 0x0; LW (n) <<= 1; HW (n) = (HW (n) << 1) | carry; } // if r >= d if (GE (r, d)) { // r = r - d sub_double (p, m, r, r, d); // q[k] = 1 LW (q) |= 0x1; } } if (mode == 0) { return q; } else { return r; } } QUAD_WORD_T double_uadd (NODE_T * p, MOID_T * m, QUAD_WORD_T u, QUAD_WORD_T v) { QUAD_WORD_T w; (void) p; add_double (p, m, w, u, v); return w; } QUAD_WORD_T double_usub (NODE_T * p, MOID_T * m, QUAD_WORD_T u, QUAD_WORD_T v) { QUAD_WORD_T w; (void) p; sub_double (p, m, w, u, v); return w; } QUAD_WORD_T double_umul (NODE_T * p, MOID_T * m, QUAD_WORD_T u, QUAD_WORD_T v) { QUAD_WORD_T w; m128to128 (p, m, &w, u, v); return w; } // Signed integer. QUAD_WORD_T double_sadd (NODE_T * p, QUAD_WORD_T u, QUAD_WORD_T v) { QUAD_WORD_T w; int neg_u = D_NEG (u), neg_v = D_NEG (v); set_lw (w, 0); if (neg_u) { u = neg_int_16 (u); } if (neg_v) { v = neg_int_16 (v); } if (!neg_u && !neg_v) { w = double_uadd (p, M_LONG_INT, u, v); PRELUDE_ERROR (D_NEG (w), p, ERROR_MATH, M_LONG_INT); } else if (neg_u && neg_v) { w = neg_int_16 (double_sadd (p, u, v)); } else if (neg_u) { w = double_ssub (p, v, u); } else if (neg_v) { w = double_ssub (p, u, v); } return w; } QUAD_WORD_T double_ssub (NODE_T * p, QUAD_WORD_T u, QUAD_WORD_T v) { QUAD_WORD_T w; int neg_u = D_NEG (u), neg_v = D_NEG (v); set_lw (w, 0); if (neg_u) { u = neg_int_16 (u); } if (neg_v) { v = neg_int_16 (v); } if (!neg_u && !neg_v) { if (D_LT (u, v)) { w = neg_int_16 (double_usub (p, M_LONG_INT, v, u)); } else { w = double_usub (p, M_LONG_INT, u, v); } } else if (neg_u && neg_v) { w = double_ssub (p, v, u); } else if (neg_u) { w = neg_int_16 (double_sadd (p, u, v)); } else if (neg_v) { w = double_sadd (p, u, v); } return w; } QUAD_WORD_T double_smul (NODE_T * p, QUAD_WORD_T u, QUAD_WORD_T v) { QUAD_WORD_T w; int neg_u = D_NEG (u), neg_v = D_NEG (v); if (neg_u) { u = neg_int_16 (u); } if (neg_v) { v = neg_int_16 (v); } w = double_umul (p, M_LONG_INT, u, v); if (neg_u != neg_v) { w = neg_int_16 (w); } return w; } QUAD_WORD_T double_sdiv (NODE_T * p, QUAD_WORD_T u, QUAD_WORD_T v, int mode) { QUAD_WORD_T w; int neg_u = D_NEG (u), neg_v = D_NEG (v); if (neg_u) { u = neg_int_16 (u); } if (neg_v) { v = neg_int_16 (v); } w = double_udiv (p, M_LONG_INT, u, v, mode); if (mode == 0 && neg_u != neg_v) { w = neg_int_16 (w); } else if (mode == 1 && D_NEG (w)) { w = double_sadd (p, w, v); } return w; } // Infinity. DOUBLE_T a68_divq (DOUBLE_T x, DOUBLE_T y) { return x / y; } DOUBLE_T a68_dposinf (void) { return a68_divq (+1.0, 0.0); } DOUBLE_T a68_dneginf (void) { return a68_divq (-1.0, 0.0); } //! @brief Sqrt (x^2 + y^2) that does not needlessly overflow. DOUBLE_T a68_double_hypot (DOUBLE_T x, DOUBLE_T y) { DOUBLE_T xabs = ABSQ (x), yabs = ABSQ (y), min, max; if (xabs < yabs) { min = xabs; max = yabs; } else { min = yabs; max = xabs; } if (min == 0.0q) { return max; } else { DOUBLE_T u = min / max; return max * sqrtq (1.0q + u * u); } } // Conversions. QUAD_WORD_T int_16_to_real_16 (NODE_T * p, QUAD_WORD_T z) { QUAD_WORD_T w, radix; DOUBLE_T weight; int neg = D_NEG (z); if (neg) { z = abs_int_16 (z); } w.f = 0.0q; set_lw (radix, RADIX); weight = 1.0q; while (!D_ZERO (z)) { QUAD_WORD_T digit; digit = double_udiv (p, M_LONG_INT, z, radix, 1); w.f = w.f + LW (digit) * weight; z = double_udiv (p, M_LONG_INT, z, radix, 0); weight = weight * RADIX_Q; } if (neg) { w.f = -w.f; } return w; } QUAD_WORD_T real_16_to_int_16 (NODE_T * p, QUAD_WORD_T z) { // This routines looks a lot like "strtol". QUAD_WORD_T sum, weight, radix; BOOL_T negative = (BOOL_T) (z.f < 0); z.f = fabsq (truncq (z.f)); if (z.f > CONST_2_UP_112_Q) { errno = EDOM; MATH_RTE (p, errno != 0, M_LONG_REAL, NO_TEXT); } set_lw (sum, 0); set_lw (weight, 1); set_lw (radix, RADIX); while (z.f > 0) { QUAD_WORD_T term, digit, quot, rest; quot.f = truncq (z.f / RADIX_Q); rest.f = z.f - quot.f * RADIX_Q; z.f = quot.f; set_lw (digit, (INT_T) (rest.f)); term = double_umul (p, M_LONG_INT, digit, weight); sum = double_uadd (p, M_LONG_INT, sum, term); if (z.f > 0.0q) { weight = double_umul (p, M_LONG_INT, weight, radix); } } if (negative) { return neg_int_16 (sum); } else { return sum; } } //! @brief Value of LONG INT denotation int string_to_int_16 (NODE_T * p, A68_LONG_INT * z, char *s) { int k, end, sign; QUAD_WORD_T weight, ten, sum; while (IS_SPACE (s[0])) { s++; } // Get the sign sign = (s[0] == '-' ? -1 : 1); if (s[0] == '+' || s[0] == '-') { s++; } end = 0; while (s[end] != '\0') { end++; } set_lw (sum, 0); set_lw (weight, 1); set_lw (ten, 10); for (k = end - 1; k >= 0; k--) { QUAD_WORD_T term; int digit = s[k] - '0'; set_lw (term, digit); term = double_umul (p, M_LONG_INT, term, weight); sum = double_uadd (p, M_LONG_INT, sum, term); weight = double_umul (p, M_LONG_INT, weight, ten); } if (sign == -1) { HW (sum) = HW (sum) | D_SIGN; } VALUE (z) = sum; STATUS (z) = INIT_MASK; return A68_TRUE; } //! @brief LONG BITS value of LONG BITS denotation QUAD_WORD_T double_strtou (NODE_T * p, char *s) { int base = 0; QUAD_WORD_T z; char *radix = NO_TEXT; errno = 0; base = (int) a68_strtou (s, &radix, 10); if (base < 2 || base > 16) { diagnostic (A68_RUNTIME_ERROR, p, ERROR_INVALID_RADIX, base); exit_genie (p, A68_RUNTIME_ERROR); } set_lw (z, 0x0); if (radix != NO_TEXT && TO_UPPER (radix[0]) == TO_UPPER (RADIX_CHAR) && errno == 0) { QUAD_WORD_T w; char *q = radix; while (q[0] != NULL_CHAR) { q++; } set_lw (w, 1); while ((--q) != radix) { int digit = char_value (q[0]); if (digit < 0 && digit >= base) { diagnostic (A68_RUNTIME_ERROR, p, ERROR_IN_DENOTATION, M_LONG_BITS); exit_genie (p, A68_RUNTIME_ERROR); } else { QUAD_WORD_T v; set_lw (v, digit); v = double_umul (p, M_LONG_INT, v, w); z = double_uadd (p, M_LONG_INT, z, v); set_lw (v, base); w = double_umul (p, M_LONG_INT, w, v); } } } else { diagnostic (A68_RUNTIME_ERROR, p, ERROR_IN_DENOTATION, M_LONG_BITS); exit_genie (p, A68_RUNTIME_ERROR); } return (z); } //! @brief OP LENG = (BITS) LONG BITS void genie_lengthen_bits_to_double_bits (NODE_T * p) { A68_BITS k; QUAD_WORD_T d; POP_OBJECT (p, &k, A68_BITS); LW (d) = VALUE (&k); HW (d) = 0; PUSH_VALUE (p, d, A68_LONG_BITS); } //! @brief OP SHORTEN = (LONG BITS) BITS void genie_shorten_double_bits_to_bits (NODE_T * p) { A68_LONG_BITS k; QUAD_WORD_T j; POP_OBJECT (p, &k, A68_LONG_BITS); j = VALUE (&k); PRELUDE_ERROR (HW (j) != 0, p, ERROR_MATH, M_BITS); PUSH_VALUE (p, LW (j), A68_BITS); } //! @brief Convert to other radix, binary up to hexadecimal. BOOL_T convert_radix_double (NODE_T * p, QUAD_WORD_T z, int radix, int width) { QUAD_WORD_T w, rad; if (radix < 2 || radix > 16) { radix = 16; } set_lw (rad, radix); reset_transput_buffer (EDIT_BUFFER); if (width > 0) { while (width > 0) { w = double_udiv (p, M_LONG_INT, z, rad, 1); plusto_transput_buffer (p, digchar (LW (w)), EDIT_BUFFER); width--; z = double_udiv (p, M_LONG_INT, z, rad, 0); } return D_ZERO (z); } else if (width == 0) { do { w = double_udiv (p, M_LONG_INT, z, rad, 1); plusto_transput_buffer (p, digchar (LW (w)), EDIT_BUFFER); z = double_udiv (p, M_LONG_INT, z, rad, 0); } while (!D_ZERO (z)); return A68_TRUE; } else { return A68_FALSE; } } //! @brief OP LENG = (LONG INT) LONG REAL void genie_widen_int_16_to_real_16 (NODE_T * p) { A68_DOUBLE *z = (A68_DOUBLE *) STACK_TOP; EXECUTE_UNIT (SUB (p)); VALUE (z) = int_16_to_real_16 (p, VALUE (z)); } //! @brief OP LENG = (REAL) LONG REAL QUAD_WORD_T dble_16 (NODE_T * p, REAL_T z) { // Quick and dirty, only works with 64-bit INT_T. BOOL_T nega = (z < 0.0); REAL_T u = fabs (z); QUAD_WORD_T w; int expo = 0; standardise (&u, 1, REAL_DIG, &expo); u *= ten_up (REAL_DIG); expo -= REAL_DIG; set_lw (w, (INT_T) u); w = int_16_to_real_16 (p, w); w.f *= ten_up_double (expo); if (nega) { w.f = -w.f; } return w; } //! @brief OP LENG = (REAL) LONG REAL void genie_lengthen_real_to_real_16 (NODE_T * p) { A68_REAL z; POP_OBJECT (p, &z, A68_REAL); PUSH_VALUE (p, dble_16 (p, VALUE (&z)), A68_LONG_REAL); } //! @brief OP SHORTEN = (LONG REAL) REAL void genie_shorten_real_16_to_real (NODE_T * p) { A68_LONG_REAL z; REAL_T w; POP_OBJECT (p, &z, A68_LONG_REAL); w = VALUE (&z).f; PUSH_VALUE (p, w, A68_REAL); } //! @brief Convert integer to multi-precison number. MP_T *int_16_to_mp (NODE_T * p, MP_T * z, QUAD_WORD_T k, int digits) { QUAD_WORD_T k2, radix; int n = 0, j, negative = D_NEG (k); if (negative) { k = neg_int_16 (k); } set_lw (radix, MP_RADIX); k2 = k; do { k2 = double_udiv (p, M_LONG_INT, k2, radix, 0); if (!D_ZERO (k2)) { n++; } } while (!D_ZERO (k2)); SET_MP_ZERO (z, digits); MP_EXPONENT (z) = (MP_T) n; for (j = 1 + n; j >= 1; j--) { QUAD_WORD_T term = double_udiv (p, M_LONG_INT, k, radix, 1); MP_DIGIT (z, j) = (MP_T) LW (term); k = double_udiv (p, M_LONG_INT, k, radix, 0); } MP_DIGIT (z, 1) = (negative ? -MP_DIGIT (z, 1) : MP_DIGIT (z, 1)); check_mp_exp (p, z); return z; } //! @brief Convert multi-precision number to integer. QUAD_WORD_T mp_to_int_16 (NODE_T * p, MP_T * z, int digits) { // This routines looks a lot like "strtol". int j, expo = (int) MP_EXPONENT (z); QUAD_WORD_T sum, weight; set_lw (sum, 0); set_lw (weight, 1); BOOL_T negative; if (expo >= digits) { diagnostic (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--) { QUAD_WORD_T term, digit, radix; set_lw (digit, (MP_INT_T) MP_DIGIT (z, j)); term = double_umul (p, M_LONG_INT, digit, weight); sum = double_uadd (p, M_LONG_INT, sum, term); set_lw (radix, MP_RADIX); weight = double_umul (p, M_LONG_INT, weight, radix); } if (negative) { return neg_int_16 (sum); } else { return sum; } } //! @brief Convert real to multi-precison number. MP_T *real_16_to_mp (NODE_T * p, MP_T * z, DOUBLE_T x, int digits) { int j, k, sign_x, sum, weight; SET_MP_ZERO (z, digits); if (x == 0.0q) { return z; } // Small integers can be done better by int_to_mp. if (ABS (x) < MP_RADIX && truncq (x) == x) { return int_to_mp (p, z, (int) truncq (x), digits); } sign_x = SIGN (x); // Scale to [0, 0.1>. DOUBLE_T a = ABS (x); INT_T expo = (int) log10q (a); a /= ten_up_double (expo); expo--; if (a >= 1.0q) { a /= 10.0q; expo++; } // Transport digits of x to the mantissa of z. sum = 0; weight = (MP_RADIX / 10); for (k = 0, j = 1; a != 0.0q && j <= digits && k < DOUBLE_DIGITS; k++) { DOUBLE_T u = a * 10.0q; DOUBLE_T v = floorq (u); a = u - v; sum += weight * (int) v; weight /= 10; if (weight < 1) { MP_DIGIT (z, j++) = (MP_T) sum; sum = 0; weight = (MP_RADIX / 10); } } // Store the last digits. if (j <= digits) { MP_DIGIT (z, j) = (MP_T) sum; } (void) align_mp (z, &expo, digits); MP_EXPONENT (z) = (MP_T) expo; MP_DIGIT (z, 1) *= sign_x; check_mp_exp (p, z); return z; } //! @brief Convert multi-precision number to real. DOUBLE_T mp_to_real_16 (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_RADIX <= (MP_T) REAL_MIN_10_EXP) { return 0; } else { int j; DOUBLE_T sum = 0, weight; weight = ten_up_double ((int) (MP_EXPONENT (z) * LOG_MP_RADIX)); for (j = 1; j <= digits && (j - 2) * LOG_MP_RADIX <= FLT128_DIG; j++) { sum += ABS (MP_DIGIT (z, j)) * weight; weight /= MP_RADIX; } CHECK_DOUBLE_REAL (p, sum); return MP_DIGIT (z, 1) >= 0 ? sum : -sum; } } DOUBLE_T inverf_real_16 (DOUBLE_T z) { if (fabsq (z) >= 1.0q) { errno = EDOM; return z; } else { // Newton-Raphson. DOUBLE_T f = sqrtq (M_PIq) / 2, g, x = z; int its = 10; x = dble (a68_inverf ((REAL_T) x)).f; do { g = x; x -= f * (erfq (x) - z) / expq (-(x * x)); } while (its-- > 0 && errno == 0 && fabsq (x - g) > (3 * FLT128_EPSILON)); return x; } } //! @brief OP LENG = (LONG REAL) LONG LONG REAL void genie_lengthen_real_16_to_mp (NODE_T * p) { int digits = DIGITS (M_LONG_LONG_REAL); A68_LONG_REAL x; POP_OBJECT (p, &x, A68_LONG_REAL); MP_T *z = nil_mp (p, digits); (void) real_16_to_mp (p, z, VALUE (&x).f, digits); MP_STATUS (z) = (MP_T) INIT_MASK; } //! @brief OP SHORTEN = (LONG LONG REAL) LONG REAL void genie_shorten_mp_to_real_16 (NODE_T * p) { MOID_T *mode = LHS_MODE (p); int digits = DIGITS (mode), size = SIZE (mode); MP_T *z; QUAD_WORD_T d; DECREMENT_STACK_POINTER (p, size); z = (MP_T *) STACK_TOP; MP_STATUS (z) = (MP_T) INIT_MASK; d.f = mp_to_real_16 (p, z, digits); PUSH_VALUE (p, d, A68_LONG_REAL); } //! @brief OP LENG = (LONG INT) LONG LONG INT void genie_lengthen_int_16_to_mp (NODE_T * p) { int digits = DIGITS (M_LONG_LONG_INT); A68_LONG_INT k; POP_OBJECT (p, &k, A68_LONG_INT); MP_T *z = nil_mp (p, digits); (void) int_16_to_mp (p, z, VALUE (&k), digits); MP_STATUS (z) = (MP_T) INIT_MASK; } //! @brief OP SHORTEN = (LONG LONG INT) LONG INT void genie_shorten_mp_to_int_16 (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_VALUE (p, mp_to_int_16 (p, z, digits), A68_LONG_INT); } //! @brief OP LENG = (INT) LONG INT void genie_lengthen_int_to_int_16 (NODE_T * p) { A68_INT k; INT_T v; QUAD_WORD_T d; POP_OBJECT (p, &k, A68_INT); v = VALUE (&k); if (v >= 0) { LW (d) = v; HW (d) = 0; } else { LW (d) = -v; HW (d) = D_SIGN; } PUSH_VALUE (p, d, A68_LONG_INT); } //! @brief OP SHORTEN = (LONG INT) INT void genie_shorten_long_int_to_int (NODE_T * p) { A68_LONG_INT k; QUAD_WORD_T j; POP_OBJECT (p, &k, A68_LONG_INT); j = VALUE (&k); PRELUDE_ERROR (HW (j) != 0 && HW (j) != D_SIGN, p, ERROR_MATH, M_INT); PRELUDE_ERROR (LW (j) & D_SIGN, p, ERROR_MATH, M_INT); if (D_NEG (j)) { PUSH_VALUE (p, -LW (j), A68_INT); } else { PUSH_VALUE (p, LW (j), A68_INT); } } // Constants. //! @brief PROC long max int = LONG INT void genie_double_max_int (NODE_T * p) { QUAD_WORD_T d; HW (d) = 0x7fffffffffffffffLL; LW (d) = 0xffffffffffffffffLL; PUSH_VALUE (p, d, A68_LONG_INT); } //! @brief PROC long max bits = LONG BITS void genie_double_max_bits (NODE_T * p) { QUAD_WORD_T d; HW (d) = 0xffffffffffffffffLL; LW (d) = 0xffffffffffffffffLL; PUSH_VALUE (p, d, A68_LONG_INT); } //! @brief LONG REAL max long real void genie_double_max_real (NODE_T * p) { QUAD_WORD_T d; d.f = FLT128_MAX; PUSH_VALUE (p, d, A68_LONG_REAL); } //! @brief LONG REAL min long real void genie_double_min_real (NODE_T * p) { QUAD_WORD_T d; d.f = FLT128_MIN; PUSH_VALUE (p, d, A68_LONG_REAL); } //! @brief LONG REAL small long real void genie_double_small_real (NODE_T * p) { QUAD_WORD_T d; d.f = FLT128_EPSILON; PUSH_VALUE (p, d, A68_LONG_REAL); } //! @brief PROC long pi = LON REAL void genie_pi_double (NODE_T * p) { QUAD_WORD_T w; w.f = M_PIq; PUSH_VALUE (p, w, A68_LONG_INT); } // MONADs and DYADs //! @brief OP SIGN = (LONG INT) INT void genie_sign_int_16 (NODE_T * p) { A68_LONG_INT k; POP_OBJECT (p, &k, A68_LONG_INT); PUSH_VALUE (p, sign_int_16 (VALUE (&k)), A68_INT); } //! @brief OP ABS = (LONG INT) LONG INT void genie_abs_int_16 (NODE_T * p) { A68_LONG_INT *k; POP_OPERAND_ADDRESS (p, k, A68_LONG_INT); VALUE (k) = abs_int_16 (VALUE (k)); } //! @brief OP ODD = (LONG INT) BOOL void genie_odd_int_16 (NODE_T * p) { A68_LONG_INT j; QUAD_WORD_T w; POP_OBJECT (p, &j, A68_LONG_INT); w = abs_int_16 (VALUE (&j)); if (LW (w) & 0x1) { PUSH_VALUE (p, A68_TRUE, A68_BOOL); } else { PUSH_VALUE (p, A68_FALSE, A68_BOOL); } } //! @brief OP - = (LONG INT) LONG INT void genie_minus_int_16 (NODE_T * p) { A68_LONG_INT *k; POP_OPERAND_ADDRESS (p, k, A68_LONG_INT); VALUE (k) = neg_int_16 (VALUE (k)); } //! @brief OP ROUND = (LONG REAL) LONG INT void genie_round_real_16 (NODE_T * p) { A68_LONG_REAL x; QUAD_WORD_T u; POP_OBJECT (p, &x, A68_LONG_REAL); u = VALUE (&x); if (u.f < 0.0q) { u.f = u.f - 0.5q; } else { u.f = u.f + 0.5q; } PUSH_VALUE (p, real_16_to_int_16 (p, u), A68_LONG_INT); } //! @brief OP ENTIER = (LONG REAL) LONG INT void genie_entier_real_16 (NODE_T * p) { A68_LONG_REAL x; QUAD_WORD_T u; POP_OBJECT (p, &x, A68_LONG_REAL); u = VALUE (&x); u.f = floorq (u.f); PUSH_VALUE (p, real_16_to_int_16 (p, u), A68_LONG_INT); } //! @brief OP + = (LONG INT, LONG INT) LONG INT void genie_add_int_16 (NODE_T * p) { A68_LONG_INT i, j; POP_OBJECT (p, &j, A68_LONG_INT); POP_OBJECT (p, &i, A68_LONG_INT); PUSH_VALUE (p, double_sadd (p, VALUE (&i), VALUE (&j)), A68_LONG_INT); } //! @brief OP - = (LONG INT, LONG INT) LONG INT void genie_sub_int_16 (NODE_T * p) { A68_LONG_INT i, j; POP_OBJECT (p, &j, A68_LONG_INT); POP_OBJECT (p, &i, A68_LONG_INT); PUSH_VALUE (p, double_ssub (p, VALUE (&i), VALUE (&j)), A68_LONG_INT); } //! @brief OP * = (LONG INT, LONG INT) LONG INT void genie_mul_int_16 (NODE_T * p) { A68_LONG_INT i, j; POP_OBJECT (p, &j, A68_LONG_INT); POP_OBJECT (p, &i, A68_LONG_INT); PUSH_VALUE (p, double_smul (p, VALUE (&i), VALUE (&j)), A68_LONG_INT); } //! @brief OP / = (LONG INT, LONG INT) LONG INT void genie_over_int_16 (NODE_T * p) { A68_LONG_INT i, j; POP_OBJECT (p, &j, A68_LONG_INT); POP_OBJECT (p, &i, A68_LONG_INT); PRELUDE_ERROR (D_ZERO (VALUE (&j)), p, ERROR_DIVISION_BY_ZERO, M_LONG_INT); PUSH_VALUE (p, double_sdiv (p, VALUE (&i), VALUE (&j), 0), A68_LONG_INT); } //! @brief OP MOD = (LONG INT, LONG INT) LONG INT void genie_mod_int_16 (NODE_T * p) { A68_LONG_INT i, j; POP_OBJECT (p, &j, A68_LONG_INT); POP_OBJECT (p, &i, A68_LONG_INT); PRELUDE_ERROR (D_ZERO (VALUE (&j)), p, ERROR_DIVISION_BY_ZERO, M_LONG_INT); PUSH_VALUE (p, double_sdiv (p, VALUE (&i), VALUE (&j), 1), A68_LONG_INT); } //! @brief OP / = (LONG INT, LONG INT) LONG REAL void genie_div_int_16 (NODE_T * p) { A68_LONG_INT i, j; QUAD_WORD_T u, v, w; POP_OBJECT (p, &j, A68_LONG_INT); POP_OBJECT (p, &i, A68_LONG_INT); PRELUDE_ERROR (D_ZERO (VALUE (&j)), p, ERROR_DIVISION_BY_ZERO, M_LONG_INT); v = int_16_to_real_16 (p, VALUE (&j)); u = int_16_to_real_16 (p, VALUE (&i)); w.f = u.f / v.f; PUSH_VALUE (p, w, A68_LONG_REAL); } //! @brief OP ** = (LONG INT, INT) INT void genie_pow_int_16_int (NODE_T * p) { A68_LONG_INT i; A68_INT j; UNSIGNED_T expo, top; QUAD_WORD_T mult, prod; POP_OBJECT (p, &j, A68_INT); PRELUDE_ERROR (VALUE (&j) < 0, p, ERROR_EXPONENT_INVALID, M_INT); top = (UNSIGNED_T) VALUE (&j); POP_OBJECT (p, &i, A68_LONG_INT); set_lw (prod, 1); mult = VALUE (&i); expo = 1; while (expo <= top) { if (expo & top) { prod = double_smul (p, prod, mult); } expo <<= 1; if (expo <= top) { mult = double_smul (p, mult, mult); } } PUSH_VALUE (p, prod, A68_LONG_INT); } //! @brief OP - = (LONG REAL) LONG REAL void genie_minus_real_16 (NODE_T * p) { A68_LONG_REAL *u; POP_OPERAND_ADDRESS (p, u, A68_LONG_REAL); VALUE (u).f = -(VALUE (u).f); } //! @brief OP ABS = (LONG REAL) LONG REAL void genie_abs_real_16 (NODE_T * p) { A68_LONG_REAL *u; POP_OPERAND_ADDRESS (p, u, A68_LONG_REAL); VALUE (u).f = fabsq (VALUE (u).f); } //! @brief OP SIGN = (LONG REAL) INT void genie_sign_real_16 (NODE_T * p) { A68_LONG_REAL u; POP_OBJECT (p, &u, A68_LONG_REAL); PUSH_VALUE (p, sign_real_16 (VALUE (&u)), A68_INT); } //! @brief OP ** = (LONG REAL, INT) INT void genie_pow_real_16_int (NODE_T * p) { A68_LONG_REAL z; A68_INT j; INT_T top; UNSIGNED_T expo; QUAD_WORD_T mult, prod; int negative; POP_OBJECT (p, &j, A68_INT); top = (UNSIGNED_T) VALUE (&j); POP_OBJECT (p, &z, A68_LONG_INT); prod.f = 1.0q; mult.f = VALUE (&z).f; if (top < 0) { top = -top; negative = A68_TRUE; } else { negative = A68_FALSE; } expo = 1; while (expo <= top) { if (expo & top) { prod.f = prod.f * mult.f; CHECK_DOUBLE_REAL (p, prod.f); } expo <<= 1; if (expo <= top) { mult.f = mult.f * mult.f; CHECK_DOUBLE_REAL (p, mult.f); } } if (negative) { prod.f = 1.0q / prod.f; } PUSH_VALUE (p, prod, A68_LONG_REAL); } //! @brief OP ** = (LONG REAL, LONG REAL) LONG REAL void genie_pow_real_16 (NODE_T * p) { A68_LONG_REAL x, y; DOUBLE_T z = 0.0q; POP_OBJECT (p, &y, A68_LONG_REAL); POP_OBJECT (p, &x, A68_LONG_REAL); errno = 0; PRELUDE_ERROR (VALUE (&x).f < 0.0q, p, ERROR_INVALID_ARGUMENT, M_LONG_REAL); if (VALUE (&x).f == 0.0q) { if (VALUE (&y).f < 0.0q) { errno = ERANGE; MATH_RTE (p, errno != 0, M_LONG_REAL, NO_TEXT); } else { z = (VALUE (&y).f == 0.0q ? 1.0q : 0.0q); } } else { z = expq (VALUE (&y).f * logq (VALUE (&x).f)); MATH_RTE (p, errno != 0, M_LONG_REAL, NO_TEXT); } PUSH_VALUE (p, dble (z), A68_LONG_REAL); } //! @brief OP + = (LONG REAL, LONG REAL) LONG REAL void genie_add_real_16 (NODE_T * p) { A68_LONG_REAL u, v; QUAD_WORD_T w; POP_OBJECT (p, &v, A68_LONG_REAL); POP_OBJECT (p, &u, A68_LONG_REAL); w.f = VALUE (&u).f + VALUE (&v).f; CHECK_DOUBLE_REAL (p, w.f); PUSH_VALUE (p, w, A68_LONG_REAL); } //! @brief OP - = (LONG REAL, LONG REAL) LONG REAL void genie_sub_real_16 (NODE_T * p) { A68_LONG_REAL u, v; QUAD_WORD_T w; POP_OBJECT (p, &v, A68_LONG_REAL); POP_OBJECT (p, &u, A68_LONG_REAL); w.f = VALUE (&u).f - VALUE (&v).f; CHECK_DOUBLE_REAL (p, w.f); PUSH_VALUE (p, w, A68_LONG_REAL); } //! @brief OP * = (LONG REAL, LONG REAL) LONG REAL void genie_mul_real_16 (NODE_T * p) { A68_LONG_REAL u, v; QUAD_WORD_T w; POP_OBJECT (p, &v, A68_LONG_REAL); POP_OBJECT (p, &u, A68_LONG_REAL); w.f = VALUE (&u).f * VALUE (&v).f; CHECK_DOUBLE_REAL (p, w.f); PUSH_VALUE (p, w, A68_LONG_REAL); } //! @brief OP / = (LONG REAL, LONG REAL) LONG REAL void genie_over_real_16 (NODE_T * p) { A68_LONG_REAL u, v; QUAD_WORD_T w; POP_OBJECT (p, &v, A68_LONG_REAL); POP_OBJECT (p, &u, A68_LONG_REAL); PRELUDE_ERROR (VALUE (&v).f == 0.0q, p, ERROR_DIVISION_BY_ZERO, M_LONG_REAL); w.f = VALUE (&u).f / VALUE (&v).f; PUSH_VALUE (p, w, A68_LONG_REAL); } //! @brief OP +:= = (REF LONG INT, LONG INT) REF LONG INT void genie_plusab_int_16 (NODE_T * p) { genie_f_and_becomes (p, M_REF_LONG_INT, genie_add_int_16); } //! @brief OP -:= = (REF LONG INT, LONG INT) REF LONG INT void genie_minusab_int_16 (NODE_T * p) { genie_f_and_becomes (p, M_REF_LONG_INT, genie_sub_int_16); } //! @brief OP *:= = (REF LONG INT, LONG INT) REF LONG INT void genie_timesab_int_16 (NODE_T * p) { genie_f_and_becomes (p, M_REF_LONG_INT, genie_mul_int_16); } //! @brief OP %:= = (REF LONG INT, LONG INT) REF LONG INT void genie_overab_int_16 (NODE_T * p) { genie_f_and_becomes (p, M_REF_LONG_INT, genie_over_int_16); } //! @brief OP %*:= = (REF LONG INT, LONG INT) REF LONG INT void genie_modab_int_16 (NODE_T * p) { genie_f_and_becomes (p, M_REF_LONG_INT, genie_mod_int_16); } //! @brief OP +:= = (REF LONG REAL, LONG REAL) REF LONG REAL void genie_plusab_real_16 (NODE_T * p) { genie_f_and_becomes (p, M_REF_LONG_REAL, genie_add_real_16); } //! @brief OP -:= = (REF LONG REAL, LONG REAL) REF LONG REAL void genie_minusab_real_16 (NODE_T * p) { genie_f_and_becomes (p, M_REF_LONG_REAL, genie_sub_real_16); } //! @brief OP *:= = (REF LONG REAL, LONG REAL) REF LONG REAL void genie_timesab_real_16 (NODE_T * p) { genie_f_and_becomes (p, M_REF_LONG_REAL, genie_mul_real_16); } //! @brief OP /:= = (REF LONG REAL, LONG REAL) REF LONG REAL void genie_divab_real_16 (NODE_T * p) { genie_f_and_becomes (p, M_REF_LONG_REAL, genie_over_real_16); } // OP (LONG INT, LONG INT) BOOL. #define A68_CMP_INT(n, OP)\ void n (NODE_T * p) {\ A68_LONG_INT i, j;\ int k;\ POP_OBJECT (p, &j, A68_LONG_INT);\ POP_OBJECT (p, &i, A68_LONG_INT);\ k = sign_int_16 (double_ssub (p, VALUE (&i), VALUE (&j)));\ PUSH_VALUE (p, (BOOL_T) (k OP 0), A68_BOOL);\ } A68_CMP_INT (genie_eq_int_16, ==) A68_CMP_INT (genie_ne_int_16, !=) A68_CMP_INT (genie_lt_int_16, <) A68_CMP_INT (genie_gt_int_16, >) A68_CMP_INT (genie_le_int_16, <=) A68_CMP_INT (genie_ge_int_16, >=) // OP (LONG REAL, LONG REAL) BOOL. #define A68_CMP_REAL(n, OP)\ void n (NODE_T * p) {\ A68_LONG_REAL i, j;\ POP_OBJECT (p, &j, A68_LONG_REAL);\ POP_OBJECT (p, &i, A68_LONG_REAL);\ PUSH_VALUE (p, (BOOL_T) (VALUE (&i).f OP VALUE (&j).f), A68_BOOL);\ } A68_CMP_REAL (genie_eq_real_16, ==) A68_CMP_REAL (genie_ne_real_16, !=) A68_CMP_REAL (genie_lt_real_16, <) A68_CMP_REAL (genie_gt_real_16, >) A68_CMP_REAL (genie_le_real_16, <=) A68_CMP_REAL (genie_ge_real_16, >=) //! @brief OP NOT = (LONG BITS) LONG BITS void genie_not_double_bits (NODE_T * p) { A68_LONG_BITS i; QUAD_WORD_T w; POP_OBJECT (p, &i, A68_LONG_BITS); HW (w) = ~HW (VALUE (&i)); LW (w) = ~LW (VALUE (&i)); PUSH_VALUE (p, w, A68_LONG_BITS); } //! @brief OP = = (LONG BITS, LONG BITS) BOOL. void genie_eq_double_bits (NODE_T * p) { A68_LONG_BITS i, j; BOOL_T u, v; POP_OBJECT (p, &j, A68_LONG_BITS); POP_OBJECT (p, &i, A68_LONG_BITS); u = HW (VALUE (&i)) == HW (VALUE (&j)); v = LW (VALUE (&i)) == LW (VALUE (&j)); PUSH_VALUE (p, (BOOL_T) (u & v ? A68_TRUE : A68_FALSE), A68_BOOL); } //! @brief OP ~= = (LONG BITS, LONG BITS) BOOL. void genie_ne_double_bits (NODE_T * p) { A68_LONG_BITS i, j; BOOL_T u, v; POP_OBJECT (p, &j, A68_LONG_BITS); // (i ~= j) == ~ (i = j) POP_OBJECT (p, &i, A68_LONG_BITS); u = HW (VALUE (&i)) == HW (VALUE (&j)); v = LW (VALUE (&i)) == LW (VALUE (&j)); PUSH_VALUE (p, (BOOL_T) (u & v ? A68_FALSE : A68_TRUE), A68_BOOL); } //! @brief OP <= = (LONG BITS, LONG BITS) BOOL void genie_le_double_bits (NODE_T * p) { A68_LONG_BITS i, j; BOOL_T u, v; POP_OBJECT (p, &j, A68_LONG_BITS); POP_OBJECT (p, &i, A68_LONG_BITS); u = (HW (VALUE (&i)) | HW (VALUE (&j))) == HW (VALUE (&j)); v = (LW (VALUE (&i)) | LW (VALUE (&j))) == LW (VALUE (&j)); PUSH_VALUE (p, (BOOL_T) (u & v ? A68_TRUE : A68_FALSE), A68_BOOL); } //! @brief OP > = (LONG BITS, LONG BITS) BOOL void genie_gt_double_bits (NODE_T * p) { A68_LONG_BITS i, j; BOOL_T u, v; POP_OBJECT (p, &j, A68_LONG_BITS); // (i > j) == ! (i <= j) POP_OBJECT (p, &i, A68_LONG_BITS); u = (HW (VALUE (&i)) | HW (VALUE (&j))) == HW (VALUE (&j)); v = (LW (VALUE (&i)) | LW (VALUE (&j))) == LW (VALUE (&j)); PUSH_VALUE (p, (BOOL_T) (u & v ? A68_FALSE : A68_TRUE), A68_BOOL); } //! @brief OP >= = (LONG BITS, LONG BITS) BOOL void genie_ge_double_bits (NODE_T * p) { A68_LONG_BITS i, j; BOOL_T u, v; POP_OBJECT (p, &j, A68_LONG_BITS); // (i >= j) == (j <= i) POP_OBJECT (p, &i, A68_LONG_BITS); u = (HW (VALUE (&i)) | HW (VALUE (&j))) == HW (VALUE (&i)); v = (LW (VALUE (&i)) | LW (VALUE (&j))) == LW (VALUE (&i)); PUSH_VALUE (p, (BOOL_T) (u & v ? A68_TRUE : A68_FALSE), A68_BOOL); } //! @brief OP < = (LONG BITS, LONG BITS) BOOL void genie_lt_double_bits (NODE_T * p) { A68_LONG_BITS i, j; BOOL_T u, v; POP_OBJECT (p, &j, A68_LONG_BITS); // (i < j) == ! (i >= j) POP_OBJECT (p, &i, A68_LONG_BITS); u = (HW (VALUE (&i)) | HW (VALUE (&j))) == HW (VALUE (&i)); v = (LW (VALUE (&i)) | LW (VALUE (&j))) == LW (VALUE (&i)); PUSH_VALUE (p, (BOOL_T) (u & v ? A68_FALSE : A68_TRUE), A68_BOOL); } //! @brief PROC long bits pack = ([] BOOL) BITS void genie_double_bits_pack (NODE_T * p) { A68_REF z; QUAD_WORD_T w; A68_ARRAY *arr; A68_TUPLE *tup; int size; POP_REF (p, &z); CHECK_REF (p, z, M_ROW_BOOL); GET_DESCRIPTOR (arr, tup, &z); size = ROW_SIZE (tup); PRELUDE_ERROR (size < 0 || size > BITS_WIDTH, p, ERROR_OUT_OF_BOUNDS, M_ROW_BOOL); set_lw (w, 0x0); if (ROW_SIZE (tup) > 0) { UNSIGNED_T bit = 0x0; int k, n = 0; BYTE_T *base = DEREF (BYTE_T, &ARRAY (arr)); for (k = UPB (tup); k >= LWB (tup); k--) { A68_BOOL *boo = (A68_BOOL *) & (base[INDEX_1_DIM (arr, tup, k)]); CHECK_INIT (p, INITIALISED (boo), M_BOOL); if (n == 0 || n == BITS_WIDTH) { bit = 0x1; } if (VALUE (boo)) { if (n > BITS_WIDTH) { LW (w) |= bit; } else { HW (w) |= bit; }; } n++; bit <<= 1; } } PUSH_VALUE (p, w, A68_LONG_BITS); } //! @brief OP AND = (LONG BITS, LONG BITS) LONG BITS void genie_and_double_bits (NODE_T * p) { A68_LONG_BITS i, j; QUAD_WORD_T w; POP_OBJECT (p, &j, A68_LONG_BITS); POP_OBJECT (p, &i, A68_LONG_BITS); HW (w) = HW (VALUE (&i)) & HW (VALUE (&j)); LW (w) = LW (VALUE (&i)) & LW (VALUE (&j)); PUSH_VALUE (p, w, A68_LONG_BITS); } //! @brief OP OR = (LONG BITS, LONG BITS) LONG BITS void genie_or_double_bits (NODE_T * p) { A68_LONG_BITS i, j; QUAD_WORD_T w; POP_OBJECT (p, &j, A68_LONG_BITS); POP_OBJECT (p, &i, A68_LONG_BITS); HW (w) = HW (VALUE (&i)) | HW (VALUE (&j)); LW (w) = LW (VALUE (&i)) | LW (VALUE (&j)); PUSH_VALUE (p, w, A68_LONG_BITS); } //! @brief OP XOR = (LONG BITS, LONG BITS) LONG BITS void genie_xor_double_bits (NODE_T * p) { A68_LONG_BITS i, j; QUAD_WORD_T w; POP_OBJECT (p, &j, A68_LONG_BITS); POP_OBJECT (p, &i, A68_LONG_BITS); HW (w) = HW (VALUE (&i)) ^ HW (VALUE (&j)); LW (w) = LW (VALUE (&i)) ^ LW (VALUE (&j)); PUSH_VALUE (p, w, A68_LONG_BITS); } //! @brief OP + = (LONG BITS, LONG BITS) LONG BITS void genie_add_double_bits (NODE_T * p) { A68_LONG_BITS i, j; QUAD_WORD_T w; POP_OBJECT (p, &j, A68_LONG_BITS); POP_OBJECT (p, &i, A68_LONG_BITS); add_double (p, M_LONG_BITS, w, VALUE (&i), VALUE (&j)); PUSH_VALUE (p, w, A68_LONG_BITS); } //! @brief OP - = (LONG BITS, LONG BITS) LONG BITS void genie_sub_double_bits (NODE_T * p) { A68_LONG_BITS i, j; QUAD_WORD_T w; POP_OBJECT (p, &j, A68_LONG_BITS); POP_OBJECT (p, &i, A68_LONG_BITS); sub_double (p, M_LONG_BITS, w, VALUE (&i), VALUE (&j)); PUSH_VALUE (p, w, A68_LONG_BITS); } //! @brief OP * = (LONG BITS, LONG BITS) LONG BITS void genie_times_double_bits (NODE_T * p) { A68_LONG_BITS i, j; QUAD_WORD_T w; POP_OBJECT (p, &j, A68_LONG_BITS); POP_OBJECT (p, &i, A68_LONG_BITS); w = double_umul (p, M_LONG_BITS, VALUE (&i), VALUE (&j)); PUSH_VALUE (p, w, A68_LONG_BITS); } //! @brief OP OVER = (LONG BITS, LONG BITS) LONG BITS void genie_over_double_bits (NODE_T * p) { A68_LONG_BITS i, j; QUAD_WORD_T w; POP_OBJECT (p, &j, A68_LONG_BITS); POP_OBJECT (p, &i, A68_LONG_BITS); w = double_udiv (p, M_LONG_BITS, VALUE (&i), VALUE (&j), 0); PUSH_VALUE (p, w, A68_LONG_BITS); } //! @brief OP MOD = (LONG BITS, LONG BITS) LONG BITS void genie_mod_double_bits (NODE_T * p) { A68_LONG_BITS i, j; QUAD_WORD_T w; POP_OBJECT (p, &j, A68_LONG_BITS); POP_OBJECT (p, &i, A68_LONG_BITS); w = double_udiv (p, M_LONG_BITS, VALUE (&i), VALUE (&j), 1); PUSH_VALUE (p, w, A68_LONG_BITS); } //! @brief OP ELEM = (INT, LONG BITS) BOOL void genie_elem_double_bits (NODE_T * p) { A68_LONG_BITS j; A68_INT i; int k, n; UNSIGNED_T mask = 0x1, *w; POP_OBJECT (p, &j, A68_LONG_BITS); POP_OBJECT (p, &i, A68_INT); k = VALUE (&i); PRELUDE_ERROR (k < 1 || k > LONG_BITS_WIDTH, p, ERROR_OUT_OF_BOUNDS, M_INT); if (k <= BITS_WIDTH) { w = &(LW (VALUE (&j))); } else { w = &(HW (VALUE (&j))); k -= BITS_WIDTH; } for (n = 0; n < (BITS_WIDTH - VALUE (&i)); n++) { mask = mask << 1; } PUSH_VALUE (p, (BOOL_T) ((*w & mask) ? A68_TRUE : A68_FALSE), A68_BOOL); } //! @brief OP SET = (INT, LONG BITS) LONG BITS void genie_set_double_bits (NODE_T * p) { A68_LONG_BITS j; A68_INT i; int k, n; UNSIGNED_T mask = 0x1, *w; POP_OBJECT (p, &j, A68_LONG_BITS); POP_OBJECT (p, &i, A68_INT); k = VALUE (&i); PRELUDE_ERROR (k < 1 || k > LONG_BITS_WIDTH, p, ERROR_OUT_OF_BOUNDS, M_INT); if (k <= BITS_WIDTH) { w = &(LW (VALUE (&j))); } else { w = &(HW (VALUE (&j))); k -= BITS_WIDTH; } for (n = 0; n < (BITS_WIDTH - VALUE (&i)); n++) { mask = mask << 1; } (*w) |= mask; PUSH_OBJECT (p, j, A68_LONG_BITS); } //! @brief OP CLEAR = (INT, LONG BITS) LONG BITS void genie_clear_double_bits (NODE_T * p) { A68_LONG_BITS j; A68_INT i; int k, n; UNSIGNED_T mask = 0x1, *w; POP_OBJECT (p, &j, A68_LONG_BITS); POP_OBJECT (p, &i, A68_INT); k = VALUE (&i); PRELUDE_ERROR (k < 1 || k > LONG_BITS_WIDTH, p, ERROR_OUT_OF_BOUNDS, M_INT); if (k <= BITS_WIDTH) { w = &(LW (VALUE (&j))); } else { w = &(HW (VALUE (&j))); k -= BITS_WIDTH; } for (n = 0; n < (BITS_WIDTH - VALUE (&i)); n++) { mask = mask << 1; } (*w) &= ~mask; PUSH_OBJECT (p, j, A68_LONG_BITS); } //! @brief OP SHL = (LONG BITS, INT) LONG BITS void genie_shl_double_bits (NODE_T * p) { A68_LONG_BITS i; A68_INT j; QUAD_WORD_T *w; int k, n; POP_OBJECT (p, &j, A68_INT); POP_OBJECT (p, &i, A68_LONG_BITS); w = &VALUE (&i); k = VALUE (&j); if (VALUE (&j) >= 0) { for (n = 0; n < k; n++) { UNSIGNED_T carry = ((LW (*w) & D_SIGN) ? 0x1 : 0x0); PRELUDE_ERROR (MODCHK (p, M_LONG_BITS, HW (*w) | D_SIGN), p, ERROR_MATH, M_LONG_BITS); HW (*w) = (HW (*w) << 1) | carry; LW (*w) = (LW (*w) << 1); } } else { k = -k; for (n = 0; n < k; n++) { UNSIGNED_T carry = ((HW (*w) & 0x1) ? D_SIGN : 0x0); HW (*w) = (HW (*w) >> 1); LW (*w) = (LW (*w) >> 1) | carry; } } PUSH_OBJECT (p, i, A68_LONG_BITS); } //! @brief OP SHR = (LONG BITS, INT) LONG BITS void genie_shr_double_bits (NODE_T * p) { A68_INT *j; POP_OPERAND_ADDRESS (p, j, A68_INT); VALUE (j) = -VALUE (j); genie_shl_double_bits (p); // Conform RR } //! @brief OP ROL = (LONG BITS, INT) LONG BITS void genie_rol_double_bits (NODE_T * p) { A68_LONG_BITS i; A68_INT j; QUAD_WORD_T *w = &VALUE (&i); int k, n; POP_OBJECT (p, &j, A68_INT); POP_OBJECT (p, &i, A68_LONG_BITS); k = VALUE (&j); if (k >= 0) { for (n = 0; n < k; n++) { UNSIGNED_T carry = ((HW (*w) & D_SIGN) ? 0x1 : 0x0); UNSIGNED_T carry_between = ((LW (*w) & D_SIGN) ? 0x1 : 0x0); HW (*w) = (HW (*w) << 1) | carry_between; LW (*w) = (LW (*w) << 1) | carry; } } else { k = -k; for (n = 0; n < k; n++) { UNSIGNED_T carry = ((LW (*w) & 0x1) ? D_SIGN : 0x0); UNSIGNED_T carry_between = ((HW (*w) & 0x1) ? D_SIGN : 0x0); HW (*w) = (HW (*w) >> 1) | carry; LW (*w) = (LW (*w) >> 1) | carry_between; } } PUSH_OBJECT (p, i, A68_LONG_BITS); } //! @brief OP ROR = (LONG BITS, INT) LONG BITS void genie_ror_double_bits (NODE_T * p) { A68_INT *j; POP_OPERAND_ADDRESS (p, j, A68_INT); VALUE (j) = -VALUE (j); genie_rol_double_bits (p); // Conform RR } //! @brief OP BIN = (LONG INT) LONG BITS void genie_bin_int_16 (NODE_T * p) { A68_LONG_INT i; POP_OBJECT (p, &i, A68_LONG_INT); // RR does not convert negative numbers if (D_NEG (VALUE (&i))) { errno = EDOM; diagnostic (A68_RUNTIME_ERROR, p, ERROR_OUT_OF_BOUNDS, M_BITS); exit_genie (p, A68_RUNTIME_ERROR); } PUSH_OBJECT (p, i, A68_LONG_BITS); } //! @brief OP +* = (LONG REAL, LONG REAL) LONG COMPLEX void genie_i_complex_32 (NODE_T * p) { (void) p; } //! @brief OP SHORTEN = (LONG COMPLEX) COMPLEX void genie_shorten_complex_32_to_complex (NODE_T * p) { A68_LONG_REAL re, im; REAL_T w; POP_OBJECT (p, &im, A68_LONG_REAL); POP_OBJECT (p, &re, A68_LONG_REAL); w = VALUE (&re).f; PUSH_VALUE (p, w, A68_REAL); w = VALUE (&im).f; PUSH_VALUE (p, w, A68_REAL); } //! @brief OP LENG = (LONG COMPLEX) LONG LONG COMPLEX void genie_lengthen_complex_32_to_long_mp_complex (NODE_T * p) { int digits = DIGITS (M_LONG_LONG_REAL); A68_LONG_REAL re, im; POP_OBJECT (p, &im, A68_LONG_REAL); POP_OBJECT (p, &re, A68_LONG_REAL); MP_T *z = nil_mp (p, digits); (void) real_16_to_mp (p, z, VALUE (&re).f, digits); MP_STATUS (z) = (MP_T) INIT_MASK; z = nil_mp (p, digits); (void) real_16_to_mp (p, z, VALUE (&im).f, digits); MP_STATUS (z) = (MP_T) INIT_MASK; } //! @brief OP +* = (LONG INT, LONG INT) LONG COMPLEX void genie_i_int_complex_32 (NODE_T * p) { A68_LONG_INT re, im; POP_OBJECT (p, &im, A68_LONG_INT); POP_OBJECT (p, &re, A68_LONG_INT); PUSH_VALUE (p, int_16_to_real_16 (p, VALUE (&re)), A68_LONG_REAL); PUSH_VALUE (p, int_16_to_real_16 (p, VALUE (&im)), A68_LONG_REAL); } //! @brief OP RE = (LONG COMPLEX) LONG REAL void genie_re_complex_32 (NODE_T * p) { DECREMENT_STACK_POINTER (p, SIZE (M_LONG_REAL)); } //! @brief OP IM = (LONG COMPLEX) LONG REAL void genie_im_complex_32 (NODE_T * p) { A68_LONG_REAL re, im; POP_OBJECT (p, &im, A68_LONG_REAL); POP_OBJECT (p, &re, A68_LONG_REAL); PUSH_OBJECT (p, im, A68_LONG_REAL); } //! @brief OP - = (LONG COMPLEX) LONG COMPLEX void genie_minus_complex_32 (NODE_T * p) { A68_LONG_REAL re, im; POP_OBJECT (p, &im, A68_LONG_REAL); POP_OBJECT (p, &re, A68_LONG_REAL); VALUE (&re).f = -VALUE (&re).f; VALUE (&im).f = -VALUE (&im).f; PUSH_OBJECT (p, im, A68_LONG_REAL); PUSH_OBJECT (p, re, A68_LONG_REAL); } //! @brief OP ABS = (LONG COMPLEX) LONG REAL void genie_abs_complex_32 (NODE_T * p) { A68_LONG_REAL re, im; POP_LONG_COMPLEX (p, &re, &im); PUSH_VALUE (p, dble (a68_double_hypot (VALUE (&re).f, VALUE (&im).f)), A68_LONG_REAL); } //! @brief OP ARG = (LONG COMPLEX) LONG REAL void genie_arg_complex_32 (NODE_T * p) { A68_LONG_REAL re, im; POP_LONG_COMPLEX (p, &re, &im); PRELUDE_ERROR (VALUE (&re).f == 0.0q && VALUE (&im).f == 0.0q, p, ERROR_INVALID_ARGUMENT, M_LONG_COMPLEX); PUSH_VALUE (p, dble (atan2q (VALUE (&im).f, VALUE (&re).f)), A68_LONG_REAL); } //! @brief OP CONJ = (LONG COMPLEX) LONG COMPLEX void genie_conj_complex_32 (NODE_T * p) { A68_LONG_REAL im; POP_OBJECT (p, &im, A68_LONG_REAL); VALUE (&im).f = -VALUE (&im).f; PUSH_OBJECT (p, im, A68_LONG_REAL); } //! @brief OP + = (COMPLEX, COMPLEX) COMPLEX void genie_add_complex_32 (NODE_T * p) { A68_LONG_REAL re_x, im_x, re_y, im_y; POP_LONG_COMPLEX (p, &re_y, &im_y); POP_LONG_COMPLEX (p, &re_x, &im_x); VALUE (&re_x).f += VALUE (&re_y).f; VALUE (&im_x).f += VALUE (&im_y).f; CHECK_DOUBLE_COMPLEX (p, VALUE (&im_x).f, VALUE (&im_y).f); PUSH_OBJECT (p, re_x, A68_LONG_REAL); PUSH_OBJECT (p, im_x, A68_LONG_REAL); } //! @brief OP - = (COMPLEX, COMPLEX) COMPLEX void genie_sub_complex_32 (NODE_T * p) { A68_LONG_REAL re_x, im_x, re_y, im_y; POP_LONG_COMPLEX (p, &re_y, &im_y); POP_LONG_COMPLEX (p, &re_x, &im_x); VALUE (&re_x).f -= VALUE (&re_y).f; VALUE (&im_x).f -= VALUE (&im_y).f; CHECK_DOUBLE_COMPLEX (p, VALUE (&im_x).f, VALUE (&im_y).f); PUSH_OBJECT (p, re_x, A68_LONG_REAL); PUSH_OBJECT (p, im_x, A68_LONG_REAL); } //! @brief OP * = (COMPLEX, COMPLEX) COMPLEX void genie_mul_complex_32 (NODE_T * p) { A68_LONG_REAL re_x, im_x, re_y, im_y; DOUBLE_T re, im; POP_LONG_COMPLEX (p, &re_y, &im_y); POP_LONG_COMPLEX (p, &re_x, &im_x); re = VALUE (&re_x).f * VALUE (&re_y).f - VALUE (&im_x).f * VALUE (&im_y).f; im = VALUE (&im_x).f * VALUE (&re_y).f + VALUE (&re_x).f * VALUE (&im_y).f; CHECK_DOUBLE_COMPLEX (p, VALUE (&im_x).f, VALUE (&im_y).f); PUSH_VALUE (p, dble (re), A68_LONG_REAL); PUSH_VALUE (p, dble (im), A68_LONG_REAL); } //! @brief OP / = (COMPLEX, COMPLEX) COMPLEX void genie_div_complex_32 (NODE_T * p) { A68_LONG_REAL re_x, im_x, re_y, im_y; DOUBLE_T re = 0.0, im = 0.0; POP_LONG_COMPLEX (p, &re_y, &im_y); POP_LONG_COMPLEX (p, &re_x, &im_x); PRELUDE_ERROR (VALUE (&re_y).f == 0.0q && VALUE (&im_y).f == 0.0q, p, ERROR_DIVISION_BY_ZERO, M_LONG_COMPLEX); if (ABSQ (VALUE (&re_y).f) >= ABSQ (VALUE (&im_y).f)) { DOUBLE_T r = VALUE (&im_y).f / VALUE (&re_y).f, den = VALUE (&re_y).f + r * VALUE (&im_y).f; re = (VALUE (&re_x).f + r * VALUE (&im_x).f) / den; im = (VALUE (&im_x).f - r * VALUE (&re_x).f) / den; } else { DOUBLE_T r = VALUE (&re_y).f / VALUE (&im_y).f, den = VALUE (&im_y).f + r * VALUE (&re_y).f; re = (VALUE (&re_x).f * r + VALUE (&im_x).f) / den; im = (VALUE (&im_x).f * r - VALUE (&re_x).f) / den; } PUSH_VALUE (p, dble (re), A68_LONG_REAL); PUSH_VALUE (p, dble (im), A68_LONG_REAL); } //! @brief OP ** = (LONG COMPLEX, INT) LONG COMPLEX void genie_pow_complex_32_int (NODE_T * p) { A68_LONG_REAL re_x, im_x; DOUBLE_T re_y, im_y, re_z, im_z; A68_INT j; INT_T expo; BOOL_T negative; POP_OBJECT (p, &j, A68_INT); POP_LONG_COMPLEX (p, &re_x, &im_x); re_z = 1.0q; im_z = 0.0q; re_y = VALUE (&re_x).f; im_y = VALUE (&im_x).f; expo = 1; negative = (BOOL_T) (VALUE (&j) < 0); if (negative) { VALUE (&j) = -VALUE (&j); } while ((UNSIGNED_T) expo <= (UNSIGNED_T) (VALUE (&j))) { DOUBLE_T z; if (expo & VALUE (&j)) { z = re_z * re_y - im_z * im_y; im_z = re_z * im_y + im_z * re_y; re_z = z; } z = re_y * re_y - im_y * im_y; im_y = im_y * re_y + re_y * im_y; re_y = z; CHECK_DOUBLE_COMPLEX (p, re_y, im_y); CHECK_DOUBLE_COMPLEX (p, re_z, im_z); expo <<= 1; } if (negative) { PUSH_VALUE (p, dble (1.0q), A68_LONG_REAL); PUSH_VALUE (p, dble (0.0q), A68_LONG_REAL); PUSH_VALUE (p, dble (re_z), A68_LONG_REAL); PUSH_VALUE (p, dble (im_z), A68_LONG_REAL); genie_div_complex_32 (p); } else { PUSH_VALUE (p, dble (re_z), A68_LONG_REAL); PUSH_VALUE (p, dble (im_z), A68_LONG_REAL); } } //! @brief OP = = (COMPLEX, COMPLEX) BOOL void genie_eq_complex_32 (NODE_T * p) { A68_LONG_REAL re_x, im_x, re_y, im_y; POP_LONG_COMPLEX (p, &re_y, &im_y); POP_LONG_COMPLEX (p, &re_x, &im_x); PUSH_VALUE (p, (BOOL_T) ((VALUE (&re_x).f == VALUE (&re_y).f) && (VALUE (&im_x).f == VALUE (&im_y).f)), A68_BOOL); } //! @brief OP /= = (COMPLEX, COMPLEX) BOOL void genie_ne_complex_32 (NODE_T * p) { A68_LONG_REAL re_x, im_x, re_y, im_y; POP_LONG_COMPLEX (p, &re_y, &im_y); POP_LONG_COMPLEX (p, &re_x, &im_x); PUSH_VALUE (p, (BOOL_T) ! ((VALUE (&re_x).f == VALUE (&re_y).f) && (VALUE (&im_x).f == VALUE (&im_y).f)), A68_BOOL); } //! @brief OP +:= = (REF COMPLEX, COMPLEX) REF COMPLEX void genie_plusab_complex_32 (NODE_T * p) { genie_f_and_becomes (p, M_REF_LONG_COMPLEX, genie_add_complex_32); } //! @brief OP -:= = (REF COMPLEX, COMPLEX) REF COMPLEX void genie_minusab_complex_32 (NODE_T * p) { genie_f_and_becomes (p, M_REF_LONG_COMPLEX, genie_sub_complex_32); } //! @brief OP *:= = (REF COMPLEX, COMPLEX) REF COMPLEX void genie_timesab_complex_32 (NODE_T * p) { genie_f_and_becomes (p, M_REF_LONG_COMPLEX, genie_mul_complex_32); } //! @brief OP /:= = (REF COMPLEX, COMPLEX) REF COMPLEX void genie_divab_complex_32 (NODE_T * p) { genie_f_and_becomes (p, M_REF_LONG_COMPLEX, genie_div_complex_32); } //! @brief OP LENG = (COMPLEX) LONG COMPLEX void genie_lengthen_complex_to_complex_32 (NODE_T * p) { A68_REAL i; POP_OBJECT (p, &i, A68_REAL); genie_lengthen_real_to_real_16 (p); PUSH_OBJECT (p, i, A68_REAL); genie_lengthen_real_to_real_16 (p); } // Functions #define CD_FUNCTION(name, fun)\ void name (NODE_T * p) {\ A68_LONG_REAL *x;\ POP_OPERAND_ADDRESS (p, x, A68_LONG_REAL);\ errno=0;\ VALUE (x).f = fun (VALUE (x).f);\ MATH_RTE (p, errno != 0, M_LONG_REAL, NO_TEXT);\ } CD_FUNCTION (genie_acos_real_16, acosq); CD_FUNCTION (genie_acosh_real_16, acoshq); CD_FUNCTION (genie_asinh_real_16, asinhq); CD_FUNCTION (genie_atanh_real_16, atanhq); CD_FUNCTION (genie_asin_real_16, asinq); CD_FUNCTION (genie_atan_real_16, atanq); CD_FUNCTION (genie_cosh_real_16, coshq); CD_FUNCTION (genie_cos_real_16, cosq); CD_FUNCTION (genie_curt_real_16, cbrtq); CD_FUNCTION (genie_exp_real_16, expq); CD_FUNCTION (genie_ln_real_16, logq); CD_FUNCTION (genie_log_real_16, log10q); CD_FUNCTION (genie_sinh_real_16, sinhq); CD_FUNCTION (genie_sin_real_16, sinq); CD_FUNCTION (genie_sqrt_real_16, sqrtq); CD_FUNCTION (genie_tanh_real_16, tanhq); CD_FUNCTION (genie_tan_real_16, tanq); CD_FUNCTION (genie_erf_real_16, erfq); CD_FUNCTION (genie_erfc_real_16, erfcq); CD_FUNCTION (genie_lngamma_real_16, lgammaq); CD_FUNCTION (genie_gamma_real_16, tgammaq); CD_FUNCTION (genie_csc_real_16, a68_csc_16); CD_FUNCTION (genie_acsc_real_16, a68_acsc_16); CD_FUNCTION (genie_sec_real_16, a68_sec_16); CD_FUNCTION (genie_asec_real_16, a68_asec_16); CD_FUNCTION (genie_cot_real_16, a68_cot_16); CD_FUNCTION (genie_acot_real_16, a68_acot_16); CD_FUNCTION (genie_sindg_real_16, a68_sindg_16); CD_FUNCTION (genie_cosdg_real_16, a68_cosdg_16); CD_FUNCTION (genie_tandg_real_16, a68_tandg_16); CD_FUNCTION (genie_asindg_real_16, a68_asindg_16); CD_FUNCTION (genie_acosdg_real_16, a68_acosdg_16); CD_FUNCTION (genie_atandg_real_16, a68_atandg_16); CD_FUNCTION (genie_cotdg_real_16, a68_cotdg_16); CD_FUNCTION (genie_acotdg_real_16, a68_acotdg_16); CD_FUNCTION (genie_sinpi_real_16, a68_sinpi_16); CD_FUNCTION (genie_cospi_real_16, a68_cospi_16); CD_FUNCTION (genie_tanpi_real_16, a68_tanpi_16); CD_FUNCTION (genie_cotpi_real_16, a68_cotpi_16); //! @brief PROC long arctan2 = (LONG REAL) LONG REAL void genie_atan2_real_16 (NODE_T * p) { A68_LONG_REAL x, y; POP_OBJECT (p, &y, A68_LONG_REAL); POP_OBJECT (p, &x, A68_LONG_REAL); errno = 0; PRELUDE_ERROR (VALUE (&x).f == 0.0q && VALUE (&y).f == 0.0q, p, ERROR_INVALID_ARGUMENT, M_LONG_REAL); VALUE (&x).f = a68_atan2 (VALUE (&y).f, VALUE (&x).f); PRELUDE_ERROR (errno != 0, p, ERROR_MATH_EXCEPTION, NO_TEXT); PUSH_OBJECT (p, x, A68_LONG_REAL); } //! @brief PROC long arctan2dg = (LONG REAL) LONG REAL void genie_atan2dg_real_16 (NODE_T * p) { A68_LONG_REAL x, y; POP_OBJECT (p, &y, A68_LONG_REAL); POP_OBJECT (p, &x, A68_LONG_REAL); errno = 0; PRELUDE_ERROR (VALUE (&x).f == 0.0q && VALUE (&y).f == 0.0q, p, ERROR_INVALID_ARGUMENT, M_LONG_REAL); VALUE (&x).f = CONST_180_OVER_PI_Q * a68_atan2 (VALUE (&y).f, VALUE (&x).f); PRELUDE_ERROR (errno != 0, p, ERROR_MATH_EXCEPTION, NO_TEXT); PUSH_OBJECT (p, x, A68_LONG_REAL); } //! @brief PROC (LONG REAL) LONG REAL inverf void genie_inverf_real_16 (NODE_T * _p_) { A68_LONG_REAL x; DOUBLE_T y, z; A68 (f_entry) = _p_; POP_OBJECT (_p_, &x, A68_LONG_REAL); errno = 0; y = VALUE (&x).f; z = inverf_real_16 (y); MATH_RTE (_p_, errno != 0, M_LONG_REAL, NO_TEXT); CHECK_DOUBLE_REAL (_p_, z); PUSH_VALUE (_p_, dble (z), A68_LONG_REAL); } //! @brief PROC (LONG REAL) LONG REAL inverfc void genie_inverfc_real_16 (NODE_T * p) { A68_LONG_REAL *u; POP_OPERAND_ADDRESS (p, u, A68_LONG_REAL); VALUE (u).f = 1.0q - (VALUE (u).f); genie_inverf_real_16 (p); } #define _re_ (VALUE (&re).f) #define _im_ (VALUE (&im).f) #define CD_C_FUNCTION(p, g)\ A68_LONG_REAL re, im;\ DOUBLE_COMPLEX_T z;\ POP_OBJECT (p, &im, A68_LONG_REAL);\ POP_OBJECT (p, &re, A68_LONG_REAL);\ errno = 0;\ z = VALUE (&re).f + VALUE (&im).f * _Complex_I;\ z = g (z);\ PUSH_VALUE (p, dble ((DOUBLE_T) crealq (z)), A68_LONG_REAL);\ PUSH_VALUE (p, dble ((DOUBLE_T) cimagq (z)), A68_LONG_REAL);\ MATH_RTE (p, errno != 0, M_COMPLEX, NO_TEXT); //! @brief PROC long csqrt = (LONG COMPLEX) LONG COMPLEX void genie_sqrt_complex_32 (NODE_T * p) { CD_C_FUNCTION (p, csqrtq); } //! @brief PROC long csin = (LONG COMPLEX) LONG COMPLEX void genie_sin_complex_32 (NODE_T * p) { CD_C_FUNCTION (p, csinq); } //! @brief PROC long ccos = (LONG COMPLEX) LONG COMPLEX void genie_cos_complex_32 (NODE_T * p) { CD_C_FUNCTION (p, ccosq); } //! @brief PROC long ctan = (LONG COMPLEX) LONG COMPLEX void genie_tan_complex_32 (NODE_T * p) { CD_C_FUNCTION (p, ctanq); } //! @brief PROC long casin = (LONG COMPLEX) LONG COMPLEX void genie_asin_complex_32 (NODE_T * p) { CD_C_FUNCTION (p, casinq); } //! @brief PROC long cacos = (LONG COMPLEX) LONG COMPLEX void genie_acos_complex_32 (NODE_T * p) { CD_C_FUNCTION (p, cacosq); } //! @brief PROC long catan = (LONG COMPLEX) LONG COMPLEX void genie_atan_complex_32 (NODE_T * p) { CD_C_FUNCTION (p, catanq); } //! @brief PROC long cexp = (LONG COMPLEX) LONG COMPLEX void genie_exp_complex_32 (NODE_T * p) { CD_C_FUNCTION (p, cexpq); } //! @brief PROC long cln = (LONG COMPLEX) LONG COMPLEX void genie_ln_complex_32 (NODE_T * p) { CD_C_FUNCTION (p, clogq); } //! @brief PROC long csinh = (LONG COMPLEX) LONG COMPLEX void genie_sinh_complex_32 (NODE_T * p) { CD_C_FUNCTION (p, csinhq); } //! @brief PROC long ccosh = (LONG COMPLEX) LONG COMPLEX void genie_cosh_complex_32 (NODE_T * p) { CD_C_FUNCTION (p, ccoshq); } //! @brief PROC long ctanh = (LONG COMPLEX) LONG COMPLEX void genie_tanh_complex_32 (NODE_T * p) { CD_C_FUNCTION (p, ctanhq); } //! @brief PROC long casinh = (LONG COMPLEX) LONG COMPLEX void genie_asinh_complex_32 (NODE_T * p) { CD_C_FUNCTION (p, casinhq); } //! @brief PROC long cacosh = (LONG COMPLEX) LONG COMPLEX void genie_acosh_complex_32 (NODE_T * p) { CD_C_FUNCTION (p, cacoshq); } //! @brief PROC long catanh = (LONG COMPLEX) LONG COMPLEX void genie_atanh_complex_32 (NODE_T * p) { CD_C_FUNCTION (p, catanhq); } #undef _re_ #undef _im_ //! @brief PROC next long random = LONG REAL void genie_next_random_real_16 (NODE_T * p) { // This is 'real width' digits only. genie_next_random (p); genie_lengthen_real_to_real_16 (p); } #define CALL(g, x, y) {\ ADDR_T pop_sp = A68_SP;\ A68_LONG_REAL *z = (A68_LONG_REAL *) STACK_TOP;\ QUAD_WORD_T _w_;\ _w_.f = (x);\ PUSH_VALUE (_p_, _w_, A68_LONG_REAL);\ genie_call_procedure (_p_, M_PROC_LONG_REAL_LONG_REAL, M_PROC_LONG_REAL_LONG_REAL, M_PROC_LONG_REAL_LONG_REAL, &(g), pop_sp, pop_fp);\ (y) = VALUE (z).f;\ A68_SP = pop_sp;\ } //! @brief Transform string into real-16. DOUBLE_T a68_strtoq (char *s, char **end) { int i, dot = -1, pos = 0, pow = 0, expo; DOUBLE_T sum, W, y[FLT128_DIG]; errno = 0; for (i = 0; i < FLT128_DIG; i++) { y[i] = 0.0q; } while (IS_SPACE (s[0])) { s++; } // Scan mantissa digits and put them into "y". if (s[0] == '-') { W = -1.0q; } else { W = 1.0q; } if (s[0] == '+' || s[0] == '-') { s++; } while (s[0] == '0') { s++; } while (pow < FLT128_DIG && s[pos] != NULL_CHAR && (IS_DIGIT (s[pos]) || s[pos] == POINT_CHAR)) { if (s[pos] == POINT_CHAR) { dot = pos; } else { int val = (int) s[pos] - (int) '0'; y[pow] = W * val; W /= 10.0q; pow++; } pos++; } (*end) = &(s[pos]); // Sum from low to high to preserve precision. sum = 0.0q; for (i = FLT128_DIG - 1; i >= 0; i--) { sum = sum + y[i]; } // See if there is an exponent. if (s[pos] != NULL_CHAR && TO_UPPER (s[pos]) == TO_UPPER (EXPONENT_CHAR)) { expo = (int) strtol (&(s[++pos]), end, 10); } else { expo = 0; } // Standardise. if (dot >= 0) { expo += dot - 1; } else { expo += pow - 1; } while (sum != 0.0q && fabsq (sum) < 1.0q) { sum *= 10.0q; expo -= 1; } // if (errno == 0) { return sum * ten_up_double (expo); } else { return 0.0q; } } void genie_beta_inc_cf_real_16 (NODE_T * p) { A68_LONG_REAL x, s, t; POP_OBJECT (p, &x, A68_LONG_REAL); POP_OBJECT (p, &t, A68_LONG_REAL); POP_OBJECT (p, &s, A68_LONG_REAL); errno = 0; PUSH_VALUE (p, dble (a68_beta_inc_16 (VALUE (&s).f, VALUE (&t).f, VALUE (&x).f)), A68_LONG_REAL); MATH_RTE (p, errno != 0, M_LONG_REAL, NO_TEXT); } void genie_beta_real_16 (NODE_T * p) { A68_LONG_REAL a, b; POP_OBJECT (p, &b, A68_LONG_REAL); POP_OBJECT (p, &a, A68_LONG_REAL); errno = 0; PUSH_VALUE (p, dble (expq (lgammaq (VALUE (&a).f) + lgammaq (VALUE (&b).f) - lgammaq (VALUE (&a).f + VALUE (&b).f))), A68_LONG_REAL); MATH_RTE (p, errno != 0, M_LONG_REAL, NO_TEXT); } void genie_ln_beta_real_16 (NODE_T * p) { A68_LONG_REAL a, b; POP_OBJECT (p, &b, A68_LONG_REAL); POP_OBJECT (p, &a, A68_LONG_REAL); errno = 0; PUSH_VALUE (p, dble (lgammaq (VALUE (&a).f) + lgammaq (VALUE (&b).f) - lgammaq (VALUE (&a).f + VALUE (&b).f)), A68_LONG_REAL); MATH_RTE (p, errno != 0, M_LONG_REAL, NO_TEXT); } // LONG REAL infinity void genie_infinity_real_16 (NODE_T * p) { PUSH_VALUE (p, dble (a68_posinf ()), A68_LONG_REAL); } // LONG REAL minus infinity void genie_minus_infinity_real_16 (NODE_T * p) { PUSH_VALUE (p, dble (a68_dneginf ()), A68_LONG_REAL); } #endif algol68g-3.1.2/src/a68g/refinement.c0000644000175000017500000001442514361065320013723 00000000000000//! @file refinement.c //! @author J. Marcel van der Veer // //! @section Copyright // // This file is part of Algol68G - an Algol 68 compiler-interpreter. // Copyright 2001-2023 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" #include "a68g-parser.h" // This code implements a small refinement preprocessor for A68G. // // At the University of Nijmegen a preprocessor much like this one was used // as a front-end to FLACC in elementary computer science courses. // See: // // C.H.A. Koster et al., // Systematisch programmeren in Algol 68, Deel I en II. //! @brief Whether refinement terminator. 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 (&A68_JOB); TOP_REFINEMENT (&A68_JOB) = 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_ALIGNED (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 (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 (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 (&A68_JOB); exists = A68_FALSE; while (x != NO_REFINEMENT && !exists) { if (NAME (x) == NAME (new_one)) { diagnostic (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 (&A68_JOB); TOP_REFINEMENT (&A68_JOB) = new_one; } } if (p != NO_NODE && !IN_PRELUDE (p)) { diagnostic (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 (&A68_JOB) == NO_REFINEMENT) { return; } // Initialisation. x = TOP_REFINEMENT (&A68_JOB); while (x != NO_REFINEMENT) { APPLICATIONS (x) = 0; FORWARD (x); } // Before we introduce infinite loops, find where closing-prelude starts. p = TOP_NODE (&A68_JOB); 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, __func__); point = p; // We need to substitute until the first point. p = TOP_NODE (&A68_JOB); 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 (&A68_JOB); 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 (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 (A68_SYNTAX_ERROR, p, ERROR_SYNTAX_EXPECTED, POINT_SYMBOL); } // Has the programmer done it well?. if (ERROR_COUNT (&A68_JOB) == 0) { x = TOP_REFINEMENT (&A68_JOB); while (x != NO_REFINEMENT) { if (APPLICATIONS (x) == 0) { diagnostic (A68_SYNTAX_ERROR, NODE_DEFINED (x), ERROR_REFINEMENT_NOT_APPLIED); } FORWARD (x); } } } algol68g-3.1.2/src/a68g/physics.c0000644000175000017500000003303514361065320013247 00000000000000//! @file physics.c //! @author J. Marcel van der Veer // //! @section Copyright // // This file is part of Algol68G - an Algol 68 compiler-interpreter. // Copyright 2001-2023 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" #include "a68g-genie.h" #include "a68g-prelude.h" #include "a68g-physics.h" #include "a68g-numbers.h" 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 * CONST_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 * CONST_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); algol68g-3.1.2/src/a68g/scanner.c0000644000175000017500000013376214361065320013226 00000000000000//! @file scanner.c //! @author J. Marcel van der Veer // //! @section Copyright // // This file is part of Algol68G - an Algol 68 compiler-interpreter. // Copyright 2001-2023 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" #include "a68g-parser.h" #include "a68g-prelude.h" #include "a68g-options.h" #include "a68g-environ.h" #include "a68g-genie.h" // 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 Save scanner state, for character look-ahead. void save_state (LINE_T * ref_l, char *ref_s, char ch) { SCAN_STATE_L (&A68_JOB) = ref_l; SCAN_STATE_S (&A68_JOB) = ref_s; SCAN_STATE_C (&A68_JOB) = ch; } //! @brief Restore scanner state, for character look-ahead. void restore_state (LINE_T ** ref_l, char **ref_s, char *ch) { *ref_l = SCAN_STATE_L (&A68_JOB); *ref_s = SCAN_STATE_S (&A68_JOB); *ch = SCAN_STATE_C (&A68_JOB); } //! @brief New_source_line. LINE_T *new_source_line (void) { LINE_T *z = (LINE_T *) get_fixed_heap_space ((size_t) SIZE_ALIGNED (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 Append a source line to the internal source file. 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, __func__); (*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 (&A68_JOB) == NO_LINE) { TOP_LINE (&A68_JOB) = z; } if (*ref_l != NO_LINE) { NEXT (*ref_l) = z; } *ref_l = z; } // Scanner, tokenises the source code. //! @brief Whether ch is unworthy. void unworthy (LINE_T * u, char *v, char ch) { if (IS_PRINT (ch)) { ASSERT (snprintf (A68 (edit_line), SNPRINTF_SIZE, "*%s", ERROR_UNWORTHY_CHARACTER) >= 0); } else { ASSERT (snprintf (A68 (edit_line), SNPRINTF_SIZE, "*%s %s", ERROR_UNWORTHY_CHARACTER, ctrl_char (ch)) >= 0); } scan_error (u, v, A68 (edit_line)); } //! @brief Concatenate lines that terminate in '\' with next line. 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. BOOL_T is_bold (char *u, char *v) { unt len = (unt) strlen (v); if (OPTION_STROPPING (&A68_JOB) == 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. 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. 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. 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. 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'. 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. 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 (A68_PARSER (no_preprocessing) && streq (item, "PREPROCESSOR") == 0) { A68_PARSER (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 (A68_PARSER (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) { A68_PARSER (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. 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. // A rigorous fail-safe, but there is no mechanism to prevent recursive includes // in A68 source code. User reports do not indicate sophisticated use of INCLUDE, // so this is fine for now. // TODO - some day we might need `app', analogous to `cpp'. // BOOL_T make_pass = A68_TRUE; while (make_pass) { LINE_T *s, *t, *u = top; char *v = &(STRING (u)[0]); make_pass = A68_FALSE; errno = 0; while (u != NO_LINE) { int pr_lim; char *item = next_preprocessor_item (&u, &v, &pr_lim); LINE_T *start_l = u; char *start_c = v; // Search for PR include "filename" PR. if (item != NO_TEXT && (streq (item, "INCLUDE") == 0 || 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. while (IS_ALPHA (v[0])) { v++; } 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); SCAN_ERROR (n == 0, start_l, start_c, ERROR_INCORRECT_FILENAME); // Make the name relative to the position of the source file (C preprocessor standard). if (FILENAME (u) != NO_TEXT) { fn = a68_relpath (a68_dirname (FILENAME (u)), a68_dirname (fnb), a68_basename (fnb)); } else { fn = a68_relpath (FILE_PATH (&A68_JOB), a68_dirname (fnb), a68_basename (fnb)); } // Do not check errno, since errno may be undefined here after a successful call. if (fn != NO_TEXT) { bufcpy (fnb, fn, BUFFER_SIZE); } else { char err[PATH_MAX + 1]; bufcpy (err, ERROR_SOURCE_FILE_OPEN, PATH_MAX); bufcat (err, " ", PATH_MAX); bufcat (err, fnb, PATH_MAX); SCAN_ERROR (A68_TRUE, NO_LINE, NO_TEXT, err); } fnwid = (int) strlen (fnb) + 1; fn = (char *) get_fixed_heap_space ((size_t) fnwid); bufcpy (fn, fnb, fnwid); // Ignore the file when included more than once. for (t = top; t != NO_LINE; t = NEXT (t)) { if (strcmp (FILENAME (t), fn) == 0) { goto search_next_pragmat; } } t = NO_LINE; // Access the file. errno = 0; fd = open (fn, O_RDONLY | O_BINARY); ASSERT (snprintf (A68 (edit_line), SNPRINTF_SIZE, "*%s \"%s\"", ERROR_SOURCE_FILE_OPEN, fn) >= 0); SCAN_ERROR (fd == -1, start_l, start_c, A68 (edit_line)); errno = 0; 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 ((unt) (8 + fsize)); errno = 0; ASSERT (lseek (fd, 0, SEEK_SET) >= 0); SCAN_ERROR (errno != 0, start_l, start_c, ERROR_FILE_READ); errno = 0; 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 > A68_PARSER (max_scan_buf_length)) { A68_PARSER (max_scan_buf_length) = fsize; A68_PARSER (scan_buf) = (char *) get_temp_heap_space ((unt) (8 + A68_PARSER (max_scan_buf_length))); } // Link all lines into the list. linum = 1; s = u; t = PREVIOUS (u); k = 0; if (fsize == 0) { // If file is empty, insert single empty line. A68_PARSER (scan_buf)[0] = NEWLINE_CHAR; A68_PARSER (scan_buf)[1] = NULL_CHAR; append_source_line (A68_PARSER (scan_buf), &t, &linum, fn); } else while (k < fsize) { n = 0; A68_PARSER (scan_buf)[0] = NULL_CHAR; while (k < fsize && fbuf[k] != NEWLINE_CHAR) { SCAN_ERROR ((IS_CNTRL (fbuf[k]) && !IS_SPACE (fbuf[k])) || fbuf[k] == STOP_CHAR, start_l, start_c, ERROR_FILE_INCLUDE_CTRL); A68_PARSER (scan_buf)[n++] = fbuf[k++]; A68_PARSER (scan_buf)[n] = NULL_CHAR; } A68_PARSER (scan_buf)[n++] = NEWLINE_CHAR; A68_PARSER (scan_buf)[n] = NULL_CHAR; if (k < fsize) { k++; } append_source_line (A68_PARSER (scan_buf), &t, &linum, fn); } // Conclude and go find another include directive, if any. NEXT (t) = s; PREVIOUS (s) = t; concatenate_lines (top); ASSERT (close (fd) == 0); make_pass = A68_TRUE; } search_next_pragmat:_SKIP_; } } } //! @brief Size of source file. int get_source_size (void) { FILE_T f = FILE_SOURCE_FD (&A68_JOB); // This is why WIN32 must open as "read binary". return (int) lseek (f, 0, SEEK_END); } //! @brief Append environment source lines. 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); } } //! @brief Read script file and make internal copy. BOOL_T read_script_file (void) { LINE_T *ref_l = NO_LINE; int k, n, num; unt 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 ((unt) (8 + A68_PARSER (source_file_size))); FILE_T source = FILE_SOURCE_FD (&A68_JOB); ABEND (source == -1, ERROR_ACTION, __func__); buffer[0] = NULL_CHAR; n = 0; len = (unt) (8 + A68_PARSER (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 (&A68 (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, ERROR_INTERNAL_CONSISTENCY, __func__); // 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 ((unt) n >= len, ERROR_ACTION, __func__); } 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. 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 (&A68_JOB); char **prelude_start, **postlude, *buffer; // Prelude. if (OPTION_STROPPING (&A68_JOB) == UPPER_STROPPING) { prelude_start = bold_prelude_start; postlude = bold_postlude; } else if (OPTION_STROPPING (&A68_JOB) == 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; errno = 0; buffer = (char *) get_temp_heap_space ((unt) (8 + A68_PARSER (source_file_size))); ABEND (errno != 0 || buffer == NO_TEXT, ERROR_ALLOCATION, __func__); ASSERT (lseek (f, 0, SEEK_SET) >= 0); ABEND (errno != 0, ERROR_ACTION, __func__); errno = 0; bytes_read = (int) io_read (f, buffer, (size_t) A68_PARSER (source_file_size)); ABEND (errno != 0 || bytes_read != A68_PARSER (source_file_size), ERROR_ACTION, __func__); // Link all lines into the list. k = 0; while (k < A68_PARSER (source_file_size)) { l = 0; A68_PARSER (scan_buf)[0] = NULL_CHAR; while (k < A68_PARSER (source_file_size) && buffer[k] != NEWLINE_CHAR) { if (k < A68_PARSER (source_file_size) - 1 && buffer[k] == CR_CHAR && buffer[k + 1] == NEWLINE_CHAR) { k++; } else { A68_PARSER (scan_buf)[l++] = buffer[k++]; A68_PARSER (scan_buf)[l] = NULL_CHAR; } } A68_PARSER (scan_buf)[l++] = NEWLINE_CHAR; A68_PARSER (scan_buf)[l] = NULL_CHAR; if (k < A68_PARSER (source_file_size)) { k++; } append_source_line (A68_PARSER (scan_buf), &ref_l, &line_num, FILE_SOURCE_NAME (&A68_JOB)); SCAN_ERROR (l != (ssize_t) strlen (A68_PARSER (scan_buf)), NO_LINE, NO_TEXT, ERROR_FILE_SOURCE_CTRL); } // Postlude. append_environ (postlude, &ref_l, &line_num, "postlude"); // Concatenate lines. concatenate_lines (TOP_LINE (&A68_JOB)); // Include files. include_files (TOP_LINE (&A68_JOB)); return A68_TRUE; } //! @brief Next_char get next character from internal copy of source file. 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 (&A68_JOB) & 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. 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 (&A68_JOB) & SOURCE_MASK ? A68_TRUE : A68_FALSE); } *ref_c = next_char (ref_l, ref_s, A68_FALSE); } } //! @brief Handle a pragment (pragmat or comment). char *pragment (int type, LINE_T ** ref_l, char **ref_c) { #define INIT_BUFFER {chars_in_buf = 0; A68_PARSER (scan_buf)[chars_in_buf] = NULL_CHAR;} #define ADD_ONE_CHAR(ch) {A68_PARSER (scan_buf)[chars_in_buf ++] = ch; A68_PARSER (scan_buf)[chars_in_buf] = NULL_CHAR;} char c = **ref_c, *term_s = NO_TEXT, *start_c = *ref_c; char *z = NO_TEXT; LINE_T *start_l = *ref_l; int term_s_length, chars_in_buf; BOOL_T stop, pragmat = A68_FALSE; // Set terminator. if (OPTION_STROPPING (&A68_JOB) == UPPER_STROPPING) { if (type == STYLE_I_COMMENT_SYMBOL) { term_s = "CO"; } else if (type == STYLE_II_COMMENT_SYMBOL) { term_s = "#"; } else if (type == BOLD_COMMENT_SYMBOL) { term_s = "COMMENT"; } else if (type == 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 (&A68_JOB) == 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 (&A68_JOB) == 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, &(A68_PARSER (scan_buf)[chars_in_buf - term_s_length])) == 0); } c = next_char (ref_l, ref_c, A68_FALSE); } A68_PARSER (scan_buf)[chars_in_buf - term_s_length] = NULL_CHAR; z = new_string (term_s, A68_PARSER (scan_buf), term_s, NO_TEXT); if (type == STYLE_I_PRAGMAT_SYMBOL || type == BOLD_PRAGMAT_SYMBOL) { isolate_options (A68_PARSER (scan_buf), start_l); } return z; #undef ADD_ONE_CHAR #undef INIT_BUFFER } //! @brief Attribute for format item. 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; } } } //! @brief Whether input shows exponent character. 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 (&A68_JOB) == 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. 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 (&A68_JOB) == 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. 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 (&A68_JOB) == 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.. 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 = A68_PARSER (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 (&A68_JOB) == UPPER_STROPPING) { format_items = "/%\\+-.abcdefghijklmnopqrstuvwxyz"; } else if (OPTION_STROPPING (&A68_JOB) == QUOTE_STROPPING) { format_items = "/%\\+-.ABCDEFGHIJKLMNOPQRSTUVWXYZ"; } else { format_items = "/%\\+-.abcdefghijklmnopqrstuvwxyz"; } if (strchr (format_items, c) != NO_TEXT) { // General format items. (sym++)[0] = c; sym[0] = NULL_CHAR; *att = get_format_item (c); (void) next_char (ref_l, ref_s, 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 (&A68_JOB) == 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 (&A68_JOB) == 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 (&A68_JOB) == 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 (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 (&A68_JOB) == 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 (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 (strchr (MONADS, c) != NO_TEXT || strchr (NOMADS, c) != NO_TEXT) { // Operator. char *scanned = sym; (sym++)[0] = c; c = next_char (ref_l, ref_s, A68_FALSE); if (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. 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. 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. 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. 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 && !A68_PARSER (stop_scanner)) { int att = 0; get_next_token (in_format, l, s, start_l, start_c, &att); if (A68_PARSER (scan_buf)[0] == STOP_CHAR) { A68_PARSER (stop_scanner) = A68_TRUE; } else if (strlen (A68_PARSER (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 (A68 (top_keyword), A68_PARSER (scan_buf)); } else { kw = NO_KEYWORD; } if (!(kw != NO_KEYWORD && att != ROW_CHAR_DENOTATION)) { if (att == IDENTIFIER) { make_lower_case (A68_PARSER (scan_buf)); } if (att != ROW_CHAR_DENOTATION && att != LITERAL) { int len = (int) strlen (A68_PARSER (scan_buf)); while (len >= 1 && A68_PARSER (scan_buf)[len - 1] == '_') { trailing = "_"; A68_PARSER (scan_buf)[len - 1] = NULL_CHAR; len--; } } c = TEXT (add_token (&A68 (top_token), A68_PARSER (scan_buf))); } else { if (IS (kw, TO_SYMBOL)) { // Merge GO and TO to GOTO. if (*root != NO_NODE && IS (*root, GO_SYMBOL)) { ATTRIBUTE (*root) = GOTO_SYMBOL; NSYMBOL (*root) = TEXT (find_keyword (A68 (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 { char *stale = lpr; lpr = new_string (lpr, "\n\n", nlpr, NO_TEXT); a68_free (nlpr); a68_free (stale); } 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 { char *stale = lpr; lpr = new_string (lpr, "\n\n", nlpr, NO_TEXT); a68_free (nlpr); a68_free (stale); } lprt = att; if (!A68_PARSER (stop_scanner)) { (void) set_options (OPTION_LIST (&A68_JOB), 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 (&A68_JOB); 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 (&A68_JOB) == NO_NODE) { TOP_NODE (&A68_JOB) = q; } *root = q; if (trailing != NO_TEXT) { diagnostic (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, STOP)) { 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 (&A68_JOB) && att == SUB_SYMBOL) { ATTRIBUTE (*root) = FORMAT_OPEN_SYMBOL; } else if (OPTION_BRACKETS (&A68_JOB) && 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 (&A68_JOB) && in_format && att == BUS_SYMBOL) { ATTRIBUTE (*root) = FORMAT_CLOSE_SYMBOL; } else if (OPTION_BRACKETS (&A68_JOB) && in_format && att == OCCA_SYMBOL) { ATTRIBUTE (*root) = FORMAT_CLOSE_SYMBOL; } } } } //! @brief Tokenise source file, build initial syntax tree. BOOL_T lexical_analyser (void) { LINE_T *l = NO_LINE, *start_l = NO_LINE; char *s = NO_TEXT, *start_c = NO_TEXT; NODE_T *root = NO_NODE; A68_PARSER (scan_buf) = NO_TEXT; A68_PARSER (max_scan_buf_length) = A68_PARSER (source_file_size) = get_source_size (); // Errors in file?. if (A68_PARSER (max_scan_buf_length) == 0) { return A68_FALSE; } if (OPTION_RUN_SCRIPT (&A68_JOB)) { A68_PARSER (scan_buf) = (char *) get_temp_heap_space ((unt) (8 + A68_PARSER (max_scan_buf_length))); if (!read_script_file ()) { return A68_FALSE; } } else { A68_PARSER (max_scan_buf_length) += KILOBYTE; // for the environ, more than enough A68_PARSER (scan_buf) = (char *) get_temp_heap_space ((unt) A68_PARSER (max_scan_buf_length)); // Errors in file?. if (!read_source_file ()) { return A68_FALSE; } } // Start tokenising. A68_PARSER (read_error) = A68_FALSE; A68_PARSER (stop_scanner) = A68_FALSE; if ((l = TOP_LINE (&A68_JOB)) != NO_LINE) { s = STRING (l); } tokenise_source (&root, 0, A68_FALSE, &l, &s, &start_l, &start_c); return A68_TRUE; } algol68g-3.1.2/src/a68g/fft.c0000644000175000017500000002463514361065320012352 00000000000000//! @file fft.c //! @author J. Marcel van der Veer // //! @section Copyright // // This file is part of Algol68G - an Algol 68 compiler-interpreter. // Copyright 2001-2023 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" #include "a68g-genie.h" #include "a68g-prelude.h" #if defined (HAVE_GSL) //! @brief Map GSL error handler onto a68g error handler. void fft_error_handler (const char *reason, const char *file, int line, int gsl_errno) { if (line != 0) { ASSERT (snprintf (A68 (edit_line), SNPRINTF_SIZE, "%s in line %d of file %s", reason, line, file) >= 0); } else { ASSERT (snprintf (A68 (edit_line), SNPRINTF_SIZE, "%s", reason) >= 0); } diagnostic (A68_RUNTIME_ERROR, A68 (f_entry), ERROR_FFT, A68 (edit_line), gsl_strerror (gsl_errno)); exit_genie (A68 (f_entry), A68_RUNTIME_ERROR); } //! @brief Detect math errors. void fft_test_error (int rc) { if (rc != 0) { fft_error_handler ("math error", "", 0, rc); } } //! @brief Pop [] REAL on the stack as complex REAL_T []. REAL_T *pop_array_real (NODE_T * p, int *len) { A68_REF desc; A68_ARRAY *arr; A68_TUPLE *tup; int inc, iindex, k; BYTE_T *base; REAL_T *v; A68 (f_entry) = p; // Pop arguments. POP_REF (p, &desc); CHECK_REF (p, desc, M_ROW_REAL); GET_DESCRIPTOR (arr, tup, &desc); *len = ROW_SIZE (tup); if ((*len) <= 0) { return NO_REAL; } v = (REAL_T *) get_heap_space (2 * (size_t) (*len) * sizeof (REAL_T)); 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), M_REAL); v[2 * k] = VALUE (x); v[2 * k + 1] = 0.0; } return v; } //! @brief Push REAL_T [] on the stack as [] REAL. void push_array_real (NODE_T * p, REAL_T * v, int len) { A68_REF desc, row; A68_ARRAY arr; A68_TUPLE tup; int inc, iindex, k; BYTE_T *base; A68 (f_entry) = p; NEW_ROW_1D (desc, row, arr, tup, M_ROW_REAL, M_REAL, len); 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 (p, VALUE (x)); } PUSH_REF (p, desc); } //! @brief Pop [] COMPLEX on the stack as REAL_T []. REAL_T *pop_array_complex (NODE_T * p, int *len) { A68_REF desc; A68_ARRAY *arr; A68_TUPLE *tup; int inc, iindex, k; BYTE_T *base; REAL_T *v; A68 (f_entry) = p; // Pop arguments. POP_REF (p, &desc); CHECK_REF (p, desc, M_ROW_COMPLEX); GET_DESCRIPTOR (arr, tup, &desc); *len = ROW_SIZE (tup); if ((*len) <= 0) { return NO_REAL; } v = (REAL_T *) get_heap_space (2 * (size_t) (*len) * sizeof (REAL_T)); 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 (M_REAL)); CHECK_INIT (p, INITIALISED (re), M_COMPLEX); CHECK_INIT (p, INITIALISED (im), M_COMPLEX); v[2 * k] = VALUE (re); v[2 * k + 1] = VALUE (im); } return v; } //! @brief Push REAL_T [] on the stack as [] COMPLEX. void push_array_complex (NODE_T * p, REAL_T * v, int len) { A68_REF desc, row; A68_ARRAY arr; A68_TUPLE tup; int inc, iindex, k; BYTE_T *base; A68 (f_entry) = p; NEW_ROW_1D (desc, row, arr, tup, M_ROW_COMPLEX, M_COMPLEX, len); 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 (M_REAL)); STATUS (re) = INIT_MASK; VALUE (re) = v[2 * k]; STATUS (im) = INIT_MASK; VALUE (im) = v[2 * k + 1]; CHECK_COMPLEX (p, VALUE (re), VALUE (im)); } PUSH_REF (p, desc); } //! @brief Push prime factorisation on the stack as [] INT. 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; A68 (f_entry) = p; POP_OBJECT (p, &n, A68_INT); CHECK_INIT (p, INITIALISED (&n), M_INT); wt = gsl_fft_complex_wavetable_alloc ((size_t) (VALUE (&n))); len = (int) (NF (wt)); NEW_ROW_1D (desc, row, arr, tup, M_ROW_INT, M_INT, len); 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 void genie_fft_complex_forward (NODE_T * p) { gsl_error_handler_t *save_handler = gsl_set_error_handler (fft_error_handler); int len, rc; REAL_T *data; gsl_fft_complex_wavetable *wt; gsl_fft_complex_workspace *ws; A68 (f_entry) = 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) { a68_free (data); } (void) gsl_set_error_handler (save_handler); } //! @brief PROC ([] COMPLEX) [] COMPLEX fft complex backward void genie_fft_complex_backward (NODE_T * p) { gsl_error_handler_t *save_handler = gsl_set_error_handler (fft_error_handler); int len, rc; REAL_T *data; gsl_fft_complex_wavetable *wt; gsl_fft_complex_workspace *ws; A68 (f_entry) = 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) { a68_free (data); } (void) gsl_set_error_handler (save_handler); } //! @brief PROC ([] COMPLEX) [] COMPLEX fft complex inverse void genie_fft_complex_inverse (NODE_T * p) { gsl_error_handler_t *save_handler = gsl_set_error_handler (fft_error_handler); int len, rc; REAL_T *data; gsl_fft_complex_wavetable *wt; gsl_fft_complex_workspace *ws; A68 (f_entry) = 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) { a68_free (data); } (void) gsl_set_error_handler (save_handler); } //! @brief PROC ([] REAL) [] COMPLEX fft forward void genie_fft_forward (NODE_T * p) { gsl_error_handler_t *save_handler = gsl_set_error_handler (fft_error_handler); int len, rc; REAL_T *data; gsl_fft_complex_wavetable *wt; gsl_fft_complex_workspace *ws; A68 (f_entry) = 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) { a68_free (data); } (void) gsl_set_error_handler (save_handler); } //! @brief PROC ([] COMPLEX) [] REAL fft backward void genie_fft_backward (NODE_T * p) { gsl_error_handler_t *save_handler = gsl_set_error_handler (fft_error_handler); int len, rc; REAL_T *data; gsl_fft_complex_wavetable *wt; gsl_fft_complex_workspace *ws; A68 (f_entry) = 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) { a68_free (data); } (void) gsl_set_error_handler (save_handler); } //! @brief PROC ([] COMPLEX) [] REAL fft inverse void genie_fft_inverse (NODE_T * p) { gsl_error_handler_t *save_handler = gsl_set_error_handler (fft_error_handler); int len, rc; REAL_T *data; gsl_fft_complex_wavetable *wt; gsl_fft_complex_workspace *ws; A68 (f_entry) = 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) { a68_free (data); } (void) gsl_set_error_handler (save_handler); } #endif algol68g-3.1.2/src/a68g/mp-gamma.c0000644000175000017500000003702714361065320013266 00000000000000//! @file mp-gamma.c //! @author J. Marcel van der Veer // //! @section Copyright // // This file is part of Algol68G - an Algol 68 compiler-interpreter. // Copyright 2001-2023 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" #include "a68g-genie.h" #include "a68g-prelude.h" #include "a68g-double.h" #include "a68g-mp.h" #include "a68g-lib.h" //! @brief PROC (LONG REAL) LONG REAL erf MP_T *erf_mp (NODE_T * p, MP_T * z, MP_T * x, int digs) { if (IS_ZERO_MP (x)) { SET_MP_ZERO (z, digs); return z; } else { ADDR_T pop_sp = A68_SP; // Note we need double precision! int gdigs = FUN_DIGITS (2 * digs), k = 1, sign; BOOL_T go_on = A68_TRUE; MP_T *y_g = nil_mp (p, gdigs); MP_T *z_g = len_mp (p, x, digs, gdigs); sign = MP_SIGN (x); (void) abs_mp (p, z_g, z_g, gdigs); (void) set_mp (y_g, gdigs * LOG_MP_RADIX, 0, gdigs); (void) sqrt_mp (p, y_g, y_g, gdigs); (void) sub_mp (p, y_g, z_g, y_g, gdigs); if (MP_SIGN (y_g) >= 0) { SET_MP_ONE (z, digs); } else { // Taylor expansion. MP_T *p_g = nil_mp (p, gdigs); MP_T *r_g = nil_mp (p, gdigs); MP_T *s_g = nil_mp (p, gdigs); MP_T *t_g = nil_mp (p, gdigs); MP_T *u_g = nil_mp (p, gdigs); (void) mul_mp (p, y_g, z_g, z_g, gdigs); SET_MP_ONE (s_g, gdigs); SET_MP_ONE (t_g, gdigs); for (k = 1; go_on; k++) { (void) mul_mp (p, t_g, y_g, t_g, gdigs); (void) div_mp_digit (p, t_g, t_g, (MP_T) k, gdigs); (void) div_mp_digit (p, u_g, t_g, (MP_T) (2 * k + 1), gdigs); if (EVEN (k)) { (void) add_mp (p, s_g, s_g, u_g, gdigs); } else { (void) sub_mp (p, s_g, s_g, u_g, gdigs); } go_on = (MP_EXPONENT (s_g) - MP_EXPONENT (u_g)) < gdigs; } (void) mul_mp (p, r_g, z_g, s_g, gdigs); (void) mul_mp_digit (p, r_g, r_g, 2, gdigs); (void) mp_pi (p, p_g, MP_SQRT_PI, gdigs); (void) div_mp (p, r_g, r_g, p_g, gdigs); (void) shorten_mp (p, z, digs, r_g, gdigs); } if (sign < 0) { (void) minus_mp (p, z, z, digs); } A68_SP = pop_sp; return z; } } //! @brief PROC (LONG REAL) LONG REAL erfc MP_T *erfc_mp (NODE_T * p, MP_T * z, MP_T * x, int digs) { (void) erf_mp (p, z, x, digs); (void) one_minus_mp (p, z, z, digs); return z; } //! @brief PROC (LONG REAL) LONG REAL inverf MP_T *inverf_mp (NODE_T * p, MP_T * z, MP_T * x, int digs) { ADDR_T pop_sp = A68_SP; int gdigs, sign; BOOL_T go_on = A68_TRUE; // Precision adapts to the argument, but not too much. // If this is not precise enough, you need more digs // in your entire calculation, not just in this routine. // Calculate an initial Newton-Raphson estimate while at it. #if (A68_LEVEL >= 3) DOUBLE_T y = ABS (mp_to_real_16 (p, x, digs)); if (y < erfq (5.0q)) { y = inverf_real_16 (y); gdigs = FUN_DIGITS (digs); } else { y = 5.0q; gdigs = FUN_DIGITS (2 * digs); } MP_T *z_g = nil_mp (p, gdigs); (void) real_16_to_mp (p, z_g, y, gdigs); #else REAL_T y = ABS (mp_to_real (p, x, digs)); if (y < erf (4.0)) { y = a68_inverf (y); gdigs = FUN_DIGITS (digs); } else { y = 4.0; gdigs = FUN_DIGITS (2 * digs); } MP_T *z_g = nil_mp (p, gdigs); (void) real_to_mp (p, z_g, y, gdigs); #endif MP_T *x_g = len_mp (p, x, digs, gdigs); MP_T *y_g = nil_mp (p, gdigs); sign = MP_SIGN (x); (void) abs_mp (p, x_g, x_g, gdigs); SET_MP_ONE (y_g, gdigs); (void) sub_mp (p, y_g, x_g, y_g, gdigs); if (MP_SIGN (y_g) >= 0) { errno = EDOM; A68_SP = pop_sp; return NaN_MP; } else { // Newton-Raphson. MP_T *d_g = nil_mp (p, gdigs); MP_T *f_g = nil_mp (p, gdigs); MP_T *p_g = nil_mp (p, gdigs); // sqrt (pi) / 2 (void) mp_pi (p, p_g, MP_SQRT_PI, gdigs); (void) half_mp (p, p_g, p_g, gdigs); // nrdigs prevents end-less iteration int nrdigs; for (nrdigs = 0; nrdigs < digs && go_on; nrdigs++) { (void) move_mp (y_g, z_g, gdigs); (void) erf_mp (p, f_g, z_g, gdigs); (void) sub_mp (p, f_g, f_g, x_g, gdigs); (void) mul_mp (p, d_g, z_g, z_g, gdigs); (void) minus_mp (p, d_g, d_g, gdigs); (void) exp_mp (p, d_g, d_g, gdigs); (void) div_mp (p, f_g, f_g, d_g, gdigs); (void) mul_mp (p, f_g, f_g, p_g, gdigs); (void) sub_mp (p, z_g, z_g, f_g, gdigs); (void) sub_mp (p, y_g, z_g, y_g, gdigs); if (IS_ZERO_MP (y_g)) { go_on = A68_FALSE; } else { go_on = ABS (MP_EXPONENT (y_g)) < digs; } } (void) shorten_mp (p, z, digs, z_g, gdigs); } if (sign < 0) { (void) minus_mp (p, z, z, digs); } A68_SP = pop_sp; return z; } //! @brief PROC (LONG REAL) LONG REAL inverfc MP_T *inverfc_mp (NODE_T * p, MP_T * z, MP_T * x, int digs) { (void) one_minus_mp (p, z, x, digs); (void) inverf_mp (p, z, z, digs); return z; } // Reference: // John L. Spouge. "Computation of the Gamma, Digamma, and Trigamma Functions". // SIAM Journal on Numerical Analysis. 31 (3) [1994] // // Spouge's algorithm sums terms of greatly varying magnitude. #define GAMMA_PRECISION(z) (2 * (z)) //! brief Set up gamma coefficient table void mp_gamma_table (NODE_T *p, int digs) { if (A68_MP (mp_gamma_size) <= 0) { int b = 1; int gdigs = GAMMA_PRECISION (digs); REAL_T log_lim = -digs * LOG_MP_RADIX, log_error; do { ABEND (b >= MP_RADIX, ERROR_HIGH_PRECISION, __func__); // error = 1 / (sqrt (b) * a68_x_up_y (2 * M_PI, b + 0.5)); log_error = -(log10 (b) / 2 + (b + 0.5) * log10 (2 *M_PI)); b += 1; } while (log_error > log_lim); A68_MP (mp_gamma_size) = b; A68_MP (mp_gam_ck) = (MP_T **) get_heap_space ((size_t) ((b + 1) * sizeof (MP_T *))); A68_MP (mp_gam_ck)[0] = (MP_T *) get_heap_space (SIZE_MP (gdigs)); (void) mp_pi (p, (A68_MP (mp_gam_ck)[0]), MP_SQRT_TWO_PI, gdigs); ADDR_T pop_sp = A68_SP; MP_T *ak = nil_mp (p, gdigs); MP_T *db = lit_mp (p, b, 0, gdigs); MP_T *ck = nil_mp (p, gdigs); MP_T *dk = nil_mp (p, gdigs); MP_T *dz = nil_mp (p, gdigs); MP_T *hlf = nil_mp (p, gdigs); MP_T *fac = lit_mp (p, 1, 0, gdigs); SET_MP_HALF (hlf, gdigs); int k; for (k = 1; k < b; k++) { set_mp (dk, k, 0, gdigs); (void) sub_mp (p, ak, db, dk, gdigs); (void) sub_mp (p, dz, dk, hlf, gdigs); (void) pow_mp (p, ck, ak, dz, gdigs); (void) exp_mp (p, dz, ak, gdigs); (void) mul_mp (p, ck, ck, dz, gdigs); (void) div_mp (p, ck, ck, fac, gdigs); A68_MP (mp_gam_ck)[k] = (MP_T *) get_heap_space (SIZE_MP (gdigs)); (void) move_mp ((A68_MP(mp_gam_ck)[k]), ck, gdigs); (void) mul_mp (p, fac, fac, dk, gdigs); (void) minus_mp (p, fac, fac, gdigs); } A68_SP = pop_sp; } } MP_T *mp_spouge_sum (NODE_T *p, MP_T *sum, MP_T *x_g, int gdigs) { ADDR_T pop_sp = A68_SP; int a = A68_MP (mp_gamma_size); MP_T *da = nil_mp (p, gdigs); MP_T *dz = nil_mp (p, gdigs); (void) move_mp (sum, A68_MP (mp_gam_ck)[0], gdigs); // Sum small to large to preserve precision. int k; for (k = a - 1; k > 0; k--) { set_mp (da, k, 0, gdigs); (void) add_mp (p, dz, x_g, da, gdigs); (void) div_mp (p, dz, A68_MP (mp_gam_ck)[k], dz, gdigs); (void) add_mp (p, sum, sum, dz, gdigs); } A68_SP = pop_sp; return sum; } //! @brief PROC (LONG REAL) LONG REAL gamma MP_T *gamma_mp (NODE_T * p, MP_T * z, MP_T * x, int digs) { mp_gamma_table (p, digs); int gdigs = GAMMA_PRECISION (digs); // Set up coefficient table. ADDR_T pop_sp = A68_SP; if (MP_DIGIT (x, 1) < 0) { // G(1-x)G(x) = pi / sin (pi*x) MP_T *pi = nil_mp (p, digs); MP_T *sz = nil_mp (p, digs); MP_T *xm = nil_mp (p, digs); (void) mp_pi (p, pi, MP_PI, digs); (void) one_minus_mp (p, xm, x, digs); (void) gamma_mp (p, xm, xm, digs); (void) sinpi_mp (p, sz, x, digs); (void) mul_mp (p, sz, sz, xm, digs); (void) div_mp (p, z, pi, sz, digs); A68_SP = pop_sp; return z; } int a = A68_MP (mp_gamma_size); // Compute Spouge's Gamma MP_T *sum = nil_mp (p, gdigs); MP_T *x_g = len_mp (p, x, digs, gdigs); (void) minus_one_mp (p, x_g, x_g, gdigs); (void) mp_spouge_sum (p, sum, x_g, gdigs); // (z+a)^(z+0.5)*exp(-(z+a)) * Sum MP_T *fac = nil_mp (p, gdigs); MP_T *dz = nil_mp (p, gdigs); MP_T *az = nil_mp (p, gdigs); MP_T *da = nil_mp (p, gdigs); MP_T *hlf = nil_mp (p, gdigs); SET_MP_HALF (hlf, gdigs); set_mp (da, a, 0, gdigs); (void) add_mp (p, az, x_g, da, gdigs); (void) add_mp (p, dz, x_g, hlf, gdigs); (void) pow_mp (p, fac, az, dz, gdigs); (void) minus_mp (p, az, az, gdigs); (void) exp_mp (p, dz, az, gdigs); (void) mul_mp (p, fac, fac, dz, gdigs); (void) mul_mp (p, fac, sum, fac, gdigs); (void) shorten_mp (p, z, digs, fac, gdigs); A68_SP = pop_sp; return z; } //! @brief PROC (LONG REAL) LONG REAL ln gamma MP_T *lngamma_mp (NODE_T * p, MP_T * z, MP_T * x, int digs) { mp_gamma_table (p, digs); int gdigs = GAMMA_PRECISION (digs); // Set up coefficient table. ADDR_T pop_sp = A68_SP; if (MP_DIGIT (x, 1) < 0) { // G(1-x)G(x) = pi / sin (pi*x) MP_T *sz = nil_mp (p, digs); MP_T *dz = nil_mp (p, digs); MP_T *xm = nil_mp (p, digs); (void) mp_pi (p, dz, MP_LN_PI, digs); (void) sinpi_mp (p, sz, x, digs); (void) ln_mp (p, sz, sz, digs); (void) sub_mp (p, dz, dz, sz, digs); (void) one_minus_mp (p, xm, x, digs); (void) lngamma_mp (p, xm, xm, digs); (void) sub_mp (p, z, dz, xm, digs); A68_SP = pop_sp; return z; } int a = A68_MP (mp_gamma_size); // Compute Spouge's ln Gamma MP_T *sum = nil_mp (p, gdigs); MP_T *x_g = len_mp (p, x, digs, gdigs); (void) minus_one_mp (p, x_g, x_g, gdigs); (void) mp_spouge_sum (p, sum, x_g, gdigs); // (x+0.5) * ln (x+a) - (x+a) + ln Sum MP_T *da = nil_mp (p, gdigs); MP_T *hlf = nil_mp (p, gdigs); SET_MP_HALF (hlf, gdigs); MP_T *fac = nil_mp (p, gdigs); MP_T *dz = nil_mp (p, gdigs); MP_T *az = nil_mp (p, gdigs); set_mp (da, a, 0, gdigs); (void) add_mp (p, az, x_g, da, gdigs); (void) ln_mp (p, fac, az, gdigs); (void) add_mp (p, dz, x_g, hlf, gdigs); (void) mul_mp (p, fac, fac, dz, gdigs); (void) sub_mp (p, fac, fac, az, gdigs); (void) ln_mp (p, dz, sum, gdigs); (void) add_mp (p, fac, fac, dz, gdigs); (void) shorten_mp (p, z, digs, fac, gdigs); A68_SP = pop_sp; return z; } //! @brief PROC (LONG REAL, LONG REAL) LONG REAL ln beta MP_T *lnbeta_mp (NODE_T * p, MP_T * z, MP_T * a, MP_T *b, int digs) { ADDR_T pop_sp = A68_SP; MP_T *aa = nil_mp (p, digs); MP_T *bb = nil_mp (p, digs); MP_T *ab = nil_mp (p, digs); (void) lngamma_mp (p, aa, a, digs); (void) lngamma_mp (p, bb, b, digs); (void) add_mp (p, ab, a, b, digs); (void) lngamma_mp (p, ab, ab, digs); (void) add_mp (p, z, aa, bb, digs); (void) sub_mp (p, z, z, ab, digs); A68_SP = pop_sp; return z; } //! @brief PROC (LONG REAL, LONG REAL) LONG REAL beta MP_T *beta_mp (NODE_T * p, MP_T * z, MP_T * a, MP_T *b, int digs) { ADDR_T pop_sp = A68_SP; MP_T *u = nil_mp (p, digs); lnbeta_mp (p, u, a, b, digs); exp_mp (p, z, u, digs); A68_SP = pop_sp; return z; } //! @brief PROC (LONG REAL, LONG REAL, LONG REAL) LONG REAL beta inc MP_T *beta_inc_mp (NODE_T * p, MP_T * z, MP_T * s, MP_T *t, MP_T *x, int digs) { // Incomplete beta function I{x}(s, t). // Continued fraction, see dlmf.nist.gov/8.17; Lentz's algorithm. ADDR_T pop_sp = A68_SP; A68_BOOL gt; MP_T *one = lit_mp (p, 1, 0, digs); gt_mp (p, >, x, one, digs); if (MP_DIGIT (x, 1) < 0 || VALUE (>)) { errno = EDOM; A68_SP = pop_sp; return NaN_MP; } if (same_mp (p, x, one, digs)) { SET_MP_ONE (z, digs); A68_SP = pop_sp; return z; } // Rapid convergence when x <= (s+1)/((s+1)+(t+1)) or else recursion. { MP_T *u = nil_mp (p, digs), *v = nil_mp (p, digs), *w = nil_mp (p, digs); (void) plus_one_mp (p, u, s, digs); (void) plus_one_mp (p, v, t, digs); (void) add_mp (p, w, u, v, digs); (void) div_mp (p, u, u, w, digs); gt_mp (p, >, x, u, digs); if (VALUE (>)) { // B{x}(s, t) = 1 - B{1-x}(t, s) (void) one_minus_mp (p, x, x, digs); PRELUDE_ERROR (beta_inc_mp (p, z, s, t, x, digs) == NaN_MP, p, ERROR_INVALID_ARGUMENT, MOID (p)); (void) one_minus_mp (p, z, z, digs); A68_SP = pop_sp; return z; } } // Lentz's algorithm for continued fraction. A68_SP = pop_sp; int gdigs = FUN_DIGITS (digs); const INT_T lim = gdigs * LOG_MP_RADIX; BOOL_T cont = A68_TRUE; MP_T *F = lit_mp (p, 1, 0, gdigs); MP_T *T = lit_mp (p, 1, 0, gdigs); MP_T *W = lit_mp (p, 1, 0, gdigs); MP_T *c = lit_mp (p, 1, 0, gdigs); MP_T *d = nil_mp (p, gdigs); MP_T *m = nil_mp (p, gdigs); MP_T *s_g = len_mp (p, s, digs, gdigs); MP_T *t_g = len_mp (p, t, digs, gdigs); MP_T *x_g = len_mp (p, x, digs, gdigs); MP_T *u = lit_mp (p, 1, 0, gdigs); MP_T *v = nil_mp (p, gdigs); MP_T *w = nil_mp (p, gdigs); for (INT_T N = 0; cont && N < lim; N++) { if (N == 0) { SET_MP_ONE (T, gdigs); } else if (N % 2 == 0) { // d{2m} := x m(t-m)/((s+2m-1)(s+2m)) // T = x * m * (t - m) / (s + 2.0q * m - 1.0q) / (s + 2.0q * m); (void) sub_mp (p, u, t_g, m, gdigs); (void) mul_mp (p, u, u, m, gdigs); (void) mul_mp (p, u, u, x_g, gdigs); (void) add_mp (p, v, m, m, gdigs); (void) add_mp (p, v, s_g, v, gdigs); (void) minus_one_mp (p, v, v, gdigs); (void) add_mp (p, w, m, m, gdigs); (void) add_mp (p, w, s_g, w, gdigs); (void) div_mp (p, T, u, v, gdigs); (void) div_mp (p, T, T, w, gdigs); } else { // d{2m+1} := -x (s+m)(s+t+m)/((s+2m+1)(s+2m)) // T = -x * (s + m) * (s + t + m) / (s + 2.0q * m + 1.0q) / (s + 2.0q * m); (void) add_mp (p, u, s_g, m, gdigs); (void) add_mp (p, v, u, t_g, gdigs); (void) mul_mp (p, u, u, v, gdigs); (void) mul_mp (p, u, u, x_g, gdigs); (void) minus_mp (p, u, u, gdigs); (void) add_mp (p, v, m, m, gdigs); (void) add_mp (p, v, s_g, v, gdigs); (void) plus_one_mp (p, v, v, gdigs); (void) add_mp (p, w, m, m, gdigs); (void) add_mp (p, w, s_g, w, gdigs); (void) div_mp (p, T, u, v, gdigs); (void) div_mp (p, T, T, w, gdigs); (void) plus_one_mp (p, m, m, gdigs); } // d = 1.0q / (T * d + 1.0q); (void) mul_mp (p, d, T, d, gdigs); (void) plus_one_mp (p, d, d, gdigs); (void) rec_mp (p, d, d, gdigs); // c = T / c + 1.0q; (void) div_mp (p, c, T, c, gdigs); (void) plus_one_mp (p, c, c, gdigs); // F *= c * d; (void) mul_mp (p, F, F, c, gdigs); (void) mul_mp (p, F, F, d, gdigs); if (same_mp (p, F, W, gdigs)) { cont = A68_FALSE; } else { (void) move_mp (W, F, gdigs); } } minus_one_mp (p, F, F, gdigs); // I{x}(s,t)=x^s(1-x)^t / s / B(s,t) F (void) pow_mp (p, u, x_g, s_g, gdigs); (void) one_minus_mp (p, v, x_g, gdigs); (void) pow_mp (p, v, v, t_g, gdigs); (void) beta_mp (p, w, s_g, t_g, gdigs); (void) mul_mp (p, m, u, v, gdigs); (void) div_mp (p, m, m, s_g, gdigs); (void) div_mp (p, m, m, w, gdigs); (void) mul_mp (p, m, m, F, gdigs); (void) shorten_mp (p, z, digs, m, gdigs); A68_SP = pop_sp; return z; } algol68g-3.1.2/src/a68g/genie-stowed.c0000644000175000017500000011241614361065320014160 00000000000000//! @file genie.c //! @author J. Marcel van der Veer // //! @section Copyright // // This file is part of Algol68G - an Algol 68 compiler-interpreter. // Copyright 2001-2023 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" #include "a68g-genie.h" #include "a68g-frames.h" #include "a68g-prelude.h" #include "a68g-mp.h" #include "a68g-double.h" #include "a68g-parser.h" #include "a68g-transput.h" // 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. 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, __func__); span *= stride; } return span; } //! @brief Initialise index for FORALL constructs. 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. 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. 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. 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, A68_LD, K (ref)) >= 0); WRITE (f, buf); if (k < dim - 1) { WRITE (f, ", "); } } } //! @brief Convert C string to A68 [] 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 k; NEW_ROW_1D (z, row, arr, tup, M_ROW_CHAR, M_CHAR, width); base = ADDRESS (&row); int len = strlen (str); for (k = 0; k < width; k++) { A68_CHAR *ch = (A68_CHAR *) & (base[k * SIZE_ALIGNED (A68_CHAR)]); STATUS (ch) = INIT_MASK; VALUE (ch) = (k < len ? TO_UCHAR (str[k]) : NULL_CHAR); } return z; } //! @brief Convert C string to 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. 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. 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), M_CHAR); str[n++] = (char) VALUE (ch); } } str[n] = NULL_CHAR; return str; } else { return NO_TEXT; } } //! @brief Return an empty row. 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_FLEX (u)) { u = SUB (u); } v = SUB (u); dim = DIM (u); dsc = heap_generator (p, u, DESCRIPTOR_SIZE (dim)); 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_ROW (v) || IS_FLEX (v)) { // [] 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_T) (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. A68_REF empty_string (NODE_T * p) { return empty_row (p, M_STRING); } //! @brief Make [,, ..] MODE from [, ..] MODE. A68_REF genie_make_rowrow (NODE_T * p, MOID_T * rmod, int len, ADDR_T sp) { MOID_T *nmod = IS_FLEX (rmod) ? SUB (rmod) : rmod; MOID_T *emod = SUB (nmod); A68_REF nrow, orow; A68_ARRAY *new_arr, *old_arr; A68_TUPLE *new_tup, *old_tup; int j, k, span, odim = DIM (nmod) - 1; // Make the new descriptor. nrow = heap_generator (p, rmod, DESCRIPTOR_SIZE (DIM (nmod))); GET_DESCRIPTOR (new_arr, new_tup, &nrow); DIM (new_arr) = DIM (nmod); MOID (new_arr) = emod; ELEM_SIZE (new_arr) = SIZE (emod); SLICE_OFFSET (new_arr) = 0; FIELD_OFFSET (new_arr) = 0; if (len == 0) { // There is a vacuum on the stack. for (k = 0; k < odim; k++) { LWB (&new_tup[k + 1]) = 1; UPB (&new_tup[k + 1]) = 0; SPAN (&new_tup[k + 1]) = 1; SHIFT (&new_tup[k + 1]) = LWB (&new_tup[k + 1]); } LWB (new_tup) = 1; UPB (new_tup) = 0; SPAN (new_tup) = 0; SHIFT (new_tup) = 0; ARRAY (new_arr) = 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 (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, old_tup, &orow); for (span = 1, k = 0; k < odim; k++) { A68_TUPLE *nt = &new_tup[k + 1], *ot = &old_tup[k]; LWB (nt) = LWB (ot); UPB (nt) = UPB (ot); SPAN (nt) = span; SHIFT (nt) = LWB (nt) * SPAN (nt); span *= ROW_SIZE (nt); } LWB (new_tup) = 1; UPB (new_tup) = len; SPAN (new_tup) = span; SHIFT (new_tup) = LWB (new_tup) * SPAN (new_tup); ARRAY (new_arr) = heap_generator (p, rmod, len * span * ELEM_SIZE (new_arr)); for (j = 0; j < len; j++) { // new[j,, ] := old[, ]. BOOL_T done; GET_DESCRIPTOR (old_arr, old_tup, (A68_REF *) STACK_ADDRESS (sp + j * A68_REF_SIZE)); if (LWB (old_tup) > UPB (old_tup)) { A68_REF dst = ARRAY (new_arr); ADDR_T new_k = j * SPAN (new_tup) + calculate_internal_index (&new_tup[1], odim); OFFSET (&dst) += ROW_ELEMENT (new_arr, new_k); A68_REF none = empty_row (p, SLICE (rmod)); MOVE (ADDRESS (&dst), ADDRESS (&none), SIZE (emod)); } else { initialise_internal_index (old_tup, odim); initialise_internal_index (&new_tup[1], odim); done = A68_FALSE; while (!done) { A68_REF src = ARRAY (old_arr), dst = ARRAY (new_arr); ADDR_T old_k, new_k; old_k = calculate_internal_index (old_tup, odim); new_k = j * SPAN (new_tup) + calculate_internal_index (&new_tup[1], odim); OFFSET (&src) += ROW_ELEMENT (old_arr, old_k); OFFSET (&dst) += ROW_ELEMENT (new_arr, new_k); if (HAS_ROWS (emod)) { A68_REF none = genie_clone (p, emod, (A68_REF *) & nil_ref, &src); MOVE (ADDRESS (&dst), ADDRESS (&none), SIZE (emod)); } else { MOVE (ADDRESS (&dst), ADDRESS (&src), SIZE (emod)); } done = increment_internal_index (old_tup, odim) | increment_internal_index (&new_tup[1], odim); } } } } return nrow; } //! @brief Make a row of 'len' objects that are in the stack. 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_1D (new_row, new_arr, arr, tup, MOID (p), elem_mode, len); 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_T) (INIT_MASK | IN_STACK_MASK); OFFSET (&src) = sp + k; REF_HANDLE (&src) = (A68_HANDLE *) & nil_handle; if (HAS_ROWS (elem_mode)) { A68_REF new_one = genie_clone (p, elem_mode, (A68_REF *) & 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. 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; } else { new_row = heap_generator (p, SUB (dst_mode), DESCRIPTOR_SIZE (1)); 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. 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, DESCRIPTOR_SIZE (DIM (SUB (dst_mode)))); 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. PROP_T genie_rowing_row_row (NODE_T * p) { A68_REF row; ADDR_T sp = A68_SP; EXECUTE_UNIT (SUB (p)); STACK_DNS (p, MOID (SUB (p)), A68_FP); row = genie_make_rowrow (p, MOID (p), 1, sp); A68_SP = sp; PUSH_REF (p, row); return GPROP (p); } //! @brief Coercion to [1 : 1] [] MODE. PROP_T genie_rowing_row_of_row (NODE_T * p) { A68_REF row; ADDR_T sp = A68_SP; EXECUTE_UNIT (SUB (p)); STACK_DNS (p, MOID (SUB (p)), A68_FP); row = genie_make_row (p, SLICE (MOID (p)), 1, sp); A68_SP = sp; PUSH_REF (p, row); return GPROP (p); } //! @brief Coercion to REF [1 : 1, ..] MODE. PROP_T genie_rowing_ref_row_row (NODE_T * p) { A68_REF name; ADDR_T sp = A68_SP; MOID_T *dst = MOID (p), *src = MOID (SUB (p)); EXECUTE_UNIT (SUB (p)); STACK_DNS (p, MOID (SUB (p)), A68_FP); A68_SP = 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 PROP_T genie_rowing_ref_row_of_row (NODE_T * p) { A68_REF name; ADDR_T sp = A68_SP; MOID_T *dst = MOID (p), *src = MOID (SUB (p)); EXECUTE_UNIT (SUB (p)); STACK_DNS (p, MOID (SUB (p)), A68_FP); A68_SP = sp; name = genie_make_ref_row_of_row (p, dst, src, sp); PUSH_REF (p, name); return GPROP (p); } //! @brief Rowing coercion. PROP_T genie_rowing (NODE_T * p) { PROP_T self; if (IS_REF (MOID (p))) { // 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'. 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 == M_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 (M_SOUND)); owd = ADDRESS (&(DATA (w))); DATA (w) = heap_generator (p, M_SOUND_DATA, size); COPY (ADDRESS (&(DATA (w))), owd, size); return nsound; } else if (IS_STRUCT (m)) { // 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_UNION (m)) { // 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 *old_arr, *new_arr, *tarr; A68_TUPLE *old_tup, *new_tup, *ttup = NO_TUPLE, *op, *np, *tp; MOID_T *em = SUB (IS_FLEX (m) ? SUB (m) : m); int k, span; BOOL_T check_bounds; // Make new array. GET_DESCRIPTOR (old_arr, old_tup, DEREF (A68_REF, old)); nrow = heap_generator (p, m, DESCRIPTOR_SIZE (DIM (old_arr))); GET_DESCRIPTOR (new_arr, new_tup, &nrow); DIM (new_arr) = DIM (old_arr); MOID (new_arr) = MOID (old_arr); ELEM_SIZE (new_arr) = ELEM_SIZE (old_arr); SLICE_OFFSET (new_arr) = 0; FIELD_OFFSET (new_arr) = 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_ROW (m); } } for (span = 1, k = 0; k < DIM (old_arr); k++) { op = &old_tup[k]; np = &new_tup[k]; if (check_bounds) { tp = &ttup[k]; if (UPB (tp) >= LWB (tp) && UPB (op) >= LWB (op)) { if (UPB (tp) != UPB (op) || LWB (tp) != LWB (op)) { diagnostic (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 (new_arr) = heap_generator (p, em, ELEM_SIZE (new_arr)); } else { ARRAY (new_arr) = heap_generator (p, em, span * ELEM_SIZE (new_arr)); } // Copy the ghost element if there are no elements. if (span == 0) { if (IS_UNION (em)) { // UNION has formal members. } else if (HAS_ROWS (em)) { A68_REF old_ref, dst_ref, a68_clone; old_ref = ARRAY (old_arr); OFFSET (&old_ref) += ROW_ELEMENT (old_arr, 0); dst_ref = ARRAY (new_arr); OFFSET (&dst_ref) += ROW_ELEMENT (new_arr, 0); a68_clone = genie_clone (p, em, &ntmp, &old_ref); MOVE (ADDRESS (&dst_ref), ADDRESS (&a68_clone), SIZE (em)); } } else if (span > 0) { // The n-dimensional copier. BOOL_T done = A68_FALSE; initialise_internal_index (old_tup, DIM (old_arr)); initialise_internal_index (new_tup, DIM (new_arr)); while (!done) { A68_REF old_ref = ARRAY (old_arr); A68_REF dst_ref = ARRAY (new_arr); ADDR_T old_k = calculate_internal_index (old_tup, DIM (old_arr)); ADDR_T new_k = calculate_internal_index (new_tup, DIM (new_arr)); OFFSET (&old_ref) += ROW_ELEMENT (old_arr, old_k); OFFSET (&dst_ref) += ROW_ELEMENT (new_arr, new_k); if (HAS_ROWS (em)) { A68_REF a68_clone; a68_clone = genie_clone (p, em, &ntmp, &old_ref); MOVE (ADDRESS (&dst_ref), ADDRESS (&a68_clone), SIZE (em)); } else { MOVE (ADDRESS (&dst_ref), ADDRESS (&old_ref), SIZE (em)); } // Increase pointers. done = increment_internal_index (old_tup, DIM (old_arr)) | increment_internal_index (new_tup, DIM (new_arr)); } } 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 . 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_FLEX (m) ? 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) >= LWB (new_p) && UPB (old_p) >= LWB (old_p))) { if ((UPB (new_p) != UPB (old_p) || LWB (new_p) != LWB (old_p))) { diagnostic (A68_RUNTIME_ERROR, p, ERROR_DIFFERENT_BOUNDS); exit_genie (p, A68_RUNTIME_ERROR); } } span *= ROW_SIZE (new_p); } // Destination is an empty row, inspect if the source has elements. if (span == 0) { for (span = 1, k = 0; k < DIM (old_arr); k++) { span *= ROW_SIZE (old_p); } if (span > 0) { for (span = 1, k = 0; k < DIM (old_arr); k++) { new_tup[k] = old_tup[k]; } ARRAY (new_arr) = heap_generator (p, em, span * ELEM_SIZE (new_arr)); } } 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. 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_T) (INIT_MASK | IN_STACK_MASK); OFFSET (&stack) = A68_SP; REF_HANDLE (&stack) = (A68_HANDLE *) & nil_handle; src = DEREF (A68_REF, &stack); if (IS_ROW (srcm) && !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 Strcmp for qsort. int qstrcmp (const void *a, const void *b) { return strcmp (*(char *const *) a, *(char *const *) b); } //! @brief Sort row of string. 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 = A68_SP; CHECK_REF (p, z, M_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 **) a68_alloc ((size_t) (size * (int) sizeof (char *)), __func__, __LINE__); if (ptrs == NO_VAR) { diagnostic (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, M_STRING); len = A68_ALIGN (a68_string_size (p, ref) + 1); if (A68_SP + len > A68 (expr_stack_limit)) { diagnostic (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. NEW_ROW_1D (z, row, arrn, tupn, M_ROW_STRING, M_STRING, size); base_ref = DEREF (A68_REF, &row); for (k = 0; k < size; k++) { base_ref[k] = c_to_a_string (p, ptrs[k], DEFAULT_WIDTH); } a68_free (ptrs); A68_SP = pop_sp; PUSH_REF (p, z); } else { // This is how we sort an empty row of strings ... A68_SP = pop_sp; PUSH_REF (p, empty_row (p, M_ROW_STRING)); } } //! @brief Construct a descriptor "ref_new" for a trim of "ref_old". void genie_trimmer (NODE_T * p, BYTE_T * *ref_new, BYTE_T * *ref_old, INT_T * 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) += sizeof (A68_TUPLE); } else if (IS (p, TRIMMER)) { A68_INT k; NODE_T *q; INT_T 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 (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 (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. void genie_subscript (NODE_T * p, A68_TUPLE ** tup, INT_T * 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. 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_T 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 = A68_SP; for (sindex = 0, q = SEQUENCE (p); q != NO_NODE; t++, q = SEQUENCE (q)) { A68_INT *j = (A68_INT *) STACK_TOP; INT_T k; EXECUTE_UNIT (q); k = VALUE (j); if (k < LWB (t) || k > UPB (t)) { diagnostic (A68_RUNTIME_ERROR, q, ERROR_INDEX_OUT_OF_BOUNDS); exit_genie (q, A68_RUNTIME_ERROR); } sindex += (SPAN (t) * k - SHIFT (t)); A68_SP = 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. 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_REF (MOID (SUB (p)))); 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 = A68_SP; // 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_T 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_T k; EXECUTE_UNIT (q); k = VALUE (j); if (k < LWB (t) || k > UPB (t)) { diagnostic (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. A68_SP = 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_T offset; int dim; A68_REF z, ref_desc_copy; A68_ARRAY *old_des, *new_des; BYTE_T *ref_new, *ref_old; dim = DIM (DEFLEX (result_mode)); ref_desc_copy = heap_generator (p, MOID (p), DESCRIPTOR_SIZE (dim)); // 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_ALIGNED (A68_ARRAY); ref_new = ADDRESS (&ref_desc_copy) + SIZE_ALIGNED (A68_ARRAY); DIM (new_des) = dim; 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, ERROR_INTERNAL_CONSISTENCY, __func__); return self; } (void) primary; } //! @brief SELECTION from a value PROP_T genie_selection_value_quick (NODE_T * p) { NODE_T *selector = SUB (p); MOID_T *result_mode = MOID (selector); ADDR_T pop_sp = A68_SP; int size = SIZE (result_mode); INT_T offset = OFFSET (NODE_PACK (SUB (selector))); EXECUTE_UNIT (NEXT (selector)); A68_SP = pop_sp; if (offset > 0) { MOVE (STACK_TOP, STACK_OFFSET (offset), (unt) size); genie_check_initialisation (p, STACK_TOP, result_mode); } INCREMENT_STACK_POINTER (selector, size); return GPROP (p); } //! @brief SELECTION from a name 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. 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_REF (struct_mode)); SOURCE (&self) = p; UNIT (&self) = genie_selection; EXECUTE_UNIT (NEXT (selector)); // Multiple selections. if (selection_of_name && (IS_FLEX (SUB (struct_mode)) || IS_ROW (SUB (struct_mode)))) { 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 = DESCRIPTOR_SIZE (dims); row2 = heap_generator (selector, result_mode, desc_size); MOVE (ADDRESS (&row2), DEREF (BYTE_T, row1), (unt) 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_FLEX (struct_mode) || IS_ROW (struct_mode))) { A68_REF *row1, row2; int dims, desc_size; POP_ADDRESS (selector, row1, A68_REF); dims = DIM (DEFLEX (struct_mode)); desc_size = DESCRIPTOR_SIZE (dims); row2 = heap_generator (selector, result_mode, desc_size); MOVE (ADDRESS (&row2), DEREF (BYTE_T, row1), (unt) 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_STRUCT (SUB (struct_mode))) { 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 (struct_mode)) { DECREMENT_STACK_POINTER (selector, SIZE (struct_mode)); MOVE (STACK_TOP, STACK_OFFSET (OFFSET (NODE_PACK (SUB (selector)))), (unt) 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. PROP_T genie_field_selection (NODE_T * p) { PROP_T self; ADDR_T pop_sp = A68_SP, pop_fp = A68_FP; 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_REF (m) && ISNT (SUB (m), STRUCT_SYMBOL)) { int size = SIZE (SUB (m)); A68_SP = 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, M_VOID, w, pop_sp, pop_fp); STACK_DNS (p, MOID (p), A68_FP); m = SUB (m); } else { coerce = A68_FALSE; } } if (IS_REF (m) && IS (SUB (m), STRUCT_SYMBOL)) { CHECK_REF (p, *z, m); OFFSET (z) += OFFSET (NODE_PACK (p)); } else if (IS_STRUCT (m)) { A68_SP = pop_sp; MOVE (STACK_TOP, STACK_OFFSET (OFFSET (NODE_PACK (p))), (unt) SIZE (result_mode)); INCREMENT_STACK_POINTER (p, SIZE (result_mode)); } } return self; } algol68g-3.1.2/src/a68g/rows.c0000644000175000017500000000716714361065320012566 00000000000000//! @file rows.c //! @author J. Marcel van der Veer // //! @section Copyright // // This file is part of Algol68G - an Algol 68 compiler-interpreter. // Copyright 2001-2023 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" #include "a68g-genie.h" #include "a68g-prelude.h" // Operators for ROWS. //! @brief OP ELEMS = (ROWS) INT 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, M_ROWS); GET_DESCRIPTOR (x, t, &z); PUSH_VALUE (p, get_row_size (t, DIM (x)), A68_INT); } //! @brief OP LWB = (ROWS) INT 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, M_ROWS); GET_DESCRIPTOR (x, t, &z); PUSH_VALUE (p, LWB (t), A68_INT); } //! @brief OP UPB = (ROWS) INT 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, M_ROWS); GET_DESCRIPTOR (x, t, &z); PUSH_VALUE (p, UPB (t), A68_INT); } //! @brief OP ELEMS = (INT, ROWS) INT 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, M_ROWS); POP_OBJECT (p, &k, A68_INT); GET_DESCRIPTOR (x, t, &z); if (VALUE (&k) < 1 || VALUE (&k) > DIM (x)) { diagnostic (A68_RUNTIME_ERROR, p, ERROR_INVALID_DIMENSION, (int) VALUE (&k)); exit_genie (p, A68_RUNTIME_ERROR); } u = &(t[VALUE (&k) - 1]); PUSH_VALUE (p, ROW_SIZE (u), A68_INT); } //! @brief OP LWB = (INT, ROWS) INT 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, M_ROWS); POP_OBJECT (p, &k, A68_INT); GET_DESCRIPTOR (x, t, &z); if (VALUE (&k) < 1 || VALUE (&k) > DIM (x)) { diagnostic (A68_RUNTIME_ERROR, p, ERROR_INVALID_DIMENSION, (int) VALUE (&k)); exit_genie (p, A68_RUNTIME_ERROR); } PUSH_VALUE (p, LWB (&(t[VALUE (&k) - 1])), A68_INT); } //! @brief OP UPB = (INT, ROWS) INT 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, M_ROWS); POP_OBJECT (p, &k, A68_INT); GET_DESCRIPTOR (x, t, &z); if (VALUE (&k) < 1 || VALUE (&k) > DIM (x)) { diagnostic (A68_RUNTIME_ERROR, p, ERROR_INVALID_DIMENSION, (int) VALUE (&k)); exit_genie (p, A68_RUNTIME_ERROR); } PUSH_VALUE (p, UPB (&(t[VALUE (&k) - 1])), A68_INT); } algol68g-3.1.2/src/a68g/options.c0000644000175000017500000011641014361065320013257 00000000000000//! @file options.c //! @author J. Marcel van der Veer // //! @section Copyright // // This file is part of Algol68G - an Algol 68 compiler-interpreter. // Copyright 2001-2023 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" #include "a68g-prelude.h" #include "a68g-mp.h" #include "a68g-genie.h" #include "a68g-options.h" #include "a68g-parser.h" // This code 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]. //! @brief Set default core size. void default_mem_sizes (int n) { #define SET_SIZE(m, n) {\ ABEND (OVER_2G (n), ERROR_OUT_OF_CORE_2G, __func__);\ (m) = (n);\ } if (n < 0) { n = 1; } SET_SIZE (A68 (frame_stack_size), 12 * n * MEGABYTE); SET_SIZE (A68 (expr_stack_size), 4 * n * MEGABYTE); SET_SIZE (A68 (heap_size), 32 * n * MEGABYTE); SET_SIZE (A68 (handle_pool_size), 16 * n * MEGABYTE); SET_SIZE (A68 (storage_overhead), MIN_MEM_SIZE); #undef SET_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", A68 (a68_cmd_name)) >= 0); f = a68_fopen (name, "r", new_name); if (f != NO_FILE) { while (!feof (f)) { if (fgets (A68 (input_line), BUFFER_SIZE, f) != NO_TEXT) { if (A68 (input_line)[strlen (A68 (input_line)) - 1] == NEWLINE_CHAR) { A68 (input_line)[strlen (A68 (input_line)) - 1] = NULL_CHAR; } isolate_options (A68 (input_line), NO_LINE); } } ASSERT (fclose (f) == 0); (void) set_options (OPTION_LIST (&A68_JOB), 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 (&A68_JOB), A68_FALSE); errno = 0; } } //! @brief Tokenise string 'p' that holds options. 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 (&A68_JOB)), q, line); } } } //! @brief Set default values for options. void default_options (MODULE_T * p) { OPTION_BACKTRACE (p) = A68_FALSE; OPTION_BRACKETS (p) = A68_FALSE; OPTION_CHECK_ONLY (p) = A68_FALSE; OPTION_CLOCK (p) = A68_FALSE; OPTION_COMPILE_CHECK (p) = A68_FALSE; OPTION_COMPILE (p) = A68_FALSE; OPTION_CROSS_REFERENCE (p) = A68_FALSE; OPTION_DEBUG (p) = A68_FALSE; OPTION_FOLD (p) = A68_FALSE; OPTION_INDENT (p) = 2; OPTION_KEEP (p) = A68_FALSE; OPTION_LICENSE (p) = A68_FALSE; OPTION_MOID_LISTING (p) = A68_FALSE; OPTION_NODEMASK (p) = (STATUS_MASK_T) (ASSERT_MASK | SOURCE_MASK); OPTION_NO_WARNINGS (p) = A68_FALSE; OPTION_OPT_LEVEL (p) = NO_OPTIMISE; 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; set_long_mp_digits (0); } //! @brief Error handler for options. void option_error (LINE_T * l, char *option, char *info) { ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "%s", option) >= 0); if (info != NO_TEXT) { ASSERT (snprintf (A68 (edit_line), SNPRINTF_SIZE, "*error: %s option \"%s\"", info, A68 (output_line)) >= 0); } else { ASSERT (snprintf (A68 (edit_line), SNPRINTF_SIZE, "*error: in option \"%s\"", A68 (output_line)) >= 0); } scan_error (l, NO_TEXT, A68 (edit_line)); } //! @brief Strip minus preceeding a string. 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. 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_ALIGNED (OPTION_LIST_T)); SCAN (*l) = SOURCE_SCAN (&A68_JOB); 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 Free an option list. void free_option_list (OPTION_LIST_T * l) { if (l != NO_OPTION_LIST) { free_option_list (NEXT (l)); a68_free (STR (l)); a68_free (l); } } //! @brief Initialise option handler. void init_options (void) { A68 (options) = (OPTIONS_T *) a68_alloc ((size_t) SIZE_ALIGNED (OPTIONS_T), __func__, __LINE__); OPTION_LIST (&A68_JOB) = NO_OPTION_LIST; } //! @brief Test equality of p and q, upper case letters in q are mandatory. static inline BOOL_T eq (char *p, char *q) { // Upper case letters in 'q' are mandatory, lower case must match. if (OPTION_PRAGMAT_SEMA (&A68_JOB)) { return match_string (p, q, '='); } else { return A68_FALSE; } } //! @brief Process echoes gathered in the option list. void prune_echoes (OPTION_LIST_T * i) { while (i != NO_OPTION_LIST) { if (SCAN (i) == SOURCE_SCAN (&A68_JOB)) { char *p = strip_sign (STR (i)); // ECHO echoes a string. if (eq (p, "ECHO")) { { char *car = strchr (p, '='); if (car != NO_TEXT) { io_close_tty_line (); ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "%s", &car[1]) >= 0); WRITE (STDOUT_FILENO, A68 (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 (A68 (output_line), SNPRINTF_SIZE, "%s", STR (i)) >= 0); WRITE (STDOUT_FILENO, A68 (output_line)); } } } } } a68_free (p); } if (i != NO_OPTION_LIST) { FORWARD (i); } } } //! @brief Translate integral option argument. 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_T k, mult = 1; *error = A68_FALSE; // Fetch argument. car = 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; errno = 0; 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 (OVER_2G ((REAL_T) k * (REAL_T) mult)) { errno = ERANGE; option_error (start_l, start_c, ERROR_OVER_2G); } return k * mult; } } //! @brief Process options gathered in the option list. 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; errno = 0; 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)); char *stale = p; if (!minus_sign && eq (p, "#")) { ; } else if (!minus_sign && cmd_line) { // Item without '-'s is a filename. if (!name_set) { FILE_INITIAL_NAME (&A68_JOB) = new_string (p, NO_TEXT); name_set = A68_TRUE; } else { option_error (NO_LINE, start_c, "multiple source file names at"); } } else if (eq (p, "INCLUDE")) { // Preprocessor items stop option processing. 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; } else if (eq (p, "TECHnicalities")) { // TECH prints out some tech stuff. state_version (STDOUT_FILENO); ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "sizeof (A68_REF) = %u", (unt) sizeof (A68_REF)) >= 0); WRITELN (STDOUT_FILENO, A68 (output_line)); ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "sizeof (A68_PROCEDURE) = %u", (unt) sizeof (A68_PROCEDURE)) >= 0); WRITELN (STDOUT_FILENO, A68 (output_line)); #if (A68_LEVEL >= 3) ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "sizeof (DOUBLE_T) = %u", (unt) sizeof (DOUBLE_T)) >= 0); WRITELN (STDOUT_FILENO, A68 (output_line)); ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "sizeof (QUAD_WORD_T) = %u", (unt) sizeof (QUAD_WORD_T)) >= 0); WRITELN (STDOUT_FILENO, A68 (output_line)); #endif ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "sizeof (A68_INT) = %u", (unt) sizeof (A68_INT)) >= 0); WRITELN (STDOUT_FILENO, A68 (output_line)); ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "sizeof (A68_REAL) = %u", (unt) sizeof (A68_REAL)) >= 0); WRITELN (STDOUT_FILENO, A68 (output_line)); ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "sizeof (A68_BOOL) = %u", (unt) sizeof (A68_BOOL)) >= 0); WRITELN (STDOUT_FILENO, A68 (output_line)); ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "sizeof (A68_CHAR) = %u", (unt) sizeof (A68_CHAR)) >= 0); WRITELN (STDOUT_FILENO, A68 (output_line)); ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "sizeof (A68_BITS) = %u", (unt) sizeof (A68_BITS)) >= 0); WRITELN (STDOUT_FILENO, A68 (output_line)); #if (A68_LEVEL >= 3) ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "sizeof (A68_LONG_REAL) = %u", (unt) sizeof (A68_LONG_REAL)) >= 0); WRITELN (STDOUT_FILENO, A68 (output_line)); #else ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "sizeof (A68_LONG_REAL) = %u", (unt) size_mp ()) >= 0); WRITELN (STDOUT_FILENO, A68 (output_line)); #endif ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "sizeof (A68_LONG_LONG_REAL) = %u", (unt) size_long_mp ()) >= 0); WRITELN (STDOUT_FILENO, A68 (output_line)); WRITELN (STDOUT_FILENO, ""); exit (EXIT_SUCCESS); } // 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 (&A68_JOB) = 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"); } } // NEED or LIBrary require the argument as environ. else if (eq (p, "NEED") || eq (p, "LIBrary")) { FORWARD (i); if (i != NO_OPTION_LIST && strcmp (STR (i), "=") == 0) { FORWARD (i); } if (i == NO_OPTION_LIST) { option_error (start_l, start_c, "missing argument in"); } else { char *q = strip_sign (STR (i)); if (eq (q, "MVS")) { WRITELN (STDOUT_FILENO, "mvs required - exiting graciously"); a68_exit (EXIT_SUCCESS); } if (eq (q, "mpfr")) { #if !defined (HAVE_GNU_MPFR) io_close_tty_line (); WRITE (STDOUT_FILENO, "GNU MPFR required - exiting graciously"); a68_exit (EXIT_SUCCESS); #endif } if (eq (q, "mathlib")) { #if !defined (HAVE_MATHLIB) io_close_tty_line (); WRITE (STDOUT_FILENO, "R mathlib required - exiting graciously"); a68_exit (EXIT_SUCCESS); #endif } if (eq (q, "quadmath")) { #if !defined (HAVE_QUADMATH) io_close_tty_line (); WRITE (STDOUT_FILENO, "quadmath required - exiting graciously"); a68_exit (EXIT_SUCCESS); #endif } if (eq (q, "gsl")) { #if !defined (HAVE_GSL) io_close_tty_line (); WRITE (STDOUT_FILENO, "GNU Scientific Library required - exiting graciously"); a68_exit (EXIT_SUCCESS); #endif } if (eq (q, "plotutils")) { #if !defined (HAVE_GNU_PLOTUTILS) io_close_tty_line (); WRITE (STDOUT_FILENO, "plotutils required - exiting graciously"); a68_exit (EXIT_SUCCESS); #endif } if (eq (q, "curses")) { #if !defined (HAVE_CURSES) io_close_tty_line (); WRITE (STDOUT_FILENO, "curses required - exiting graciously"); a68_exit (EXIT_SUCCESS); #endif } if (eq (q, "ieee")) { #if !defined (HAVE_IEEE_754) io_close_tty_line (); WRITE (STDOUT_FILENO, "IEEE required - exiting graciously"); a68_exit (EXIT_SUCCESS); #endif } if (eq (q, "linux")) { #if !defined (BUILD_LINUX) io_close_tty_line (); WRITE (STDOUT_FILENO, "linux required - exiting graciously"); a68_exit (EXIT_SUCCESS); #endif } if (eq (q, "threads")) { #if !defined (BUILD_PARALLEL_CLAUSE) io_close_tty_line (); WRITE (STDOUT_FILENO, "threads required - exiting graciously"); a68_exit (EXIT_SUCCESS); #endif } if (eq (q, "postgresql")) { #if !defined (HAVE_POSTGRESQL) io_close_tty_line (); WRITE (STDOUT_FILENO, "postgresql required - exiting graciously"); a68_exit (EXIT_SUCCESS); #endif } if (eq (q, "compiler")) { #if !defined (BUILD_A68_COMPILER) io_close_tty_line (); WRITE (STDOUT_FILENO, "compiler required - exiting graciously"); a68_exit (EXIT_SUCCESS); #endif } #if !defined (BUILD_HTTP) if (eq (q, "http")) { io_close_tty_line (); WRITELN (STDOUT_FILENO, "HTTP support required - exiting graciously"); a68_exit (EXIT_SUCCESS); } #endif } } // 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 (&A68_JOB) = 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 (A68 (output_line), SNPRINTF_SIZE, "%s verification \"%s\" does not match script verification \"%s\"", A68 (a68_cmd_name), PACKAGE_STRING, STR (i)) >= 0); ABEND (strcmp (PACKAGE_STRING, STR (i)) != 0, new_string (A68 (output_line), __func__), "outdated 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"); } a68_exit (EXIT_SUCCESS); } // ECHO is treated later. else if (eq (p, "ECHO")) { if (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, ".a68", BUFFER_SIZE); f = a68_fopen (name, "w", new_name); ABEND (f == NO_FILE, ERROR_ACTION, __func__); errno = s_errno; if (eq (p, "Execute") || eq (p, "X")) { fprintf (f, "(%s)\n", STR (i)); } else { fprintf (f, "(print (((%s), new line)))\n", STR (i)); } ASSERT (fclose (f) == 0); FILE_INITIAL_NAME (&A68_JOB) = 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")) { A68 (heap_size) = k; } else if (eq (p, "HANDLES")) { A68 (handle_pool_size) = k; } else if (eq (p, "STACK")) { A68 (expr_stack_size) = k; } else if (eq (p, "FRAME")) { A68 (frame_stack_size) = k; } else if (eq (p, "OVERHEAD")) { A68 (storage_overhead) = k; } } } // COMPILE and NOCOMPILE switch on/off compilation. else if (eq (p, "Compile")) { #if defined (BUILD_LINUX) || defined (BUILD_BSD) OPTION_COMPILE (&A68_JOB) = A68_TRUE; OPTION_COMPILE_CHECK (&A68_JOB) = A68_TRUE; if (OPTION_OPT_LEVEL (&A68_JOB) < OPTIMISE_1) { OPTION_OPT_LEVEL (&A68_JOB) = OPTIMISE_1; } OPTION_RUN_SCRIPT (&A68_JOB) = A68_FALSE; #else option_error (start_l, start_c, "linux-only option"); #endif } else if (eq (p, "NOCompile") || eq (p, "NO-Compile")) { OPTION_COMPILE (&A68_JOB) = A68_FALSE; OPTION_RUN_SCRIPT (&A68_JOB) = A68_FALSE; } // OPTIMISE and NOOPTIMISE switch on/off optimisation. else if (eq (p, "NOOptimize") || eq (p, "NO-Optimize")) { OPTION_OPT_LEVEL (&A68_JOB) = NO_OPTIMISE; } else if (eq (p, "O0")) { OPTION_OPT_LEVEL (&A68_JOB) = NO_OPTIMISE; } else if (eq (p, "OG")) { OPTION_COMPILE_CHECK (&A68_JOB) = A68_TRUE; OPTION_OPT_LEVEL (&A68_JOB) = OPTIMISE_0; } else if (eq (p, "OPTimise") || eq (p, "OPTimize")) { OPTION_COMPILE_CHECK (&A68_JOB) = A68_TRUE; OPTION_OPT_LEVEL (&A68_JOB) = OPTIMISE_1; } else if (eq (p, "O") || eq (p, "O1")) { OPTION_COMPILE_CHECK (&A68_JOB) = A68_TRUE; OPTION_OPT_LEVEL (&A68_JOB) = OPTIMISE_1; } else if (eq (p, "O2")) { OPTION_COMPILE_CHECK (&A68_JOB) = A68_FALSE; OPTION_OPT_LEVEL (&A68_JOB) = OPTIMISE_2; } else if (eq (p, "O3")) { OPTION_COMPILE_CHECK (&A68_JOB) = A68_FALSE; OPTION_OPT_LEVEL (&A68_JOB) = OPTIMISE_3; } else if (eq (p, "Ofast")) { OPTION_COMPILE_CHECK (&A68_JOB) = A68_FALSE; OPTION_OPT_LEVEL (&A68_JOB) = OPTIMISE_FAST; } // ERROR-CHECK generates (some) runtime checks for O2, O3, Ofast. else if (eq (p, "ERRor-check")) { OPTION_COMPILE_CHECK (&A68_JOB) = A68_TRUE; } // RUN-SCRIPT runs a compiled .sh script. else if (eq (p, "RUN-SCRIPT")) { #if defined (BUILD_LINUX) || defined (BUILD_BSD) FORWARD (i); if (i != NO_OPTION_LIST) { if (!name_set) { FILE_INITIAL_NAME (&A68_JOB) = 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 (&A68_JOB) = A68_TRUE; OPTION_COMPILE (&A68_JOB) = A68_FALSE; #else option_error (start_l, start_c, "linux-only option"); #endif } // RUN-QUOTE-SCRIPT runs a compiled .sh script. else if (eq (p, "RUN-QUOTE-SCRIPT")) { #if defined (BUILD_LINUX) || defined (BUILD_BSD) FORWARD (i); if (i != NO_OPTION_LIST) { if (!name_set) { FILE_INITIAL_NAME (&A68_JOB) = 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 (&A68_JOB) = A68_TRUE; OPTION_STROPPING (&A68_JOB) = QUOTE_STROPPING; OPTION_COMPILE (&A68_JOB) = A68_FALSE; #else option_error (start_l, start_c, "linux-only option"); #endif } // RERUN re-uses an existing .so file. else if (eq (p, "RERUN")) { OPTION_COMPILE (&A68_JOB) = A68_FALSE; OPTION_RERUN (&A68_JOB) = A68_TRUE; if (OPTION_OPT_LEVEL (&A68_JOB) < OPTIMISE_1) { OPTION_OPT_LEVEL (&A68_JOB) = OPTIMISE_1; } } // KEEP and NOKEEP switch off/on object file deletion. else if (eq (p, "KEEP")) { OPTION_KEEP (&A68_JOB) = A68_TRUE; } else if (eq (p, "NOKEEP")) { OPTION_KEEP (&A68_JOB) = A68_FALSE; } else if (eq (p, "NO-KEEP")) { OPTION_KEEP (&A68_JOB) = A68_FALSE; } // BRACKETS extends Algol 68 syntax for brackets. else if (eq (p, "BRackets")) { OPTION_BRACKETS (&A68_JOB) = A68_TRUE; } // PRETTY and INDENT perform basic pretty printing. // This is meant for synthetic code. else if (eq (p, "PRETty-print")) { OPTION_PRETTY (&A68_JOB) = A68_TRUE; OPTION_CHECK_ONLY (&A68_JOB) = A68_TRUE; } else if (eq (p, "INDENT")) { OPTION_PRETTY (&A68_JOB) = A68_TRUE; OPTION_CHECK_ONLY (&A68_JOB) = A68_TRUE; } // FOLD performs constant folding in basic lay-out formatting.. else if (eq (p, "FOLD")) { OPTION_INDENT (&A68_JOB) = A68_TRUE; OPTION_FOLD (&A68_JOB) = A68_TRUE; OPTION_CHECK_ONLY (&A68_JOB) = A68_TRUE; } // REDUCTIONS gives parser reductions. else if (eq (p, "REDuctions")) { OPTION_REDUCTIONS (&A68_JOB) = A68_TRUE; } // QUOTESTROPPING sets stropping to quote stropping. else if (eq (p, "QUOTEstropping")) { OPTION_STROPPING (&A68_JOB) = QUOTE_STROPPING; } else if (eq (p, "QUOTE-stropping")) { OPTION_STROPPING (&A68_JOB) = QUOTE_STROPPING; } // UPPERSTROPPING sets stropping to upper stropping, which is nowadays the expected default. else if (eq (p, "UPPERstropping")) { OPTION_STROPPING (&A68_JOB) = UPPER_STROPPING; } else if (eq (p, "UPPER-stropping")) { OPTION_STROPPING (&A68_JOB) = UPPER_STROPPING; } // CHECK and NORUN just check for syntax. else if (eq (p, "CHeck") || eq (p, "NORun") || eq (p, "NO-Run")) { OPTION_CHECK_ONLY (&A68_JOB) = A68_TRUE; } // CLOCK times program execution. else if (eq (p, "CLock")) { OPTION_CLOCK (&A68_JOB) = A68_TRUE; } // RUN overrides NORUN. else if (eq (p, "RUN")) { OPTION_RUN (&A68_JOB) = A68_TRUE; } // MONITOR or DEBUG invokes the debugger at runtime errors. else if (eq (p, "MONitor") || eq (p, "DEBUG")) { OPTION_DEBUG (&A68_JOB) = A68_TRUE; } // REGRESSION is an option that sets preferences when running the test suite - undocumented option. else if (eq (p, "REGRESSION")) { OPTION_NO_WARNINGS (&A68_JOB) = A68_FALSE; OPTION_PORTCHECK (&A68_JOB) = A68_TRUE; OPTION_REGRESSION_TEST (&A68_JOB) = A68_TRUE; OPTION_TIME_LIMIT (&A68_JOB) = 300; OPTION_KEEP (&A68_JOB) = A68_TRUE; A68 (term_width) = MAX_TERM_WIDTH; } // LICense states the license else if (eq (p, "LICense")) { OPTION_LICENSE (&A68_JOB) = A68_TRUE; } // NOWARNINGS switches unsuppressible warnings off. else if (eq (p, "NOWarnings")) { OPTION_NO_WARNINGS (&A68_JOB) = A68_TRUE; } else if (eq (p, "NO-Warnings")) { OPTION_NO_WARNINGS (&A68_JOB) = A68_TRUE; } // QUIET switches all warnings off. else if (eq (p, "Quiet")) { OPTION_QUIET (&A68_JOB) = A68_TRUE; } // WARNINGS switches warnings on. else if (eq (p, "Warnings")) { OPTION_NO_WARNINGS (&A68_JOB) = A68_FALSE; } // NOPORTCHECK switches portcheck off. else if (eq (p, "NOPORTcheck")) { OPTION_PORTCHECK (&A68_JOB) = A68_FALSE; } else if (eq (p, "NO-PORTcheck")) { OPTION_PORTCHECK (&A68_JOB) = A68_FALSE; } // PORTCHECK switches portcheck on. else if (eq (p, "PORTcheck")) { OPTION_PORTCHECK (&A68_JOB) = A68_TRUE; } // PEDANTIC switches portcheck and warnings on. else if (eq (p, "PEDANTIC")) { OPTION_PORTCHECK (&A68_JOB) = A68_TRUE; OPTION_NO_WARNINGS (&A68_JOB) = A68_FALSE; } // PRAGMATS and NOPRAGMATS switch on/off pragmat processing. else if (eq (p, "PRagmats")) { OPTION_PRAGMAT_SEMA (&A68_JOB) = A68_TRUE; } else if (eq (p, "NOPRagmats")) { OPTION_PRAGMAT_SEMA (&A68_JOB) = A68_FALSE; } else if (eq (p, "NO-PRagmats")) { OPTION_PRAGMAT_SEMA (&A68_JOB) = A68_FALSE; } // STRICT ignores A68G extensions to A68 syntax. else if (eq (p, "STRict")) { OPTION_STRICT (&A68_JOB) = A68_TRUE; OPTION_PORTCHECK (&A68_JOB) = A68_TRUE; } // VERBOSE in case you want to know what Algol68G is doing. else if (eq (p, "VERBose")) { OPTION_VERBOSE (&A68_JOB) = A68_TRUE; } // VERSION lists the current version at an appropriate time in the future. else if (eq (p, "Version")) { OPTION_VERSION (&A68_JOB) = A68_TRUE; } else if (eq (p, "MODular-arithmetic")) { OPTION_NODEMASK (&A68_JOB) |= MODULAR_MASK; } else if (eq (p, "NOMODular-arithmetic")) { OPTION_NODEMASK (&A68_JOB) &= ~MODULAR_MASK; } else if (eq (p, "NO-MODular-arithmetic")) { OPTION_NODEMASK (&A68_JOB) &= ~MODULAR_MASK; } // XREF and NOXREF switch on/off a cross reference. else if (eq (p, "XREF")) { OPTION_SOURCE_LISTING (&A68_JOB) = A68_TRUE; OPTION_CROSS_REFERENCE (&A68_JOB) = A68_TRUE; OPTION_NODEMASK (&A68_JOB) |= (CROSS_REFERENCE_MASK | SOURCE_MASK); } else if (eq (p, "NOXREF")) { OPTION_NODEMASK (&A68_JOB) &= ~(CROSS_REFERENCE_MASK | SOURCE_MASK); } else if (eq (p, "NO-Xref")) { OPTION_NODEMASK (&A68_JOB) &= ~(CROSS_REFERENCE_MASK | SOURCE_MASK); } // PRELUDELISTING cross references preludes, if they ever get implemented ... else if (eq (p, "PRELUDElisting")) { OPTION_SOURCE_LISTING (&A68_JOB) = A68_TRUE; OPTION_CROSS_REFERENCE (&A68_JOB) = A68_TRUE; OPTION_STATISTICS_LISTING (&A68_JOB) = A68_TRUE; OPTION_NODEMASK (&A68_JOB) |= (SOURCE_MASK | CROSS_REFERENCE_MASK); OPTION_STANDARD_PRELUDE_LISTING (&A68_JOB) = A68_TRUE; } // STATISTICS prints process statistics. else if (eq (p, "STatistics")) { OPTION_STATISTICS_LISTING (&A68_JOB) = A68_TRUE; } // TREE and NOTREE switch on/off printing of the syntax tree. This gets bulky!. else if (eq (p, "TREE")) { OPTION_SOURCE_LISTING (&A68_JOB) = A68_TRUE; OPTION_TREE_LISTING (&A68_JOB) = A68_TRUE; OPTION_NODEMASK (&A68_JOB) |= (TREE_MASK | SOURCE_MASK); } else if (eq (p, "NOTREE")) { OPTION_NODEMASK (&A68_JOB) ^= (TREE_MASK | SOURCE_MASK); } else if (eq (p, "NO-TREE")) { OPTION_NODEMASK (&A68_JOB) ^= (TREE_MASK | SOURCE_MASK); } // UNUSED indicates unused tags. else if (eq (p, "UNUSED")) { OPTION_UNUSED (&A68_JOB) = A68_TRUE; } // EXTENSIVE set of options for an extensive listing. else if (eq (p, "EXTensive")) { OPTION_SOURCE_LISTING (&A68_JOB) = A68_TRUE; OPTION_OBJECT_LISTING (&A68_JOB) = A68_TRUE; OPTION_TREE_LISTING (&A68_JOB) = A68_TRUE; OPTION_CROSS_REFERENCE (&A68_JOB) = A68_TRUE; OPTION_MOID_LISTING (&A68_JOB) = A68_TRUE; OPTION_STANDARD_PRELUDE_LISTING (&A68_JOB) = A68_TRUE; OPTION_STATISTICS_LISTING (&A68_JOB) = A68_TRUE; OPTION_UNUSED (&A68_JOB) = A68_TRUE; OPTION_NODEMASK (&A68_JOB) |= (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 (&A68_JOB) = A68_TRUE; OPTION_CROSS_REFERENCE (&A68_JOB) = A68_TRUE; OPTION_STATISTICS_LISTING (&A68_JOB) = A68_TRUE; OPTION_NODEMASK (&A68_JOB) |= (SOURCE_MASK | CROSS_REFERENCE_MASK); } // TTY send listing to standout. Remnant from my mainframe past. else if (eq (p, "TTY")) { OPTION_CROSS_REFERENCE (&A68_JOB) = A68_TRUE; OPTION_STATISTICS_LISTING (&A68_JOB) = A68_TRUE; OPTION_NODEMASK (&A68_JOB) |= (SOURCE_MASK | CROSS_REFERENCE_MASK); } // SOURCE and NOSOURCE print source lines. else if (eq (p, "SOURCE")) { OPTION_SOURCE_LISTING (&A68_JOB) = A68_TRUE; OPTION_NODEMASK (&A68_JOB) |= SOURCE_MASK; } else if (eq (p, "NOSOURCE")) { OPTION_NODEMASK (&A68_JOB) &= ~SOURCE_MASK; } else if (eq (p, "NO-SOURCE")) { OPTION_NODEMASK (&A68_JOB) &= ~SOURCE_MASK; } // OBJECT and NOOBJECT print object lines. else if (eq (p, "OBJECT")) { OPTION_OBJECT_LISTING (&A68_JOB) = A68_TRUE; } else if (eq (p, "NOOBJECT")) { OPTION_OBJECT_LISTING (&A68_JOB) = A68_FALSE; } else if (eq (p, "NO-OBJECT")) { OPTION_OBJECT_LISTING (&A68_JOB) = A68_FALSE; } // MOIDS prints an overview of moids used in the program. else if (eq (p, "MOIDS")) { OPTION_MOID_LISTING (&A68_JOB) = A68_TRUE; } // ASSERTIONS and NOASSERTIONS switch on/off the processing of assertions. else if (eq (p, "Assertions")) { OPTION_NODEMASK (&A68_JOB) |= ASSERT_MASK; } else if (eq (p, "NOAssertions")) { OPTION_NODEMASK (&A68_JOB) &= ~ASSERT_MASK; } else if (eq (p, "NO-Assertions")) { OPTION_NODEMASK (&A68_JOB) &= ~ASSERT_MASK; } // PRECISION sets the LONG LONG precision. else if (eq (p, "PRECision")) { BOOL_T error = A68_FALSE; int N = fetch_integral (p, &i, &error); int k = width_to_mp_digits (N); if (k <= 0 || error || errno > 0) { option_error (start_l, start_c, "invalid value in"); } else if (long_mp_digits () > 0 && long_mp_digits () != k) { option_error (start_l, start_c, "different precision was already specified in"); } else if (k > mp_digits ()) { set_long_mp_digits (k); } else { option_error (start_l, start_c, "attempt to set LONG LONG precision lower than LONG precision"); } } // BACKTRACE and NOBACKTRACE switch on/off stack backtracing. else if (eq (p, "BACKtrace")) { OPTION_BACKTRACE (&A68_JOB) = A68_TRUE; } else if (eq (p, "NOBACKtrace")) { OPTION_BACKTRACE (&A68_JOB) = A68_FALSE; } else if (eq (p, "NO-BACKtrace")) { OPTION_BACKTRACE (&A68_JOB) = A68_FALSE; } // BREAK and NOBREAK switch on/off tracing of the running program. else if (eq (p, "BReakpoint")) { OPTION_NODEMASK (&A68_JOB) |= BREAKPOINT_MASK; } else if (eq (p, "NOBReakpoint")) { OPTION_NODEMASK (&A68_JOB) &= ~BREAKPOINT_MASK; } else if (eq (p, "NO-BReakpoint")) { OPTION_NODEMASK (&A68_JOB) &= ~BREAKPOINT_MASK; } // TRACE and NOTRACE switch on/off tracing of the running program. else if (eq (p, "TRace")) { OPTION_TRACE (&A68_JOB) = A68_TRUE; OPTION_NODEMASK (&A68_JOB) |= BREAKPOINT_TRACE_MASK; } else if (eq (p, "NOTRace")) { OPTION_NODEMASK (&A68_JOB) &= ~BREAKPOINT_TRACE_MASK; } else if (eq (p, "NO-TRace")) { OPTION_NODEMASK (&A68_JOB) &= ~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 (&A68_JOB) = k; } } else { // Unrecognised. option_error (start_l, start_c, "unrecognised"); } a68_free (stale); } // 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); } algol68g-3.1.2/src/a68g/prelude-gsl.c0000644000175000017500000012132214361065320014005 00000000000000//! @file prelude-gsl.c //! @author J. Marcel van der Veer // //! @section Copyright // // This file is part of Algol68G - an Algol 68 compiler-interpreter. // Copyright 2001-2023 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" #include "a68g-optimiser.h" #include "a68g-prelude.h" #include "a68g-prelude-gsl.h" #include "a68g-transput.h" #include "a68g-mp.h" #include "a68g-parser.h" #include "a68g-physics.h" #include "a68g-double.h" #if defined (HAVE_GSL) void stand_gsl_sf (void) { a68_idf (A68_EXT, "airyai", A68_MCACHE (proc_real_real), genie_airy_ai_real); a68_idf (A68_EXT, "airyaiscaled", A68_MCACHE (proc_real_real), genie_airy_ai_scaled_real); a68_idf (A68_EXT, "airybi", A68_MCACHE (proc_real_real), genie_airy_bi_real); a68_idf (A68_EXT, "airybiscaled", A68_MCACHE (proc_real_real), genie_airy_bi_scaled_real); a68_idf (A68_EXT, "besselin0", A68_MCACHE (proc_real_real), genie_bessel_in0_real); a68_idf (A68_EXT, "besselin1", A68_MCACHE (proc_real_real), genie_bessel_in1_real); a68_idf (A68_EXT, "besselin0scaled", A68_MCACHE (proc_real_real), genie_bessel_in0_scaled_real); a68_idf (A68_EXT, "besselin1scaled", A68_MCACHE (proc_real_real), genie_bessel_in1_scaled_real); a68_idf (A68_EXT, "besseljn0", A68_MCACHE (proc_real_real), genie_bessel_jn0_real); a68_idf (A68_EXT, "besseljn1", A68_MCACHE (proc_real_real), genie_bessel_jn1_real); a68_idf (A68_EXT, "besselkn0", A68_MCACHE (proc_real_real), genie_bessel_kn0_real); a68_idf (A68_EXT, "besselkn1", A68_MCACHE (proc_real_real), genie_bessel_kn1_real); a68_idf (A68_EXT, "besselkn0scaled", A68_MCACHE (proc_real_real), genie_bessel_kn0_scaled_real); a68_idf (A68_EXT, "besselkn1scaled", A68_MCACHE (proc_real_real), genie_bessel_kn1_scaled_real); a68_idf (A68_EXT, "besselyn0", A68_MCACHE (proc_real_real), genie_bessel_yn0_real); a68_idf (A68_EXT, "besselyn1", A68_MCACHE (proc_real_real), genie_bessel_yn1_real); a68_idf (A68_EXT, "expinte1", A68_MCACHE (proc_real_real), genie_expint_e1_real); a68_idf (A68_EXT, "expintei", A68_MCACHE (proc_real_real), genie_expint_ei_real); a68_idf (A68_EXT, "dawson", A68_MCACHE (proc_real_real), genie_dawson_real); a68_idf (A68_EXT, "exprel", A68_MCACHE (proc_real_real), genie_exprel_real); a68_idf (A68_EXT, "betaincgsl", A68_MCACHE (proc_real_real_real_real), genie_beta_inc_real); a68_idf (A68_EXT, "poch", A68_MCACHE (proc_real_real_real), genie_poch_real); a68_idf (A68_EXT, "digamma", A68_MCACHE (proc_real_real), genie_digamma_real); a68_idf (A68_EXT, "airyaiderivative", A68_MCACHE (proc_real_real), genie_airy_ai_deriv_real); a68_idf (A68_EXT, "airyaideriv", A68_MCACHE (proc_real_real), genie_airy_ai_deriv_real); a68_idf (A68_EXT, "airyaiderivscaled", A68_MCACHE (proc_real_real), genie_airy_ai_deriv_scaled_real); a68_idf (A68_EXT, "airybiderivative", A68_MCACHE (proc_real_real), genie_airy_bi_deriv_real); a68_idf (A68_EXT, "airybideriv", A68_MCACHE (proc_real_real), genie_airy_bi_deriv_real); a68_idf (A68_EXT, "airybiderivscaled", A68_MCACHE (proc_real_real), genie_airy_bi_deriv_scaled_real); a68_idf (A68_EXT, "airyzeroaideriv", A68_MCACHE (proc_int_real), genie_airy_zero_ai_deriv_real); a68_idf (A68_EXT, "airyzeroai", A68_MCACHE (proc_int_real), genie_airy_zero_ai_real); a68_idf (A68_EXT, "airyzerobideriv", A68_MCACHE (proc_int_real), genie_airy_zero_bi_deriv_real); a68_idf (A68_EXT, "airyzerobi", A68_MCACHE (proc_int_real), genie_airy_zero_bi_real); a68_idf (A68_EXT, "anglerestrictpos", A68_MCACHE (proc_real_real), genie_angle_restrict_pos_real); a68_idf (A68_EXT, "anglerestrictsymm", A68_MCACHE (proc_real_real), genie_angle_restrict_symm_real); a68_idf (A68_EXT, "atanint", A68_MCACHE (proc_real_real), genie_atanint_real); a68_idf (A68_EXT, "besselil0scaled", A68_MCACHE (proc_real_real), genie_bessel_il0_scaled_real); a68_idf (A68_EXT, "besselil1scaled", A68_MCACHE (proc_real_real), genie_bessel_il1_scaled_real); a68_idf (A68_EXT, "besselil2scaled", A68_MCACHE (proc_real_real), genie_bessel_il2_scaled_real); a68_idf (A68_EXT, "besselilscaled", A68_MCACHE (proc_int_real_real), genie_bessel_il_scaled_real); a68_idf (A68_EXT, "besselilscaled", A68_MCACHE (proc_real_real), genie_bessel_il_scaled_real); a68_idf (A68_EXT, "besselin", A68_MCACHE (proc_int_real_real), genie_bessel_in_real); a68_idf (A68_EXT, "besselinscaled", A68_MCACHE (proc_int_real_real), genie_bessel_in_scaled_real); a68_idf (A68_EXT, "besselinscaled", A68_MCACHE (proc_real_real), genie_bessel_in_scaled_real); a68_idf (A68_EXT, "besselinu", A68_MCACHE (proc_real_real_real), genie_bessel_inu_real); a68_idf (A68_EXT, "besselinuscaled", A68_MCACHE (proc_real_real_real), genie_bessel_inu_scaled_real); a68_idf (A68_EXT, "besseljl0", A68_MCACHE (proc_real_real), genie_bessel_jl0_real); a68_idf (A68_EXT, "besseljl1", A68_MCACHE (proc_real_real), genie_bessel_jl1_real); a68_idf (A68_EXT, "besseljl2", A68_MCACHE (proc_real_real), genie_bessel_jl2_real); a68_idf (A68_EXT, "besseljl", A68_MCACHE (proc_int_real_real), genie_bessel_jl_real); a68_idf (A68_EXT, "besseljn", A68_MCACHE (proc_int_real_real), genie_bessel_jn_real); a68_idf (A68_EXT, "besselkl0scaled", A68_MCACHE (proc_real_real), genie_bessel_kl0_scaled_real); a68_idf (A68_EXT, "besselkl1scaled", A68_MCACHE (proc_real_real), genie_bessel_kl1_scaled_real); a68_idf (A68_EXT, "besselkl2scaled", A68_MCACHE (proc_real_real), genie_bessel_kl2_scaled_real); a68_idf (A68_EXT, "besselklscaled", A68_MCACHE (proc_int_real_real), genie_bessel_kl_scaled_real); a68_idf (A68_EXT, "besselklscaled", A68_MCACHE (proc_real_real), genie_bessel_kl_scaled_real); a68_idf (A68_EXT, "besselkn", A68_MCACHE (proc_int_real_real), genie_bessel_kn_real); a68_idf (A68_EXT, "besselknscaled", A68_MCACHE (proc_int_real_real), genie_bessel_kn_scaled_real); a68_idf (A68_EXT, "besselkn_scaled", A68_MCACHE (proc_real_real), genie_bessel_kn_scaled_real); a68_idf (A68_EXT, "besselknu", A68_MCACHE (proc_real_real_real), genie_bessel_knu_real); a68_idf (A68_EXT, "besselknuscaled", A68_MCACHE (proc_real_real), genie_bessel_knu_scaled_real); a68_idf (A68_EXT, "besselknuscaled", A68_MCACHE (proc_real_real_real), genie_bessel_knu_scaled_real); a68_idf (A68_EXT, "bessellnknu", A68_MCACHE (proc_real_real), genie_bessel_ln_knu_real); a68_idf (A68_EXT, "bessellnknu", A68_MCACHE (proc_real_real_real), genie_bessel_ln_knu_real); a68_idf (A68_EXT, "besselyl0", A68_MCACHE (proc_real_real), genie_bessel_yl0_real); a68_idf (A68_EXT, "besselyl1", A68_MCACHE (proc_real_real), genie_bessel_yl1_real); a68_idf (A68_EXT, "besselyl2", A68_MCACHE (proc_real_real), genie_bessel_yl2_real); a68_idf (A68_EXT, "besselyl", A68_MCACHE (proc_int_real_real), genie_bessel_yl_real); a68_idf (A68_EXT, "besselyn", A68_MCACHE (proc_int_real_real), genie_bessel_yn_real); a68_idf (A68_EXT, "besselynu", A68_MCACHE (proc_real_real_real), genie_bessel_ynu_real); a68_idf (A68_EXT, "besselzeroj0", A68_MCACHE (proc_int_real), genie_bessel_zero_jnu0_real); a68_idf (A68_EXT, "besselzeroj1", A68_MCACHE (proc_int_real), genie_bessel_zero_jnu1_real); a68_idf (A68_EXT, "besselzerojnu", A68_MCACHE (proc_int_real_real), genie_bessel_zero_jnu_real); a68_idf (A68_EXT, "chi", A68_MCACHE (proc_real_real), genie_chi_real); a68_idf (A68_EXT, "ci", A68_MCACHE (proc_real_real), genie_ci_real); a68_idf (A68_EXT, "clausen", A68_MCACHE (proc_real_real), genie_clausen_real); a68_idf (A68_EXT, "conicalp0", A68_MCACHE (proc_real_real_real), genie_conicalp_0_real); a68_idf (A68_EXT, "conicalp1", A68_MCACHE (proc_real_real_real), genie_conicalp_1_real); a68_idf (A68_EXT, "conicalpcylreg", A68_MCACHE (proc_int_real_real_real), genie_conicalp_cyl_reg_real); a68_idf (A68_EXT, "conicalphalf", A68_MCACHE (proc_real_real_real), genie_conicalp_half_real); a68_idf (A68_EXT, "conicalpmhalf", A68_MCACHE (proc_real_real_real), genie_conicalp_mhalf_real); a68_idf (A68_EXT, "conicalpsphreg", A68_MCACHE (proc_int_real_real_real), genie_conicalp_sph_reg_real); a68_idf (A68_EXT, "debye1", A68_MCACHE (proc_real_real), genie_debye_1_real); a68_idf (A68_EXT, "debye2", A68_MCACHE (proc_real_real), genie_debye_2_real); a68_idf (A68_EXT, "debye3", A68_MCACHE (proc_real_real), genie_debye_3_real); a68_idf (A68_EXT, "debye4", A68_MCACHE (proc_real_real), genie_debye_4_real); a68_idf (A68_EXT, "debye5", A68_MCACHE (proc_real_real), genie_debye_5_real); a68_idf (A68_EXT, "debye6", A68_MCACHE (proc_real_real), genie_debye_6_real); a68_idf (A68_EXT, "dilog", A68_MCACHE (proc_real_real), genie_dilog_real); a68_idf (A68_EXT, "doublefact", A68_MCACHE (proc_int_real), genie_doublefact_real); a68_idf (A68_EXT, "ellintd", A68_MCACHE (proc_real_real_real), genie_ellint_d_real); a68_idf (A68_EXT, "ellintecomp", A68_MCACHE (proc_real_real), genie_ellint_e_comp_real); a68_idf (A68_EXT, "ellinte", A68_MCACHE (proc_real_real_real), genie_ellint_e_real); a68_idf (A68_EXT, "ellintf", A68_MCACHE (proc_real_real_real), genie_ellint_f_real); a68_idf (A68_EXT, "ellintkcomp", A68_MCACHE (proc_real_real), genie_ellint_k_comp_real); a68_idf (A68_EXT, "ellintpcomp", A68_MCACHE (proc_real_real_real), genie_ellint_p_comp_real); a68_idf (A68_EXT, "ellintp", A68_MCACHE (proc_real_real_real_real), genie_ellint_p_real); a68_idf (A68_EXT, "ellintrc", A68_MCACHE (proc_real_real_real), genie_ellint_rc_real); a68_idf (A68_EXT, "ellintrd", A68_MCACHE (proc_real_real_real_real), genie_ellint_rd_real); a68_idf (A68_EXT, "ellintrf", A68_MCACHE (proc_real_real_real_real), genie_ellint_rf_real); a68_idf (A68_EXT, "ellintrj", A68_MCACHE (proc_real_real_real_real_real), genie_ellint_rj_real); a68_idf (A68_EXT, "etaint", A68_MCACHE (proc_int_real), genie_etaint_real); a68_idf (A68_EXT, "eta", A68_MCACHE (proc_real_real), genie_eta_real); a68_idf (A68_EXT, "expint3", A68_MCACHE (proc_real_real), genie_expint_3_real); a68_idf (A68_EXT, "expinte2", A68_MCACHE (proc_real_real), genie_expint_e2_real); a68_idf (A68_EXT, "expinten", A68_MCACHE (proc_int_real_real), genie_expint_en_real); a68_idf (A68_EXT, "expm1", A68_MCACHE (proc_real_real), genie_expm1_real); a68_idf (A68_EXT, "exprel2", A68_MCACHE (proc_real_real), genie_exprel_2_real); a68_idf (A68_EXT, "expreln", A68_MCACHE (proc_int_real_real), genie_exprel_n_real); a68_idf (A68_EXT, "fermidirac0", A68_MCACHE (proc_real_real), genie_fermi_dirac_0_real); a68_idf (A68_EXT, "fermidirac1", A68_MCACHE (proc_real_real), genie_fermi_dirac_1_real); a68_idf (A68_EXT, "fermidirac2", A68_MCACHE (proc_real_real), genie_fermi_dirac_2_real); a68_idf (A68_EXT, "fermidirac3half", A68_MCACHE (proc_real_real), genie_fermi_dirac_3half_real); a68_idf (A68_EXT, "fermidirachalf", A68_MCACHE (proc_real_real), genie_fermi_dirac_half_real); a68_idf (A68_EXT, "fermidiracinc0", A68_MCACHE (proc_real_real_real), genie_fermi_dirac_inc_0_real); a68_idf (A68_EXT, "fermidiracint", A68_MCACHE (proc_int_real_real), genie_fermi_dirac_int_real); a68_idf (A68_EXT, "fermidiracm1", A68_MCACHE (proc_real_real), genie_fermi_dirac_m1_real); a68_idf (A68_EXT, "fermidiracmhalf", A68_MCACHE (proc_real_real), genie_fermi_dirac_mhalf_real); a68_idf (A68_EXT, "gammaincgsl", A68_MCACHE (proc_real_real_real), genie_gamma_inc_real); a68_idf (A68_EXT, "gammaincp", A68_MCACHE (proc_real_real_real), genie_gamma_inc_p_real); a68_idf (A68_EXT, "gammaincq", A68_MCACHE (proc_real_real_real), genie_gamma_inc_q_real); a68_idf (A68_EXT, "gammainv", A68_MCACHE (proc_real_real), genie_gammainv_real); a68_idf (A68_EXT, "gammastar", A68_MCACHE (proc_real_real), genie_gammastar_real); a68_idf (A68_EXT, "gegenpoly1real", A68_MCACHE (proc_real_real_real), genie_gegenpoly_1_real); a68_idf (A68_EXT, "gegenpoly2real", A68_MCACHE (proc_real_real_real), genie_gegenpoly_2_real); a68_idf (A68_EXT, "gegenpoly3real", A68_MCACHE (proc_real_real_real), genie_gegenpoly_3_real); a68_idf (A68_EXT, "gegenpolynreal", A68_MCACHE (proc_real_real_real), genie_gegenpoly_n_real); a68_idf (A68_EXT, "hermitefunc", A68_MCACHE (proc_int_real_real), genie_hermite_func_real); a68_idf (A68_EXT, "hypot", A68_MCACHE (proc_real_real_real), genie_hypot_real); a68_idf (A68_EXT, "hzeta", A68_MCACHE (proc_real_real_real), genie_hzeta_real); a68_idf (A68_EXT, "laguerre1real", A68_MCACHE (proc_real_real_real), genie_laguerre_1_real); a68_idf (A68_EXT, "laguerre2real", A68_MCACHE (proc_real_real_real), genie_laguerre_2_real); a68_idf (A68_EXT, "laguerre3real", A68_MCACHE (proc_real_real_real), genie_laguerre_3_real); a68_idf (A68_EXT, "laguerrenreal", A68_MCACHE (proc_real_real_real), genie_laguerre_n_real); a68_idf (A68_EXT, "lambertw0", A68_MCACHE (proc_real_real), genie_lambert_w0_real); a68_idf (A68_EXT, "lambertwm1", A68_MCACHE (proc_real_real), genie_lambert_wm1_real); a68_idf (A68_EXT, "legendreh3d0", A68_MCACHE (proc_real_real_real), genie_legendre_h3d_0_real); a68_idf (A68_EXT, "legendreh3d1", A68_MCACHE (proc_real_real_real), genie_legendre_h3d_1_real); a68_idf (A68_EXT, "legendreh3d", A68_MCACHE (proc_int_real_real_real), genie_legendre_H3d_real); a68_idf (A68_EXT, "legendrep1", A68_MCACHE (proc_real_real), genie_legendre_p1_real); a68_idf (A68_EXT, "legendrep2", A68_MCACHE (proc_real_real), genie_legendre_p2_real); a68_idf (A68_EXT, "legendrep3", A68_MCACHE (proc_real_real), genie_legendre_p3_real); a68_idf (A68_EXT, "legendrepl", A68_MCACHE (proc_int_real_real), genie_legendre_pl_real); a68_idf (A68_EXT, "legendreq0", A68_MCACHE (proc_real_real), genie_legendre_q0_real); a68_idf (A68_EXT, "legendreq1", A68_MCACHE (proc_real_real), genie_legendre_q1_real); a68_idf (A68_EXT, "legendreql", A68_MCACHE (proc_int_real_real), genie_legendre_ql_real); a68_idf (A68_EXT, "lncosh", A68_MCACHE (proc_real_real), genie_lncosh_real); a68_idf (A68_EXT, "lndoublefact", A68_MCACHE (proc_int_real), genie_lndoublefact_real); a68_idf (A68_EXT, "lnpoch", A68_MCACHE (proc_real_real_real), genie_lnpoch_real); a68_idf (A68_EXT, "lnsinh", A68_MCACHE (proc_real_real), genie_lnsinh_real); a68_idf (A68_EXT, "ln1plusxmx", A68_MCACHE (proc_real_real), genie_log_1plusx_mx_real); a68_idf (A68_EXT, "ln1plusx", A68_MCACHE (proc_real_real), genie_log_1plusx_real); a68_idf (A68_EXT, "lnabs", A68_MCACHE (proc_real_real), genie_log_abs_real); a68_idf (A68_EXT, "pochrel", A68_MCACHE (proc_real_real_real), genie_pochrel_real); a68_idf (A68_EXT, "psi1int", A68_MCACHE (proc_int_real), genie_psi_1_int_real); a68_idf (A68_EXT, "psi1piy", A68_MCACHE (proc_real_real), genie_psi_1piy_real); a68_idf (A68_EXT, "psi1", A68_MCACHE (proc_real_real), genie_psi_1_real); a68_idf (A68_EXT, "psiint", A68_MCACHE (proc_int_real), genie_psi_int_real); a68_idf (A68_EXT, "psin", A68_MCACHE (proc_int_real_real), genie_psi_n_real); a68_idf (A68_EXT, "psi", A68_MCACHE (proc_real_real), genie_psi_real); a68_idf (A68_EXT, "shi", A68_MCACHE (proc_real_real), genie_shi_real); a68_idf (A68_EXT, "sinc", A68_MCACHE (proc_real_real), genie_sinc_real); a68_idf (A68_EXT, "si", A68_MCACHE (proc_real_real), genie_si_real); a68_idf (A68_EXT, "synchrotron1", A68_MCACHE (proc_real_real), genie_synchrotron_1_real); a68_idf (A68_EXT, "synchrotron2", A68_MCACHE (proc_real_real), genie_synchrotron_2_real); a68_idf (A68_EXT, "taylorcoeff", A68_MCACHE (proc_int_real_real), genie_taylorcoeff_real); a68_idf (A68_EXT, "transport2", A68_MCACHE (proc_real_real), genie_transport_2_real); a68_idf (A68_EXT, "transport3", A68_MCACHE (proc_real_real), genie_transport_3_real); a68_idf (A68_EXT, "transport4", A68_MCACHE (proc_real_real), genie_transport_4_real); a68_idf (A68_EXT, "transport5", A68_MCACHE (proc_real_real), genie_transport_5_real); a68_idf (A68_EXT, "zetaint", A68_MCACHE (proc_int_real), genie_zeta_int_real); a68_idf (A68_EXT, "zetam1int", A68_MCACHE (proc_int_real), genie_zetam1_int_real); a68_idf (A68_EXT, "zetam1", A68_MCACHE (proc_real_real), genie_zetam1_real); a68_idf (A68_EXT, "zeta", A68_MCACHE (proc_real_real), genie_zeta_real); } void stand_gsl_linear_algebra (void) { MOID_T *m; // Vector and matrix monadic. m = a68_proc (M_ROW_REAL, M_ROW_REAL, NO_MOID); a68_op (A68_EXT, "+", m, genie_idle); a68_op (A68_EXT, "-", m, genie_vector_minus); m = a68_proc (M_ROW_ROW_REAL, M_ROW_ROW_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 (M_REAL, M_ROW_ROW_REAL, NO_MOID); a68_op (A68_EXT, "DET", m, genie_matrix_det); a68_op (A68_EXT, "TRACE", m, genie_matrix_trace); m = a68_proc (M_ROW_COMPLEX, M_ROW_COMPLEX, NO_MOID); a68_op (A68_EXT, "+", m, genie_idle); a68_op (A68_EXT, "-", m, genie_vector_complex_minus); m = a68_proc (M_ROW_ROW_COMPLEX, M_ROW_ROW_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 (M_COMPLEX, M_ROW_ROW_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 (M_BOOL, M_ROW_REAL, M_ROW_REAL, NO_MOID); a68_op (A68_EXT, "=", m, genie_vector_eq); a68_op (A68_EXT, "/=", m, genie_vector_ne); m = a68_proc (M_ROW_REAL, M_ROW_REAL, M_ROW_REAL, NO_MOID); a68_op (A68_EXT, "+", m, genie_vector_add); a68_op (A68_EXT, "-", m, genie_vector_sub); m = a68_proc (M_REF_ROW_REAL, M_REF_ROW_REAL, M_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 (M_BOOL, M_ROW_ROW_REAL, M_ROW_ROW_REAL, NO_MOID); a68_op (A68_EXT, "=", m, genie_matrix_eq); a68_op (A68_EXT, "/-", m, genie_matrix_ne); m = a68_proc (M_ROW_ROW_REAL, M_ROW_ROW_REAL, M_ROW_ROW_REAL, NO_MOID); a68_op (A68_EXT, "+", m, genie_matrix_add); a68_op (A68_EXT, "-", m, genie_matrix_sub); m = a68_proc (M_REF_ROW_ROW_REAL, M_REF_ROW_ROW_REAL, M_ROW_ROW_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 (M_BOOL, M_ROW_COMPLEX, M_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 (M_ROW_COMPLEX, M_ROW_COMPLEX, M_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 (M_REF_ROW_COMPLEX, M_REF_ROW_COMPLEX, M_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 (M_BOOL, M_ROW_ROW_COMPLEX, M_ROW_ROW_COMPLEX, NO_MOID); a68_op (A68_EXT, "=", m, genie_matrix_complex_eq); a68_op (A68_EXT, "/=", m, genie_matrix_complex_ne); m = a68_proc (M_ROW_ROW_COMPLEX, M_ROW_ROW_COMPLEX, M_ROW_ROW_COMPLEX, NO_MOID); a68_op (A68_EXT, "+", m, genie_matrix_complex_add); a68_op (A68_EXT, "-", m, genie_matrix_complex_sub); m = a68_proc (M_REF_ROW_ROW_COMPLEX, M_REF_ROW_ROW_COMPLEX, M_ROW_ROW_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 (M_ROW_REAL, M_REAL, M_ROW_REAL, NO_MOID); a68_op (A68_EXT, "*", m, genie_real_scale_vector); m = a68_proc (M_ROW_REAL, M_ROW_REAL, M_REAL, NO_MOID); a68_op (A68_EXT, "*", m, genie_vector_scale_real); a68_op (A68_EXT, "/", m, genie_vector_div_real); m = a68_proc (M_ROW_ROW_REAL, M_REAL, M_ROW_ROW_REAL, NO_MOID); a68_op (A68_EXT, "*", m, genie_real_scale_matrix); m = a68_proc (M_ROW_ROW_REAL, M_ROW_ROW_REAL, M_REAL, NO_MOID); a68_op (A68_EXT, "*", m, genie_matrix_scale_real); a68_op (A68_EXT, "/", m, genie_matrix_div_real); m = a68_proc (M_ROW_COMPLEX, M_COMPLEX, M_ROW_COMPLEX, NO_MOID); a68_op (A68_EXT, "*", m, genie_complex_scale_vector_complex); m = a68_proc (M_ROW_COMPLEX, M_ROW_COMPLEX, M_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 (M_ROW_ROW_COMPLEX, M_COMPLEX, M_ROW_ROW_COMPLEX, NO_MOID); a68_op (A68_EXT, "*", m, genie_complex_scale_matrix_complex); m = a68_proc (M_ROW_ROW_COMPLEX, M_ROW_ROW_COMPLEX, M_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 (M_REF_ROW_REAL, M_REF_ROW_REAL, M_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 (M_REF_ROW_ROW_REAL, M_REF_ROW_ROW_REAL, M_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 (M_REF_ROW_COMPLEX, M_REF_ROW_COMPLEX, M_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 (M_REF_ROW_ROW_COMPLEX, M_REF_ROW_ROW_COMPLEX, M_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 (M_ROW_REAL, M_ROW_REAL, M_ROW_ROW_REAL, NO_MOID); a68_op (A68_EXT, "*", m, genie_vector_times_matrix); m = a68_proc (M_ROW_COMPLEX, M_ROW_COMPLEX, M_ROW_ROW_COMPLEX, NO_MOID); a68_op (A68_EXT, "*", m, genie_vector_complex_times_matrix); // Matrix times vector or matrix. m = a68_proc (M_ROW_REAL, M_ROW_ROW_REAL, M_ROW_REAL, NO_MOID); a68_op (A68_EXT, "*", m, genie_matrix_times_vector); m = a68_proc (M_ROW_ROW_REAL, M_ROW_ROW_REAL, M_ROW_ROW_REAL, NO_MOID); a68_op (A68_EXT, "*", m, genie_matrix_times_matrix); m = a68_proc (M_ROW_COMPLEX, M_ROW_ROW_COMPLEX, M_ROW_COMPLEX, NO_MOID); a68_op (A68_EXT, "*", m, genie_matrix_complex_times_vector); m = a68_proc (M_ROW_ROW_COMPLEX, M_ROW_ROW_COMPLEX, M_ROW_ROW_COMPLEX, NO_MOID); a68_op (A68_EXT, "*", m, genie_matrix_complex_times_matrix); // Vector and matrix miscellaneous. m = a68_proc (M_ROW_REAL, M_ROW_REAL, NO_MOID); a68_idf (A68_EXT, "vectorecho", m, genie_vector_echo); m = a68_proc (M_ROW_ROW_REAL, M_ROW_ROW_REAL, NO_MOID); a68_idf (A68_EXT, "matrixecho", m, genie_matrix_echo); m = a68_proc (M_ROW_COMPLEX, M_ROW_COMPLEX, NO_MOID); a68_idf (A68_EXT, "complvectorecho", m, genie_vector_complex_echo); m = a68_proc (M_ROW_ROW_COMPLEX, M_ROW_ROW_COMPLEX, NO_MOID); a68_idf (A68_EXT, "complmatrixecho", m, genie_matrix_complex_echo); m = a68_proc (M_REAL, M_ROW_REAL, M_ROW_REAL, NO_MOID); a68_op (A68_EXT, "*", m, genie_vector_dot); m = a68_proc (M_COMPLEX, M_ROW_COMPLEX, M_ROW_COMPLEX, NO_MOID); a68_op (A68_EXT, "*", m, genie_vector_complex_dot); m = a68_proc (M_REAL, M_ROW_REAL, NO_MOID); a68_op (A68_EXT, "NORM", m, genie_vector_norm); m = a68_proc (M_REAL, M_ROW_COMPLEX, NO_MOID); a68_op (A68_EXT, "NORM", m, genie_vector_complex_norm); m = a68_proc (M_ROW_ROW_REAL, M_ROW_REAL, M_ROW_REAL, NO_MOID); a68_op (A68_EXT, "DYAD", m, genie_vector_dyad); m = a68_proc (M_ROW_ROW_COMPLEX, M_ROW_COMPLEX, M_ROW_COMPLEX, NO_MOID); a68_op (A68_EXT, "DYAD", m, genie_vector_complex_dyad); a68_prio ("DYAD", 3); // LU decomposition. m = a68_proc (M_ROW_ROW_REAL, M_ROW_ROW_REAL, M_REF_ROW_INT, M_REF_INT, NO_MOID); a68_idf (A68_EXT, "ludecomp", m, genie_matrix_lu); m = a68_proc (M_REAL, M_ROW_ROW_REAL, M_INT, NO_MOID); a68_idf (A68_EXT, "ludet", m, genie_matrix_lu_det); m = a68_proc (M_ROW_ROW_REAL, M_ROW_ROW_REAL, M_ROW_INT, NO_MOID); a68_idf (A68_EXT, "luinv", m, genie_matrix_lu_inv); m = a68_proc (M_ROW_REAL, M_ROW_ROW_REAL, M_ROW_ROW_REAL, M_ROW_INT, M_ROW_REAL, NO_MOID); a68_idf (A68_EXT, "lusolve", m, genie_matrix_lu_solve); m = a68_proc (M_ROW_ROW_COMPLEX, M_ROW_ROW_COMPLEX, M_REF_ROW_INT, M_REF_INT, NO_MOID); a68_idf (A68_EXT, "complexludecomp", m, genie_matrix_complex_lu); m = a68_proc (M_COMPLEX, M_ROW_ROW_COMPLEX, M_INT, NO_MOID); a68_idf (A68_EXT, "complexludet", m, genie_matrix_complex_lu_det); m = a68_proc (M_ROW_ROW_COMPLEX, M_ROW_ROW_COMPLEX, M_ROW_INT, NO_MOID); a68_idf (A68_EXT, "complexluinv", m, genie_matrix_complex_lu_inv); m = a68_proc (M_ROW_COMPLEX, M_ROW_ROW_COMPLEX, M_ROW_ROW_COMPLEX, M_ROW_INT, M_ROW_COMPLEX, NO_MOID); a68_idf (A68_EXT, "complexlusolve", m, genie_matrix_complex_lu_solve); // SVD decomposition. m = a68_proc (M_ROW_ROW_REAL, M_ROW_ROW_REAL, M_REF_ROW_ROW_REAL, M_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 (M_ROW_REAL, M_ROW_ROW_REAL, M_ROW_ROW_REAL, M_ROW_REAL, M_ROW_REAL, NO_MOID); a68_idf (A68_EXT, "svdsolve", m, genie_matrix_svd_solve); // QR decomposition. m = a68_proc (M_ROW_ROW_REAL, M_ROW_ROW_REAL, M_REF_ROW_REAL, NO_MOID); a68_idf (A68_EXT, "qrdecomp", m, genie_matrix_qr); m = a68_proc (M_ROW_REAL, M_ROW_ROW_REAL, M_ROW_REAL, M_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 (M_ROW_ROW_REAL, M_ROW_ROW_REAL, NO_MOID); a68_idf (A68_EXT, "choleskydecomp", m, genie_matrix_ch); m = a68_proc (M_ROW_REAL, M_ROW_ROW_REAL, M_ROW_REAL, NO_MOID); a68_idf (A68_EXT, "choleskysolve", m, genie_matrix_ch_solve); } void stand_gsl_constants (void) { // Constants ex GSL. a68_idf (A68_EXT, "cgsspeedoflight", M_REAL, genie_cgs_speed_of_light); a68_idf (A68_EXT, "cgsgravitationalconstant", M_REAL, genie_cgs_gravitational_constant); a68_idf (A68_EXT, "cgsplanckconstant", M_REAL, genie_cgs_planck_constant_h); a68_idf (A68_EXT, "cgsplanckconstantbar", M_REAL, genie_cgs_planck_constant_hbar); a68_idf (A68_EXT, "cgsastronomicalunit", M_REAL, genie_cgs_astronomical_unit); a68_idf (A68_EXT, "cgslightyear", M_REAL, genie_cgs_light_year); a68_idf (A68_EXT, "cgsparsec", M_REAL, genie_cgs_parsec); a68_idf (A68_EXT, "cgsgravaccel", M_REAL, genie_cgs_grav_accel); a68_idf (A68_EXT, "cgselectronvolt", M_REAL, genie_cgs_electron_volt); a68_idf (A68_EXT, "cgsmasselectron", M_REAL, genie_cgs_mass_electron); a68_idf (A68_EXT, "cgsmassmuon", M_REAL, genie_cgs_mass_muon); a68_idf (A68_EXT, "cgsmassproton", M_REAL, genie_cgs_mass_proton); a68_idf (A68_EXT, "cgsmassneutron", M_REAL, genie_cgs_mass_neutron); a68_idf (A68_EXT, "cgsrydberg", M_REAL, genie_cgs_rydberg); a68_idf (A68_EXT, "cgsboltzmann", M_REAL, genie_cgs_boltzmann); a68_idf (A68_EXT, "cgsbohrmagneton", M_REAL, genie_cgs_bohr_magneton); a68_idf (A68_EXT, "cgsnuclearmagneton", M_REAL, genie_cgs_nuclear_magneton); a68_idf (A68_EXT, "cgselectronmagneticmoment", M_REAL, genie_cgs_electron_magnetic_moment); a68_idf (A68_EXT, "cgsprotonmagneticmoment", M_REAL, genie_cgs_proton_magnetic_moment); a68_idf (A68_EXT, "cgsmolargas", M_REAL, genie_cgs_molar_gas); a68_idf (A68_EXT, "cgsstandardgasvolume", M_REAL, genie_cgs_standard_gas_volume); a68_idf (A68_EXT, "cgsminute", M_REAL, genie_cgs_minute); a68_idf (A68_EXT, "cgshour", M_REAL, genie_cgs_hour); a68_idf (A68_EXT, "cgsday", M_REAL, genie_cgs_day); a68_idf (A68_EXT, "cgsweek", M_REAL, genie_cgs_week); a68_idf (A68_EXT, "cgsinch", M_REAL, genie_cgs_inch); a68_idf (A68_EXT, "cgsfoot", M_REAL, genie_cgs_foot); a68_idf (A68_EXT, "cgsyard", M_REAL, genie_cgs_yard); a68_idf (A68_EXT, "cgsmile", M_REAL, genie_cgs_mile); a68_idf (A68_EXT, "cgsnauticalmile", M_REAL, genie_cgs_nautical_mile); a68_idf (A68_EXT, "cgsfathom", M_REAL, genie_cgs_fathom); a68_idf (A68_EXT, "cgsmil", M_REAL, genie_cgs_mil); a68_idf (A68_EXT, "cgspoint", M_REAL, genie_cgs_point); a68_idf (A68_EXT, "cgstexpoint", M_REAL, genie_cgs_texpoint); a68_idf (A68_EXT, "cgsmicron", M_REAL, genie_cgs_micron); a68_idf (A68_EXT, "cgsangstrom", M_REAL, genie_cgs_angstrom); a68_idf (A68_EXT, "cgshectare", M_REAL, genie_cgs_hectare); a68_idf (A68_EXT, "cgsacre", M_REAL, genie_cgs_acre); a68_idf (A68_EXT, "cgsbarn", M_REAL, genie_cgs_barn); a68_idf (A68_EXT, "cgsliter", M_REAL, genie_cgs_liter); a68_idf (A68_EXT, "cgsusgallon", M_REAL, genie_cgs_us_gallon); a68_idf (A68_EXT, "cgsquart", M_REAL, genie_cgs_quart); a68_idf (A68_EXT, "cgspint", M_REAL, genie_cgs_pint); a68_idf (A68_EXT, "cgscup", M_REAL, genie_cgs_cup); a68_idf (A68_EXT, "cgsfluidounce", M_REAL, genie_cgs_fluid_ounce); a68_idf (A68_EXT, "cgstablespoon", M_REAL, genie_cgs_tablespoon); a68_idf (A68_EXT, "cgsteaspoon", M_REAL, genie_cgs_teaspoon); a68_idf (A68_EXT, "cgscanadiangallon", M_REAL, genie_cgs_canadian_gallon); a68_idf (A68_EXT, "cgsukgallon", M_REAL, genie_cgs_uk_gallon); a68_idf (A68_EXT, "cgsmilesperhour", M_REAL, genie_cgs_miles_per_hour); a68_idf (A68_EXT, "cgskilometersperhour", M_REAL, genie_cgs_kilometers_per_hour); a68_idf (A68_EXT, "cgsknot", M_REAL, genie_cgs_knot); a68_idf (A68_EXT, "cgspoundmass", M_REAL, genie_cgs_pound_mass); a68_idf (A68_EXT, "cgsouncemass", M_REAL, genie_cgs_ounce_mass); a68_idf (A68_EXT, "cgston", M_REAL, genie_cgs_ton); a68_idf (A68_EXT, "cgsmetricton", M_REAL, genie_cgs_metric_ton); a68_idf (A68_EXT, "cgsukton", M_REAL, genie_cgs_uk_ton); a68_idf (A68_EXT, "cgstroyounce", M_REAL, genie_cgs_troy_ounce); a68_idf (A68_EXT, "cgscarat", M_REAL, genie_cgs_carat); a68_idf (A68_EXT, "cgsunifiedatomicmass", M_REAL, genie_cgs_unified_atomic_mass); a68_idf (A68_EXT, "cgsgramforce", M_REAL, genie_cgs_gram_force); a68_idf (A68_EXT, "cgspoundforce", M_REAL, genie_cgs_pound_force); a68_idf (A68_EXT, "cgskilopoundforce", M_REAL, genie_cgs_kilopound_force); a68_idf (A68_EXT, "cgspoundal", M_REAL, genie_cgs_poundal); a68_idf (A68_EXT, "cgscalorie", M_REAL, genie_cgs_calorie); a68_idf (A68_EXT, "cgsbtu", M_REAL, genie_cgs_btu); a68_idf (A68_EXT, "cgstherm", M_REAL, genie_cgs_therm); a68_idf (A68_EXT, "cgshorsepower", M_REAL, genie_cgs_horsepower); a68_idf (A68_EXT, "cgsbar", M_REAL, genie_cgs_bar); a68_idf (A68_EXT, "cgsstdatmosphere", M_REAL, genie_cgs_std_atmosphere); a68_idf (A68_EXT, "cgstorr", M_REAL, genie_cgs_torr); a68_idf (A68_EXT, "cgsmeterofmercury", M_REAL, genie_cgs_meter_of_mercury); a68_idf (A68_EXT, "cgsinchofmercury", M_REAL, genie_cgs_inch_of_mercury); a68_idf (A68_EXT, "cgsinchofwater", M_REAL, genie_cgs_inch_of_water); a68_idf (A68_EXT, "cgspsi", M_REAL, genie_cgs_psi); a68_idf (A68_EXT, "cgspoise", M_REAL, genie_cgs_poise); a68_idf (A68_EXT, "cgsstokes", M_REAL, genie_cgs_stokes); a68_idf (A68_EXT, "cgsfaraday", M_REAL, genie_cgs_faraday); a68_idf (A68_EXT, "cgselectroncharge", M_REAL, genie_cgs_electron_charge); a68_idf (A68_EXT, "cgsgauss", M_REAL, genie_cgs_gauss); a68_idf (A68_EXT, "cgsstilb", M_REAL, genie_cgs_stilb); a68_idf (A68_EXT, "cgslumen", M_REAL, genie_cgs_lumen); a68_idf (A68_EXT, "cgslux", M_REAL, genie_cgs_lux); a68_idf (A68_EXT, "cgsphot", M_REAL, genie_cgs_phot); a68_idf (A68_EXT, "cgsfootcandle", M_REAL, genie_cgs_footcandle); a68_idf (A68_EXT, "cgslambert", M_REAL, genie_cgs_lambert); a68_idf (A68_EXT, "cgsfootlambert", M_REAL, genie_cgs_footlambert); a68_idf (A68_EXT, "cgscurie", M_REAL, genie_cgs_curie); a68_idf (A68_EXT, "cgsroentgen", M_REAL, genie_cgs_roentgen); a68_idf (A68_EXT, "cgsrad", M_REAL, genie_cgs_rad); a68_idf (A68_EXT, "cgssolarmass", M_REAL, genie_cgs_solar_mass); a68_idf (A68_EXT, "cgsbohrradius", M_REAL, genie_cgs_bohr_radius); a68_idf (A68_EXT, "cgsnewton", M_REAL, genie_cgs_newton); a68_idf (A68_EXT, "cgsdyne", M_REAL, genie_cgs_dyne); a68_idf (A68_EXT, "cgsjoule", M_REAL, genie_cgs_joule); a68_idf (A68_EXT, "cgserg", M_REAL, genie_cgs_erg); a68_idf (A68_EXT, "mksaspeedoflight", M_REAL, genie_mks_speed_of_light); a68_idf (A68_EXT, "mksagravitationalconstant", M_REAL, genie_mks_gravitational_constant); a68_idf (A68_EXT, "mksaplanckconstant", M_REAL, genie_mks_planck_constant_h); a68_idf (A68_EXT, "mksaplanckconstantbar", M_REAL, genie_mks_planck_constant_hbar); a68_idf (A68_EXT, "mksavacuumpermeability", M_REAL, genie_mks_vacuum_permeability); a68_idf (A68_EXT, "mksaastronomicalunit", M_REAL, genie_mks_astronomical_unit); a68_idf (A68_EXT, "mksalightyear", M_REAL, genie_mks_light_year); a68_idf (A68_EXT, "mksaparsec", M_REAL, genie_mks_parsec); a68_idf (A68_EXT, "mksagravaccel", M_REAL, genie_mks_grav_accel); a68_idf (A68_EXT, "mksaelectronvolt", M_REAL, genie_mks_electron_volt); a68_idf (A68_EXT, "mksamasselectron", M_REAL, genie_mks_mass_electron); a68_idf (A68_EXT, "mksamassmuon", M_REAL, genie_mks_mass_muon); a68_idf (A68_EXT, "mksamassproton", M_REAL, genie_mks_mass_proton); a68_idf (A68_EXT, "mksamassneutron", M_REAL, genie_mks_mass_neutron); a68_idf (A68_EXT, "mksarydberg", M_REAL, genie_mks_rydberg); a68_idf (A68_EXT, "mksaboltzmann", M_REAL, genie_mks_boltzmann); a68_idf (A68_EXT, "mksabohrmagneton", M_REAL, genie_mks_bohr_magneton); a68_idf (A68_EXT, "mksanuclearmagneton", M_REAL, genie_mks_nuclear_magneton); a68_idf (A68_EXT, "mksaelectronmagneticmoment", M_REAL, genie_mks_electron_magnetic_moment); a68_idf (A68_EXT, "mksaprotonmagneticmoment", M_REAL, genie_mks_proton_magnetic_moment); a68_idf (A68_EXT, "mksamolargas", M_REAL, genie_mks_molar_gas); a68_idf (A68_EXT, "mksastandardgasvolume", M_REAL, genie_mks_standard_gas_volume); a68_idf (A68_EXT, "mksaminute", M_REAL, genie_mks_minute); a68_idf (A68_EXT, "mksahour", M_REAL, genie_mks_hour); a68_idf (A68_EXT, "mksaday", M_REAL, genie_mks_day); a68_idf (A68_EXT, "mksaweek", M_REAL, genie_mks_week); a68_idf (A68_EXT, "mksainch", M_REAL, genie_mks_inch); a68_idf (A68_EXT, "mksafoot", M_REAL, genie_mks_foot); a68_idf (A68_EXT, "mksayard", M_REAL, genie_mks_yard); a68_idf (A68_EXT, "mksamile", M_REAL, genie_mks_mile); a68_idf (A68_EXT, "mksanauticalmile", M_REAL, genie_mks_nautical_mile); a68_idf (A68_EXT, "mksafathom", M_REAL, genie_mks_fathom); a68_idf (A68_EXT, "mksamil", M_REAL, genie_mks_mil); a68_idf (A68_EXT, "mksapoint", M_REAL, genie_mks_point); a68_idf (A68_EXT, "mksatexpoint", M_REAL, genie_mks_texpoint); a68_idf (A68_EXT, "mksamicron", M_REAL, genie_mks_micron); a68_idf (A68_EXT, "mksaangstrom", M_REAL, genie_mks_angstrom); a68_idf (A68_EXT, "mksahectare", M_REAL, genie_mks_hectare); a68_idf (A68_EXT, "mksaacre", M_REAL, genie_mks_acre); a68_idf (A68_EXT, "mksabarn", M_REAL, genie_mks_barn); a68_idf (A68_EXT, "mksaliter", M_REAL, genie_mks_liter); a68_idf (A68_EXT, "mksausgallon", M_REAL, genie_mks_us_gallon); a68_idf (A68_EXT, "mksaquart", M_REAL, genie_mks_quart); a68_idf (A68_EXT, "mksapint", M_REAL, genie_mks_pint); a68_idf (A68_EXT, "mksacup", M_REAL, genie_mks_cup); a68_idf (A68_EXT, "mksafluidounce", M_REAL, genie_mks_fluid_ounce); a68_idf (A68_EXT, "mksatablespoon", M_REAL, genie_mks_tablespoon); a68_idf (A68_EXT, "mksateaspoon", M_REAL, genie_mks_teaspoon); a68_idf (A68_EXT, "mksacanadiangallon", M_REAL, genie_mks_canadian_gallon); a68_idf (A68_EXT, "mksaukgallon", M_REAL, genie_mks_uk_gallon); a68_idf (A68_EXT, "mksamilesperhour", M_REAL, genie_mks_miles_per_hour); a68_idf (A68_EXT, "mksakilometersperhour", M_REAL, genie_mks_kilometers_per_hour); a68_idf (A68_EXT, "mksaknot", M_REAL, genie_mks_knot); a68_idf (A68_EXT, "mksapoundmass", M_REAL, genie_mks_pound_mass); a68_idf (A68_EXT, "mksaouncemass", M_REAL, genie_mks_ounce_mass); a68_idf (A68_EXT, "mksaton", M_REAL, genie_mks_ton); a68_idf (A68_EXT, "mksametricton", M_REAL, genie_mks_metric_ton); a68_idf (A68_EXT, "mksaukton", M_REAL, genie_mks_uk_ton); a68_idf (A68_EXT, "mksatroyounce", M_REAL, genie_mks_troy_ounce); a68_idf (A68_EXT, "mksacarat", M_REAL, genie_mks_carat); a68_idf (A68_EXT, "mksaunifiedatomicmass", M_REAL, genie_mks_unified_atomic_mass); a68_idf (A68_EXT, "mksagramforce", M_REAL, genie_mks_gram_force); a68_idf (A68_EXT, "mksapoundforce", M_REAL, genie_mks_pound_force); a68_idf (A68_EXT, "mksakilopoundforce", M_REAL, genie_mks_kilopound_force); a68_idf (A68_EXT, "mksapoundal", M_REAL, genie_mks_poundal); a68_idf (A68_EXT, "mksacalorie", M_REAL, genie_mks_calorie); a68_idf (A68_EXT, "mksabtu", M_REAL, genie_mks_btu); a68_idf (A68_EXT, "mksatherm", M_REAL, genie_mks_therm); a68_idf (A68_EXT, "mksahorsepower", M_REAL, genie_mks_horsepower); a68_idf (A68_EXT, "mksabar", M_REAL, genie_mks_bar); a68_idf (A68_EXT, "mksastdatmosphere", M_REAL, genie_mks_std_atmosphere); a68_idf (A68_EXT, "mksatorr", M_REAL, genie_mks_torr); a68_idf (A68_EXT, "mksameterofmercury", M_REAL, genie_mks_meter_of_mercury); a68_idf (A68_EXT, "mksainchofmercury", M_REAL, genie_mks_inch_of_mercury); a68_idf (A68_EXT, "mksainchofwater", M_REAL, genie_mks_inch_of_water); a68_idf (A68_EXT, "mksapsi", M_REAL, genie_mks_psi); a68_idf (A68_EXT, "mksapoise", M_REAL, genie_mks_poise); a68_idf (A68_EXT, "mksastokes", M_REAL, genie_mks_stokes); a68_idf (A68_EXT, "mksafaraday", M_REAL, genie_mks_faraday); a68_idf (A68_EXT, "mksaelectroncharge", M_REAL, genie_mks_electron_charge); a68_idf (A68_EXT, "mksagauss", M_REAL, genie_mks_gauss); a68_idf (A68_EXT, "mksastilb", M_REAL, genie_mks_stilb); a68_idf (A68_EXT, "mksalumen", M_REAL, genie_mks_lumen); a68_idf (A68_EXT, "mksalux", M_REAL, genie_mks_lux); a68_idf (A68_EXT, "mksaphot", M_REAL, genie_mks_phot); a68_idf (A68_EXT, "mksafootcandle", M_REAL, genie_mks_footcandle); a68_idf (A68_EXT, "mksalambert", M_REAL, genie_mks_lambert); a68_idf (A68_EXT, "mksafootlambert", M_REAL, genie_mks_footlambert); a68_idf (A68_EXT, "mksacurie", M_REAL, genie_mks_curie); a68_idf (A68_EXT, "mksaroentgen", M_REAL, genie_mks_roentgen); a68_idf (A68_EXT, "mksarad", M_REAL, genie_mks_rad); a68_idf (A68_EXT, "mksasolarmass", M_REAL, genie_mks_solar_mass); a68_idf (A68_EXT, "mksabohrradius", M_REAL, genie_mks_bohr_radius); a68_idf (A68_EXT, "mksavacuumpermittivity", M_REAL, genie_mks_vacuum_permittivity); a68_idf (A68_EXT, "mksanewton", M_REAL, genie_mks_newton); a68_idf (A68_EXT, "mksadyne", M_REAL, genie_mks_dyne); a68_idf (A68_EXT, "mksajoule", M_REAL, genie_mks_joule); a68_idf (A68_EXT, "mksaerg", M_REAL, genie_mks_erg); a68_idf (A68_EXT, "numfinestructure", M_REAL, genie_num_fine_structure); a68_idf (A68_EXT, "numavogadro", M_REAL, genie_num_avogadro); a68_idf (A68_EXT, "numyotta", M_REAL, genie_num_yotta); a68_idf (A68_EXT, "numzetta", M_REAL, genie_num_zetta); a68_idf (A68_EXT, "numexa", M_REAL, genie_num_exa); a68_idf (A68_EXT, "numpeta", M_REAL, genie_num_peta); a68_idf (A68_EXT, "numtera", M_REAL, genie_num_tera); a68_idf (A68_EXT, "numgiga", M_REAL, genie_num_giga); a68_idf (A68_EXT, "nummega", M_REAL, genie_num_mega); a68_idf (A68_EXT, "numkilo", M_REAL, genie_num_kilo); a68_idf (A68_EXT, "nummilli", M_REAL, genie_num_milli); a68_idf (A68_EXT, "nummicro", M_REAL, genie_num_micro); a68_idf (A68_EXT, "numnano", M_REAL, genie_num_nano); a68_idf (A68_EXT, "numpico", M_REAL, genie_num_pico); a68_idf (A68_EXT, "numfemto", M_REAL, genie_num_femto); a68_idf (A68_EXT, "numatto", M_REAL, genie_num_atto); a68_idf (A68_EXT, "numzepto", M_REAL, genie_num_zepto); a68_idf (A68_EXT, "numyocto", M_REAL, genie_num_yocto); } void stand_gsl (void) { MOID_T *m; stand_gsl_sf (); stand_gsl_linear_algebra (); stand_gsl_constants (); // FFT. m = a68_proc (M_ROW_INT, M_INT, NO_MOID); a68_idf (A68_EXT, "primefactors", m, genie_prime_factors); m = a68_proc (M_ROW_COMPLEX, M_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 (M_ROW_COMPLEX, M_ROW_REAL, NO_MOID); a68_idf (A68_EXT, "fftforward", m, genie_fft_forward); m = a68_proc (M_ROW_REAL, M_ROW_COMPLEX, NO_MOID); a68_idf (A68_EXT, "fftbackward", m, genie_fft_backward); a68_idf (A68_EXT, "fftinverse", m, genie_fft_inverse); // Laplace. m = a68_proc (M_REAL, A68_MCACHE (proc_real_real), M_REAL, M_REF_REAL, NO_MOID); a68_idf (A68_EXT, "laplace", m, genie_laplace); } #endif algol68g-3.1.2/src/a68g/keywords.c0000644000175000017500000002113314361065320013430 00000000000000//! @file keywords.c //! @author J. Marcel van der Veer // //! @section Copyright // // This file is part of Algol68G - an Algol 68 compiler-interpreter. // Copyright 2001-2023 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" #include "a68g-prelude.h" #include "a68g-mp.h" #include "a68g-genie.h" #include "a68g-postulates.h" #include "a68g-parser.h" #include "a68g-options.h" #include "a68g-optimiser.h" #include "a68g-listing.h" //! @brief Add token to the token tree. 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_ALIGNED (TOKEN_T)); TEXT (*p) = z; LESS (*p) = MORE (*p) = NO_TOKEN; return *p; } //! @brief Find keyword, from token name. 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. 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; } } } //! @brief Add keyword to the tree. 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_ALIGNED (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 (&A68_JOB) == A68_FALSE) { add_keyword (&A68 (top_keyword), ENVIRON_SYMBOL, "ENVIRON"); add_keyword (&A68 (top_keyword), DOWNTO_SYMBOL, "DOWNTO"); add_keyword (&A68 (top_keyword), UNTIL_SYMBOL, "UNTIL"); add_keyword (&A68 (top_keyword), CLASS_SYMBOL, "CLASS"); add_keyword (&A68 (top_keyword), NEW_SYMBOL, "NEW"); add_keyword (&A68 (top_keyword), DIAGONAL_SYMBOL, "DIAG"); add_keyword (&A68 (top_keyword), TRANSPOSE_SYMBOL, "TRNSP"); add_keyword (&A68 (top_keyword), ROW_SYMBOL, "ROW"); add_keyword (&A68 (top_keyword), COLUMN_SYMBOL, "COL"); add_keyword (&A68 (top_keyword), CODE_SYMBOL, "CODE"); add_keyword (&A68 (top_keyword), EDOC_SYMBOL, "EDOC"); add_keyword (&A68 (top_keyword), ANDF_SYMBOL, "THEF"); add_keyword (&A68 (top_keyword), ORF_SYMBOL, "ELSF"); add_keyword (&A68 (top_keyword), ANDF_SYMBOL, "ANDTH"); add_keyword (&A68 (top_keyword), ORF_SYMBOL, "OREL"); add_keyword (&A68 (top_keyword), ANDF_SYMBOL, "ANDF"); add_keyword (&A68 (top_keyword), ORF_SYMBOL, "ORF"); add_keyword (&A68 (top_keyword), ALIF_SYMBOL, "ALIF"); } add_keyword (&A68 (top_keyword), POINT_SYMBOL, "."); add_keyword (&A68 (top_keyword), COMPLEX_SYMBOL, "COMPLEX"); add_keyword (&A68 (top_keyword), ACCO_SYMBOL, "{"); add_keyword (&A68 (top_keyword), OCCA_SYMBOL, "}"); add_keyword (&A68 (top_keyword), SOUND_SYMBOL, "SOUND"); add_keyword (&A68 (top_keyword), COLON_SYMBOL, ":"); add_keyword (&A68 (top_keyword), THEN_BAR_SYMBOL, "|"); add_keyword (&A68 (top_keyword), SUB_SYMBOL, "["); add_keyword (&A68 (top_keyword), BY_SYMBOL, "BY"); add_keyword (&A68 (top_keyword), OP_SYMBOL, "OP"); add_keyword (&A68 (top_keyword), COMMA_SYMBOL, ","); add_keyword (&A68 (top_keyword), AT_SYMBOL, "AT"); add_keyword (&A68 (top_keyword), PRIO_SYMBOL, "PRIO"); add_keyword (&A68 (top_keyword), STYLE_I_COMMENT_SYMBOL, "CO"); add_keyword (&A68 (top_keyword), END_SYMBOL, "END"); add_keyword (&A68 (top_keyword), GO_SYMBOL, "GO"); add_keyword (&A68 (top_keyword), TO_SYMBOL, "TO"); add_keyword (&A68 (top_keyword), ELSE_BAR_SYMBOL, "|:"); add_keyword (&A68 (top_keyword), THEN_SYMBOL, "THEN"); add_keyword (&A68 (top_keyword), TRUE_SYMBOL, "TRUE"); add_keyword (&A68 (top_keyword), PROC_SYMBOL, "PROC"); add_keyword (&A68 (top_keyword), FOR_SYMBOL, "FOR"); add_keyword (&A68 (top_keyword), GOTO_SYMBOL, "GOTO"); add_keyword (&A68 (top_keyword), WHILE_SYMBOL, "WHILE"); add_keyword (&A68 (top_keyword), IS_SYMBOL, ":=:"); add_keyword (&A68 (top_keyword), ASSIGN_TO_SYMBOL, "=:"); add_keyword (&A68 (top_keyword), COMPL_SYMBOL, "COMPL"); add_keyword (&A68 (top_keyword), FROM_SYMBOL, "FROM"); add_keyword (&A68 (top_keyword), BOLD_PRAGMAT_SYMBOL, "PRAGMAT"); add_keyword (&A68 (top_keyword), BOLD_COMMENT_SYMBOL, "COMMENT"); add_keyword (&A68 (top_keyword), DO_SYMBOL, "DO"); add_keyword (&A68 (top_keyword), STYLE_II_COMMENT_SYMBOL, "#"); add_keyword (&A68 (top_keyword), CASE_SYMBOL, "CASE"); add_keyword (&A68 (top_keyword), LOC_SYMBOL, "LOC"); add_keyword (&A68 (top_keyword), CHAR_SYMBOL, "CHAR"); add_keyword (&A68 (top_keyword), ISNT_SYMBOL, ":/=:"); add_keyword (&A68 (top_keyword), REF_SYMBOL, "REF"); add_keyword (&A68 (top_keyword), NIL_SYMBOL, "NIL"); add_keyword (&A68 (top_keyword), ASSIGN_SYMBOL, ":="); add_keyword (&A68 (top_keyword), FI_SYMBOL, "FI"); add_keyword (&A68 (top_keyword), FILE_SYMBOL, "FILE"); add_keyword (&A68 (top_keyword), PAR_SYMBOL, "PAR"); add_keyword (&A68 (top_keyword), ASSERT_SYMBOL, "ASSERT"); add_keyword (&A68 (top_keyword), OUSE_SYMBOL, "OUSE"); add_keyword (&A68 (top_keyword), IN_SYMBOL, "IN"); add_keyword (&A68 (top_keyword), LONG_SYMBOL, "LONG"); add_keyword (&A68 (top_keyword), SEMI_SYMBOL, ";"); add_keyword (&A68 (top_keyword), EMPTY_SYMBOL, "EMPTY"); add_keyword (&A68 (top_keyword), MODE_SYMBOL, "MODE"); add_keyword (&A68 (top_keyword), IF_SYMBOL, "IF"); add_keyword (&A68 (top_keyword), OD_SYMBOL, "OD"); add_keyword (&A68 (top_keyword), OF_SYMBOL, "OF"); add_keyword (&A68 (top_keyword), STRUCT_SYMBOL, "STRUCT"); add_keyword (&A68 (top_keyword), STYLE_I_PRAGMAT_SYMBOL, "PR"); add_keyword (&A68 (top_keyword), BUS_SYMBOL, "]"); add_keyword (&A68 (top_keyword), SKIP_SYMBOL, "SKIP"); add_keyword (&A68 (top_keyword), SHORT_SYMBOL, "SHORT"); add_keyword (&A68 (top_keyword), IS_SYMBOL, "IS"); add_keyword (&A68 (top_keyword), ESAC_SYMBOL, "ESAC"); add_keyword (&A68 (top_keyword), CHANNEL_SYMBOL, "CHANNEL"); add_keyword (&A68 (top_keyword), REAL_SYMBOL, "REAL"); add_keyword (&A68 (top_keyword), STRING_SYMBOL, "STRING"); add_keyword (&A68 (top_keyword), BOOL_SYMBOL, "BOOL"); add_keyword (&A68 (top_keyword), ISNT_SYMBOL, "ISNT"); add_keyword (&A68 (top_keyword), FALSE_SYMBOL, "FALSE"); add_keyword (&A68 (top_keyword), UNION_SYMBOL, "UNION"); add_keyword (&A68 (top_keyword), OUT_SYMBOL, "OUT"); add_keyword (&A68 (top_keyword), OPEN_SYMBOL, "("); add_keyword (&A68 (top_keyword), BEGIN_SYMBOL, "BEGIN"); add_keyword (&A68 (top_keyword), FLEX_SYMBOL, "FLEX"); add_keyword (&A68 (top_keyword), VOID_SYMBOL, "VOID"); add_keyword (&A68 (top_keyword), BITS_SYMBOL, "BITS"); add_keyword (&A68 (top_keyword), ELSE_SYMBOL, "ELSE"); add_keyword (&A68 (top_keyword), EXIT_SYMBOL, "EXIT"); add_keyword (&A68 (top_keyword), HEAP_SYMBOL, "HEAP"); add_keyword (&A68 (top_keyword), INT_SYMBOL, "INT"); add_keyword (&A68 (top_keyword), BYTES_SYMBOL, "BYTES"); add_keyword (&A68 (top_keyword), PIPE_SYMBOL, "PIPE"); add_keyword (&A68 (top_keyword), FORMAT_SYMBOL, "FORMAT"); add_keyword (&A68 (top_keyword), SEMA_SYMBOL, "SEMA"); add_keyword (&A68 (top_keyword), CLOSE_SYMBOL, ")"); add_keyword (&A68 (top_keyword), AT_SYMBOL, "@"); add_keyword (&A68 (top_keyword), ELIF_SYMBOL, "ELIF"); add_keyword (&A68 (top_keyword), FORMAT_DELIMITER_SYMBOL, "$"); } algol68g-3.1.2/src/a68g/regex.c0000644000175000017500000002132614361065320012677 00000000000000//! @file regex.c //! @author J. Marcel van der Veer // //! @section Copyright // // This file is part of Algol68G - an Algol 68 compiler-interpreter. // Copyright 2001-2023 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" #include "a68g-genie.h" #include "a68g-prelude.h" #include "a68g-mp.h" #include "a68g-double.h" #include "a68g-transput.h" //! @brief grep in string (STRING, STRING, REF INT, REF INT) INT. int grep_in_string (char *pat, char *str, int *start, int *end) { 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 = a68_alloc ((size_t) (nmatch * SIZE_ALIGNED (regmatch_t)), __func__, __LINE__); 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]); } a68_free (matches); return 0; } //! @brief Return code for regex interface. void push_grep_rc (NODE_T * p, int rc) { switch (rc) { case 0: { PUSH_VALUE (p, 0, A68_INT); return; } case REG_NOMATCH: { PUSH_VALUE (p, 1, A68_INT); return; } case REG_ESPACE: { PUSH_VALUE (p, 3, A68_INT); return; } default: { PUSH_VALUE (p, 2, A68_INT); return; } } } //! @brief PROC grep in string = (STRING, STRING, REF INT, REF INT) INT 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), M_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 = a68_alloc ((size_t) (nmatch * SIZE_ALIGNED (regmatch_t)), __func__, __LINE__); if (nmatch > 0 && matches == NULL) { rc = 2; PUSH_VALUE (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; } a68_free (matches); push_grep_rc (p, 0); } //! @brief PROC grep in substring = (STRING, STRING, REF INT, REF INT) INT 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), M_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 = a68_alloc ((size_t) (nmatch * SIZE_ALIGNED (regmatch_t)), __func__, __LINE__); if (nmatch > 0 && matches == NULL) { rc = 2; PUSH_VALUE (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; } a68_free (matches); push_grep_rc (p, 0); } //! @brief PROC sub in string = (STRING, STRING, REF STRING) INT 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_VALUE (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 = a68_alloc ((size_t) (nmatch * SIZE_ALIGNED (regmatch_t)), __func__, __LINE__); if (nmatch > 0 && matches == NULL) { PUSH_VALUE (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++) { plusab_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++) { plusab_transput_buffer (p, REPLACE_BUFFER, txt[k]); } *DEREF (A68_REF, &ref_str) = c_to_a_string (p, get_transput_buffer (REPLACE_BUFFER), DEFAULT_WIDTH); a68_free (matches); push_grep_rc (p, 0); } algol68g-3.1.2/src/a68g/listing.c0000644000175000017500000005670314361065320013245 00000000000000//! @file listing.c //! @author J. Marcel van der Veer // //! @section Copyright // // This file is part of Algol68G - an Algol 68 compiler-interpreter. // Copyright 2001-2023 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" #include "a68g-prelude.h" #include "a68g-mp.h" #include "a68g-genie.h" #include "a68g-listing.h" #include "a68g-parser.h" #include "a68g-optimiser.h" // Routines for making a "fat" listing file. #define SHOW_EQ A68_FALSE //! @brief a68_print_short_mode. void a68_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 (A68 (output_line), SNPRINTF_SIZE, "%s", NSYMBOL (NODE (z))) >= 0); WRITE (f, A68 (output_line)); } else if (IS_REF (z) && IS (SUB (z), STANDARD)) { WRITE (f, "REF "); a68_print_short_mode (f, SUB (z)); } else if (IS (z, PROC_SYMBOL) && PACK (z) == NO_PACK && IS (SUB (z), STANDARD)) { WRITE (f, "PROC "); a68_print_short_mode (f, SUB (z)); } else { ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "#%d", NUMBER (z)) >= 0); WRITE (f, A68 (output_line)); } } //! @brief A68g_print_flat_mode. void a68_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 (A68 (output_line), SNPRINTF_SIZE, "%s", NSYMBOL (NODE (z))) >= 0); WRITE (f, A68 (output_line)); } else if (IS_REF (z)) { ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "REF ") >= 0); WRITE (f, A68 (output_line)); a68_print_short_mode (f, SUB (z)); } else if (IS (z, PROC_SYMBOL) && DIM (z) == 0) { ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "PROC ") >= 0); WRITE (f, A68 (output_line)); a68_print_short_mode (f, SUB (z)); } else if (IS_ROW (z)) { int i = DIM (z); WRITE (f, "["); while (--i) { WRITE (f, ", "); } WRITE (f, "] "); a68_print_short_mode (f, SUB (z)); } else { a68_print_short_mode (f, z); } } //! @brief Brief_fields_flat. void a68_print_short_pack (FILE_T f, PACK_T * pack) { if (pack != NO_PACK) { a68_print_short_mode (f, MOID (pack)); if (NEXT (pack) != NO_PACK) { ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, ", ") >= 0); WRITE (f, A68 (output_line)); a68_print_short_pack (f, NEXT (pack)); } } } //! @brief A68g_print_mode. void a68_print_mode (FILE_T f, MOID_T * z) { if (z != NO_MOID) { if (IS (z, STANDARD)) { a68_print_flat_mode (f, z); } else if (IS (z, INDICANT)) { WRITE (f, NSYMBOL (NODE (z))); } else if (z == M_COLLITEM) { WRITE (f, "\"COLLITEM\""); } else if (IS_REF (z)) { WRITE (f, "REF "); a68_print_flat_mode (f, SUB (z)); } else if (IS_FLEX (z)) { WRITE (f, "FLEX "); a68_print_flat_mode (f, SUB (z)); } else if (IS_ROW (z)) { int i = DIM (z); WRITE (f, "["); while (--i) { WRITE (f, ", "); } WRITE (f, "] "); a68_print_flat_mode (f, SUB (z)); } else if (IS_STRUCT (z)) { WRITE (f, "STRUCT ("); a68_print_short_pack (f, PACK (z)); WRITE (f, ")"); } else if (IS_UNION (z)) { WRITE (f, "UNION ("); a68_print_short_pack (f, PACK (z)); WRITE (f, ")"); } else if (IS (z, PROC_SYMBOL)) { WRITE (f, "PROC "); if (PACK (z) != NO_PACK) { WRITE (f, "("); a68_print_short_pack (f, PACK (z)); WRITE (f, ") "); } a68_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\" ("); a68_print_short_pack (f, PACK (z)); WRITE (f, ")"); } else if (IS (z, STOWED_MODE)) { WRITE (f, "\"STOWED\" ("); a68_print_short_pack (f, PACK (z)); WRITE (f, ")"); } } } //! @brief Print_mode_flat. void print_mode_flat (FILE_T f, MOID_T * m) { if (m != NO_MOID) { a68_print_mode (f, m); if (NODE (m) != NO_NODE && NUMBER (NODE (m)) > 0) { ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, " node %d", NUMBER (NODE (m))) >= 0); WRITE (f, A68 (output_line)); } if (EQUIVALENT_MODE (m) != NO_MOID) { ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, " equi #%d", NUMBER (EQUIVALENT (m))) >= 0); WRITE (f, A68 (output_line)); } if (SLICE (m) != NO_MOID) { ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, " slice #%d", NUMBER (SLICE (m))) >= 0); WRITE (f, A68 (output_line)); } if (TRIM (m) != NO_MOID) { ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, " trim #%d", NUMBER (TRIM (m))) >= 0); WRITE (f, A68 (output_line)); } if (ROWED (m) != NO_MOID) { ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, " rowed #%d", NUMBER (ROWED (m))) >= 0); WRITE (f, A68 (output_line)); } if (DEFLEXED (m) != NO_MOID) { ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, " deflex #%d", NUMBER (DEFLEXED (m))) >= 0); WRITE (f, A68 (output_line)); } if (MULTIPLE (m) != NO_MOID) { ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, " multiple #%d", NUMBER (MULTIPLE (m))) >= 0); WRITE (f, A68 (output_line)); } if (NAME (m) != NO_MOID) { ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, " name #%d", NUMBER (NAME (m))) >= 0); WRITE (f, A68 (output_line)); } if (USE (m)) { ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, " used") >= 0); WRITE (f, A68 (output_line)); } if (DERIVATE (m)) { ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, " derivate") >= 0); WRITE (f, A68 (output_line)); } if (SIZE (m) > 0) { ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, " size %d", SIZE (m)) >= 0); WRITE (f, A68 (output_line)); } if (HAS_ROWS (m)) { WRITE (f, " []"); } } } //! @brief Xref_tags. 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) == A68_STANDENV)) { WRITE (f, "\n "); ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "tag %d ", NUMBER (s)) >= 0); WRITE (f, A68 (output_line)); switch (a) { case IDENTIFIER: { a68_print_mode (f, MOID (s)); ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, " %s", NSYMBOL (NODE (s))) >= 0); WRITE (f, A68 (output_line)); break; } case INDICANT: { ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "indicant %s ", NSYMBOL (NODE (s))) >= 0); WRITE (f, A68 (output_line)); a68_print_mode (f, MOID (s)); break; } case PRIO_SYMBOL: { ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "priority %s %d", NSYMBOL (NODE (s)), PRIO (s)) >= 0); WRITE (f, A68 (output_line)); break; } case OP_SYMBOL: { ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "operator %s ", NSYMBOL (NODE (s))) >= 0); WRITE (f, A68 (output_line)); a68_print_mode (f, MOID (s)); break; } case LABEL: { ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "label %s", NSYMBOL (NODE (s))) >= 0); WRITE (f, A68 (output_line)); break; } case ANONYMOUS: { switch (PRIO (s)) { case ROUTINE_TEXT: { ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "routine text ") >= 0); break; } case FORMAT_TEXT: { ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "format text ") >= 0); break; } case FORMAT_IDENTIFIER: { ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "format item ") >= 0); break; } case COLLATERAL_CLAUSE: { ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "display ") >= 0); break; } case GENERATOR: { ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "generator ") >= 0); break; } } WRITE (f, A68 (output_line)); a68_print_mode (f, MOID (s)); break; } default: { ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "internal %d ", a) >= 0); WRITE (f, A68 (output_line)); a68_print_mode (f, MOID (s)); break; } } if (NODE (s) != NO_NODE && NUMBER (NODE (s)) > 0) { ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, ", node %d", NUMBER (NODE (s))) >= 0); WRITE (f, A68 (output_line)); } if (where_tag != NO_NODE && INFO (where_tag) != NO_NINFO && LINE (INFO (where_tag)) != NO_LINE) { ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, ", line %d", LINE_NUMBER (where_tag)) >= 0); WRITE (f, A68 (output_line)); } } } } //! @brief Xref_decs. 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. void xref1_moid (FILE_T f, MOID_T * p) { ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "\n #%d ", NUMBER (p)) >= 0); WRITE (f, A68 (output_line)); print_mode_flat (f, p); } //! @brief Moid_listing. void moid_listing (FILE_T f, MOID_T * m) { for (; m != NO_MOID; FORWARD (m)) { xref1_moid (f, m); } WRITE (f, "\n"); ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "\n MODE STRING #%d ", NUMBER (M_STRING)) >= 0); WRITE (f, A68 (output_line)); ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "\n MODE COMPLEX #%d ", NUMBER (M_COMPLEX)) >= 0); WRITE (f, A68 (output_line)); ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "\n MODE SEMA #%d ", NUMBER (M_SEMA)) >= 0); WRITE (f, A68 (output_line)); } //! @brief Cross_reference. void cross_reference (FILE_T f, NODE_T * p, LINE_T * l) { if (p != NO_NODE && CROSS_REFERENCE_SAFE (&A68_JOB)) { for (; p != NO_NODE; FORWARD (p)) { if (is_new_lexical_level (p) && l == LINE (INFO (p))) { TABLE_T *c = TABLE (SUB (p)); ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "\n\n[level %d", LEVEL (c)) >= 0); WRITE (f, A68 (output_line)); if (PREVIOUS (c) == A68_STANDENV) { ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, ", in standard environ") >= 0); } else { ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, ", in level %d", LEVEL (PREVIOUS (c))) >= 0); } WRITE (f, A68 (output_line)); #if (A68_LEVEL >= 3) ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, ", %llu increment]", AP_INCREMENT (c)) >= 0); #else ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, ", %u increment]", AP_INCREMENT (c)) >= 0); #endif WRITE (f, A68 (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. BOOL_T empty_leave (NODE_T * p) { #define TEST_LEAVE(n)\ if (IS (p, (n)) && NEXT (p) == NO_NODE && PREVIOUS (p) == NO_NODE) {\ return A68_TRUE;\ } TEST_LEAVE (ENCLOSED_CLAUSE); TEST_LEAVE (UNIT); TEST_LEAVE (TERTIARY); TEST_LEAVE (SECONDARY); TEST_LEAVE (PRIMARY); TEST_LEAVE (DENOTATION); return A68_FALSE; #undef TEST_LEAVE } //! @brief Tree listing for source line. void tree_listing (FILE_T f, NODE_T * q, int x, LINE_T * l, int *ld, BOOL_T comment) { for (; q != NO_NODE; FORWARD (q)) { NODE_T *p = q; int k, dist; if (((STATUS_TEST (p, TREE_MASK)) || comment) && l == LINE (INFO (p))) { if (*ld < 0) { *ld = x; } // Indent. if (comment && empty_leave (p)) { ; } else { if (comment) { WRITE (f, "\n// "); ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "%06d ", NUMBER (p)) >= 0); WRITE (f, A68 (output_line)); } else { WRITE (f, "\n "); ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "%02d %06d p%02d ", x, NUMBER (p), PROCEDURE_LEVEL (INFO (p))) >= 0); WRITE (f, A68 (output_line)); if (PREVIOUS (TABLE (p)) != NO_TABLE) { ASSERT (snprintf (A68 (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 (A68 (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, A68 (output_line)); if (MOID (q) != NO_MOID) { ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "#%04d ", NUMBER (MOID (p))) >= 0); } else { ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, " ") >= 0); } WRITE (f, A68 (output_line)); } for (k = 0; k < (x - *ld); k++) { WRITE (f, A68 (marker)[k]); } if (MOID (p) != NO_MOID) { ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "%s ", moid_to_string (MOID (p), MOID_WIDTH, NO_NODE)) >= 0); WRITE (f, A68 (output_line)); } ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "%s", non_terminal_string (A68 (edit_line), ATTRIBUTE (p))) >= 0); WRITE (f, A68 (output_line)); if (SUB (p) == NO_NODE) { ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, " \"%s\"", NSYMBOL (p)) >= 0); WRITE (f, A68 (output_line)); } if (!comment) { if (TAX (p) != NO_TAG) { ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, ", tag %06u", (unt) NUMBER (TAX (p))) >= 0); WRITE (f, A68 (output_line)); if (MOID (TAX (p)) != NO_MOID) { ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, ", mode %06u", (unt) NUMBER (MOID (TAX (p)))) >= 0); WRITE (f, A68 (output_line)); } } if (GINFO (p) != NO_GINFO && propagator_name (UNIT (&GPROP (p))) != NO_TEXT) { ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, ", %s", propagator_name (UNIT (&GPROP (p)))) >= 0); WRITE (f, A68 (output_line)); } if (GINFO (p) != NO_GINFO && COMPILE_NAME (GINFO (p)) != NO_TEXT) { ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, ", %s", COMPILE_NAME (GINFO (p))) >= 0); WRITE (f, A68 (output_line)); } if (GINFO (p) != NO_GINFO && COMPILE_NODE (GINFO (p)) > 0) { ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, ", %6d", COMPILE_NODE (GINFO (p))) >= 0); WRITE (f, A68 (output_line)); } } } dist = x - (*ld); if (dist >= 0 && dist < BUFFER_SIZE) { A68 (marker)[dist] = (NEXT (p) != NO_NODE && l == LINE (INFO (NEXT (p))) ? "|" : " "); } } tree_listing (f, SUB (p), x + 1, l, ld, comment); dist = x - (*ld); if (dist >= 0 && dist < BUFFER_SIZE) { A68 (marker)[dist] = " "; } } } //! @brief Leaves_to_print. 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. 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 (&A68_JOB)) { cross_reference (f, TOP_NODE (&A68_JOB), line); } // Syntax tree listing connected with this line. if (tree && OPTION_TREE_LISTING (&A68_JOB)) { if (TREE_LISTING_SAFE (&A68_JOB) && leaves_to_print (TOP_NODE (&A68_JOB), line)) { int ld = -1, k2; WRITE (f, "\n\nSyntax tree"); for (k2 = 0; k2 < BUFFER_SIZE; k2++) { A68 (marker)[k2] = " "; } tree_listing (f, TOP_NODE (&A68_JOB), 1, line, &ld, A68_FALSE); WRITE (f, "\n"); } } } //! @brief Source_listing. void write_source_listing (void) { LINE_T *line = TOP_LINE (&A68_JOB); FILE_T f = FILE_LISTING_FD (&A68_JOB); int listed = 0; WRITE (FILE_LISTING_FD (&A68_JOB), NEWLINE_STRING); WRITE (FILE_LISTING_FD (&A68_JOB), "\nSource listing"); WRITE (FILE_LISTING_FD (&A68_JOB), "\n------ -------"); WRITE (FILE_LISTING_FD (&A68_JOB), NEWLINE_STRING); if (FILE_LISTING_OPENED (&A68_JOB) == 0) { diagnostic (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 (A68 (output_line), SNPRINTF_SIZE, "\n No lines to list") >= 0); WRITE (f, A68 (output_line)); } } //! @brief Write_source_listing. void write_tree_listing (void) { LINE_T *line = TOP_LINE (&A68_JOB); FILE_T f = FILE_LISTING_FD (&A68_JOB); int listed = 0; WRITE (FILE_LISTING_FD (&A68_JOB), NEWLINE_STRING); WRITE (FILE_LISTING_FD (&A68_JOB), "\nSyntax tree listing"); WRITE (FILE_LISTING_FD (&A68_JOB), "\n------ ---- -------"); WRITE (FILE_LISTING_FD (&A68_JOB), NEWLINE_STRING); if (FILE_LISTING_OPENED (&A68_JOB) == 0) { diagnostic (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 (A68 (output_line), SNPRINTF_SIZE, "\n No lines to list") >= 0); WRITE (f, A68 (output_line)); } } //! @brief Write_object_listing. void write_object_listing (void) { if (OPTION_OBJECT_LISTING (&A68_JOB)) { WRITE (FILE_LISTING_FD (&A68_JOB), NEWLINE_STRING); WRITE (FILE_LISTING_FD (&A68_JOB), "\nObject listing"); WRITE (FILE_LISTING_FD (&A68_JOB), "\n------ -------"); WRITE (FILE_LISTING_FD (&A68_JOB), NEWLINE_STRING); compiler (FILE_LISTING_FD (&A68_JOB)); } } //! @brief Write_listing. void write_listing (void) { FILE_T f = FILE_LISTING_FD (&A68_JOB); if (OPTION_MOID_LISTING (&A68_JOB)) { WRITE (FILE_LISTING_FD (&A68_JOB), NEWLINE_STRING); WRITE (FILE_LISTING_FD (&A68_JOB), "\nMode listing"); WRITE (FILE_LISTING_FD (&A68_JOB), "\n---- -------"); WRITE (FILE_LISTING_FD (&A68_JOB), NEWLINE_STRING); moid_listing (f, TOP_MOID (&A68_JOB)); } if (OPTION_STANDARD_PRELUDE_LISTING (&A68_JOB) && A68_STANDENV != NO_TABLE) { WRITE (FILE_LISTING_FD (&A68_JOB), NEWLINE_STRING); WRITE (FILE_LISTING_FD (&A68_JOB), "\nStandard prelude listing"); WRITE (FILE_LISTING_FD (&A68_JOB), "\n-------- ------- -------"); WRITE (FILE_LISTING_FD (&A68_JOB), NEWLINE_STRING); xref_decs (f, A68_STANDENV); } if (TOP_REFINEMENT (&A68_JOB) != NO_REFINEMENT) { REFINEMENT_T *x = TOP_REFINEMENT (&A68_JOB); WRITE (FILE_LISTING_FD (&A68_JOB), NEWLINE_STRING); WRITE (FILE_LISTING_FD (&A68_JOB), "\nRefinement listing"); WRITE (FILE_LISTING_FD (&A68_JOB), "\n---------- -------"); WRITE (FILE_LISTING_FD (&A68_JOB), NEWLINE_STRING); while (x != NO_REFINEMENT) { ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "\n \"%s\"", NAME (x)) >= 0); WRITE (f, A68 (output_line)); if (LINE_DEFINED (x) != NO_LINE) { ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, ", defined in line %d", NUMBER (LINE_DEFINED (x))) >= 0); WRITE (f, A68 (output_line)); } if (LINE_APPLIED (x) != NO_LINE) { ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, ", applied in line %d", NUMBER (LINE_APPLIED (x))) >= 0); WRITE (f, A68 (output_line)); } switch (APPLICATIONS (x)) { case 0: { ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, ", not applied") >= 0); WRITE (f, A68 (output_line)); break; } case 1: { break; } default: { ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, ", applied more than once") >= 0); WRITE (f, A68 (output_line)); break; } } FORWARD (x); } } if (OPTION_LIST (&A68_JOB) != NO_OPTION_LIST) { OPTION_LIST_T *i; int k = 1; WRITE (FILE_LISTING_FD (&A68_JOB), NEWLINE_STRING); WRITE (FILE_LISTING_FD (&A68_JOB), "\nPragmat listing"); WRITE (FILE_LISTING_FD (&A68_JOB), "\n------- -------"); WRITE (FILE_LISTING_FD (&A68_JOB), NEWLINE_STRING); for (i = OPTION_LIST (&A68_JOB); i != NO_OPTION_LIST; FORWARD (i)) { ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "\n%d: %s", k++, STR (i)) >= 0); WRITE (f, A68 (output_line)); } } } //! @brief Write_listing_header. void write_listing_header (void) { FILE_T f = FILE_LISTING_FD (&A68_JOB); LINE_T *z; state_version (FILE_LISTING_FD (&A68_JOB)); WRITE (FILE_LISTING_FD (&A68_JOB), "\nFile \""); WRITE (FILE_LISTING_FD (&A68_JOB), FILE_SOURCE_NAME (&A68_JOB)); WRITE (FILE_LISTING_FD (&A68_JOB), "\""); if (OPTION_STATISTICS_LISTING (&A68_JOB)) { if (ERROR_COUNT (&A68_JOB) + WARNING_COUNT (&A68_JOB) > 0) { ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "\nDiagnostics: %d error(s), %d warning(s)", ERROR_COUNT (&A68_JOB), WARNING_COUNT (&A68_JOB)) >= 0); WRITE (f, A68 (output_line)); for (z = TOP_LINE (&A68_JOB); z != NO_LINE; FORWARD (z)) { if (DIAGNOSTICS (z) != NO_DIAGNOSTIC) { write_source_line (f, z, NO_NODE, A68_TRUE); } } } } } algol68g-3.1.2/src/a68g/compiler-basic.c0000644000175000017500000002614714361065320014464 00000000000000//! @file compiler.c //! @author J. Marcel van der Veer // //! @section Copyright // // This file is part of Algol68G - an Algol 68 compiler-interpreter. // Copyright 2001-2023 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" #include "a68g-prelude.h" #include "a68g-genie.h" #include "a68g-listing.h" #include "a68g-mp.h" #include "a68g-optimiser.h" #include "a68g-compiler.h" #include "a68g-parser.h" #include "a68g-transput.h" // Whether stuff is sufficiently "basic" to be compiled. //! @brief Whether primitive mode, with simple C equivalent. BOOL_T primitive_mode (MOID_T * m) { if (m == M_INT) { return A68_TRUE; } else if (m == M_REAL) { return A68_TRUE; } else if (m == M_BOOL) { return A68_TRUE; } else if (m == M_CHAR) { return A68_TRUE; } else if (m == M_BITS) { return A68_TRUE; } else { return A68_FALSE; } } //! @brief Whether basic mode, for which units are compiled. BOOL_T basic_mode (MOID_T * m) { if (primitive_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)) { return A68_FALSE; // Not (fully) implemented yet. // TODO: code to convert stacked units into an array. // 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. BOOL_T basic_mode_non_row (MOID_T * m) { if (primitive_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 basic collateral clause. 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. 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. 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. 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. BOOL_T basic_slice (NODE_T * p) { if (IS (p, SLICE)) { NODE_T *prim = SUB (p); NODE_T *idf = stems_from (prim, IDENTIFIER); if (idf != NO_NODE) { NODE_T *indx = NEXT (prim); return basic_indexer (indx); } } return A68_FALSE; } //! @brief Whether basic argument. 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. BOOL_T basic_call (NODE_T * p) { if (IS (p, CALL)) { NODE_T *prim = SUB (p); NODE_T *idf = stems_from (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. 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. 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. 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. 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)); } if (A68_OPT (OPTION_CODE_LEVEL) >= 3) { 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)); } } if (A68_OPT (OPTION_CODE_LEVEL) >= 2) { if (IS (p, VOIDING) && IS (SUB (p), ASSIGNATION) && stems_from (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) && stems_from (SUB_SUB (p), SLICE) != NO_NODE) { NODE_T *dst = SUB_SUB (p); NODE_T *src = NEXT_NEXT (dst); NODE_T *slice = stems_from (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) && stems_from (SUB_SUB (p), SELECTION) != NO_NODE) { NODE_T *dst = SUB_SUB (p); NODE_T *src = NEXT_NEXT (dst); return (BOOL_T) (stems_from (NEXT_SUB (stems_from (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) && stems_from (SUB (p), SLICE)) { NODE_T *slice = stems_from (SUB (p), SLICE); return (BOOL_T) (basic_mode (MOID (p)) && IS (MOID (SUB (slice)), REF_SYMBOL) && basic_slice (slice)); } else if (IS (p, DEREFERENCING) && stems_from (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, REAL, COMPLEX)) { return basic_unit (SUB (p)); } else { return A68_FALSE; } } 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 = stems_from (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) (stems_from (p, IDENTIFIER) != NO_NODE && IS (MOID (stems_from ((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) && stems_from (rhs, NIHIL) != NO_NODE) { return A68_TRUE; } else { return A68_FALSE; } #undef GOOD } } if (A68_OPT (OPTION_CODE_LEVEL) >= 1) { if (IS (p, IDENTIFIER)) { if (A68_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, DEREFERENCING) && stems_from (SUB (p), IDENTIFIER)) { return (BOOL_T) (basic_mode (MOID (p)) && BASIC (SUB (p), IDENTIFIER)); } else if (IS (p, DENOTATION)) { return primitive_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)); } } return A68_FALSE; } algol68g-3.1.2/src/a68g/bits.c0000644000175000017500000002407714361065320012534 00000000000000//! @file bits.c //! @author J. Marcel van der Veer // //! @section Copyright // // This file is part of Algol68G - an Algol 68 compiler-interpreter. // Copyright 2001-2023 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" #include "a68g-prelude.h" #include "a68g-mp.h" #include "a68g-genie.h" #include "a68g-postulates.h" #include "a68g-parser.h" #include "a68g-options.h" #include "a68g-optimiser.h" #include "a68g-listing.h" #if defined (HAVE_MATHLIB) #include #endif #if defined (BUILD_WIN32) #include #endif // libgen selects Posix versions of dirname/basename in stead of GNU versions. #include #define WRITE_TXT(fn, txt) ASSERT (write ((fn), (txt), 1 + strlen (txt)) != -1) #if defined (BUILD_LINUX) #include void genie_sigsegv (NODE_T *p) { (void) p; raise (SIGSEGV); } //! @brief Provide a rudimentary backtrace. void stack_backtrace (void) { #define DEPTH 16 void *array[DEPTH]; WRITE_TXT (2, "\n++++ Top of call stack:"); int size = backtrace (array, DEPTH); if (size > 0) { WRITE_TXT (2, "\n"); backtrace_symbols_fd (array, size, 2); } #undef DEPTH } void genie_backtrace (NODE_T *p) { (void) p; stack_backtrace (); } #else void stack_backtrace (void) { WRITE_TXT (2, "\n++++ Stack backtrace is linux-only"); } void genie_backtrace (NODE_T *p) { (void) p; stack_backtrace (); } #endif //! @brief Open a file in ~/.a68g, if possible. FILE *a68_fopen (char *fn, char *mode, char *new_fn) { #if defined (BUILD_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; errno = 0; 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 Get terminal size. void a68_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. #if defined (SIGWINCH) void sigwinch_handler (int i) { (void) i; ABEND (signal (SIGWINCH, sigwinch_handler) == SIG_ERR, ERROR_ACTION, __func__); a68_getty (&A68 (term_heigth), &A68 (term_width)); return; } #endif //! @brief Signal reading for segment violation. void sigsegv_handler (int i) { (void) i; // write () is asynchronous-safe and may be called here. WRITE_TXT (2, "\nFatal"); if (FILE_INITIAL_NAME (&A68_JOB) != NO_TEXT) { WRITE_TXT (2, ": "); WRITE_TXT (2, FILE_INITIAL_NAME (&A68_JOB)); } WRITE_TXT (2, ": memory access violation\n"); stack_backtrace (); exit (EXIT_FAILURE); return; } //! @brief Raise SYSREQUEST so you get to a monitor. void sigint_handler (int i) { (void) i; ABEND (signal (SIGINT, sigint_handler) == SIG_ERR, ERROR_ACTION, __func__); if (!(STATUS_TEST (TOP_NODE (&A68_JOB), BREAKPOINT_INTERRUPT_MASK) || A68 (in_monitor))) { STATUS_SET (TOP_NODE (&A68_JOB), BREAKPOINT_INTERRUPT_MASK); genie_break (TOP_NODE (&A68_JOB)); } } #if defined (BUILD_UNIX) //! @brief Signal reading from disconnected terminal. void sigttin_handler (int i) { (void) i; ABEND (A68_TRUE, ERROR_ACTION, __func__); } //! @brief Signal broken pipe. void sigpipe_handler (int i) { (void) i; ABEND (A68_TRUE, ERROR_ACTION, __func__); } //! @brief Signal alarm - time limit check. void sigalrm_handler (int i) { (void) i; if (A68 (in_execution) && !A68 (in_monitor)) { REAL_T _m_t = (REAL_T) OPTION_TIME_LIMIT (&A68_JOB); if (_m_t > 0 && (seconds () - A68 (cputime_0)) > _m_t) { diagnostic (A68_RUNTIME_ERROR, (NODE_T *) A68 (f_entry), ERROR_TIME_LIMIT_EXCEEDED); exit_genie ((NODE_T *) A68 (f_entry), A68_RUNTIME_ERROR); } } (void) alarm (1); } #endif //! @brief Install_signal_handlers. void install_signal_handlers (void) { ABEND (signal (SIGINT, sigint_handler) == SIG_ERR, ERROR_ACTION, __func__); ABEND (signal (SIGSEGV, sigsegv_handler) == SIG_ERR, ERROR_ACTION, __func__); #if defined (SIGWINCH) ABEND (signal (SIGWINCH, sigwinch_handler) == SIG_ERR, ERROR_ACTION, __func__); #endif #if defined (BUILD_UNIX) ABEND (signal (SIGALRM, sigalrm_handler) == SIG_ERR, ERROR_ACTION, __func__); ABEND (signal (SIGPIPE, sigpipe_handler) == SIG_ERR, ERROR_ACTION, __func__); ABEND (signal (SIGTTIN, sigttin_handler) == SIG_ERR, ERROR_ACTION, __func__); #endif } //! @brief Time versus arbitrary origin. REAL_T seconds (void) { return (REAL_T) clock () / (REAL_T) CLOCKS_PER_SEC; } //! @brief Safely append to buffer. 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. 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 Safely get dir name from path. char *a68_dirname (char *src) { int len = (int) strlen (src) + 1; char *cpy = (char *) get_fixed_heap_space (len + 1); char *dst = (char *) get_fixed_heap_space (len + 1); ABEND (cpy == NO_TEXT, ERROR_OUT_OF_CORE, __func__); ABEND (dst == NO_TEXT, ERROR_OUT_OF_CORE, __func__); bufcpy (cpy, src, len); bufcpy (dst, dirname (cpy), len); return dst; } //! @brief Safely get basename from path. char *a68_basename (char *src) { int len = (int) strlen (src) + 1; char *cpy = (char *) get_fixed_heap_space (len + 1); char *dst = (char *) get_fixed_heap_space (len + 1); ABEND (cpy == NO_TEXT, ERROR_OUT_OF_CORE, __func__); ABEND (dst == NO_TEXT, ERROR_OUT_OF_CORE, __func__); bufcpy (cpy, src, len); bufcpy (dst, basename (cpy), len); return dst; } //! @brief Compute relative path. #if defined (BUILD_WIN32) static char *win32_slash (char *p) { char *q = p; while (*p != '\0') { if (*p == '\\') { *p = '/'; } p++; } return q; } static char *win32_realpath (char *name, char *resolved) { char *res = NO_TEXT; if (name == NO_TEXT || name[0] == '\0') { return NO_TEXT; } if (resolved == NO_TEXT) { res = (char *) get_fixed_heap_space (PATH_MAX + 1); if (res == NO_TEXT) { return NO_TEXT; } } else { res = resolved; } int rc = GetFullPathName (name, PATH_MAX, res, (char **) NO_TEXT); if (rc == 0) { return NO_TEXT; } else { win32_slash (res); struct stat st; if (stat (res, &st) < 0) { // Should be 'lstat', but mingw does not have that. if (resolved == NO_TEXT) { free (res); return NO_TEXT; } } } return res; } #endif char *a68_relpath (char *p1, char *p2, char *fn) { char q[PATH_MAX + 1]; bufcpy (q, p1, PATH_MAX); bufcat (q, "/", PATH_MAX); bufcat (q, p2, PATH_MAX); bufcat (q, "/", PATH_MAX); bufcat (q, fn, PATH_MAX); // Home directory shortcut ~ is a shell extension. if (strchr (q, '~') != NO_TEXT) { return NO_TEXT; } char *r = (char *) get_fixed_heap_space (PATH_MAX + 1); ABEND (r == NO_TEXT, ERROR_OUT_OF_CORE, __func__); // Error handling in the caller! errno = 0; #if defined (BUILD_WIN32) r = win32_realpath (q, NO_TEXT); #else r = realpath (q, NO_TEXT); #endif return r; } //! @brief PROC (STRING) STRING realpath void genie_realpath (NODE_T * p) { A68_REF str; char in[PATH_MAX + 1]; char * out; POP_REF (p, &str); if (a_to_c_string (p, in, str) == NO_TEXT) { PUSH_REF (p, empty_string (p)); } else { // Note that ~ is not resolved since that is the shell, not libc. #if defined (BUILD_WIN32) out = win32_realpath (in, NO_TEXT); #else out = realpath (in, NO_TEXT); #endif if (out == NO_TEXT) { PUSH_REF (p, empty_string (p)); } else { PUSH_REF (p, c_to_a_string (p, out, PATH_MAX)); } } } algol68g-3.1.2/src/a68g/single-rnd.c0000644000175000017500000001535714361065320013636 00000000000000//! @file single-rnd.c //! @author J. Marcel van der Veer // //! @section Copyright // // This file is part of Algol68G - an Algol 68 compiler-interpreter. // Copyright 2001-2023 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" #include "a68g-genie.h" #include "a68g-prelude.h" #include "a68g-double.h" #include "a68g-numbers.h" // Next part is a "stand-alone" version of GNU Scientific Library (GSL) // random number generator "taus113", based on GSL file "rng/taus113.c". // rng/taus113.c // Copyright (C) 2002 Atakan Gurkan // Based on the file taus.c which has the notice // Copyright (C) 1996, 1997, 1998, 1999, 2000, 2007 James Theiler, Brian Gough // // 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, write to the Free Software // Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. // // This is a maximally equidistributed combined, collision free // Tausworthe generator, with a period ~2^{113}. 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 // z{i+1} = (69069 * zi) 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 MASK 0xffffffffUL unt taus113_get (void *vstate); double taus113_get_double (void *vstate); void taus113_set (void *state, unt long int s); typedef struct { unt long int z1, z2, z3, z4; } taus113_state_t; static taus113_state_t rng_state; unt taus113_get (void *vstate) { taus113_state_t *state = (taus113_state_t *) vstate; unt long b1, b2, b3, b4; b1 = ((((state->z1 << 6UL) & MASK) ^ state->z1) >> 13UL); state->z1 = ((((state->z1 & 4294967294UL) << 18UL) & MASK) ^ b1); b2 = ((((state->z2 << 2UL) & MASK) ^ state->z2) >> 27UL); state->z2 = ((((state->z2 & 4294967288UL) << 2UL) & MASK) ^ b2); b3 = ((((state->z3 << 13UL) & MASK) ^ state->z3) >> 21UL); state->z3 = ((((state->z3 & 4294967280UL) << 7UL) & MASK) ^ b3); b4 = ((((state->z4 << 3UL) & MASK) ^ state->z4) >> 12UL); state->z4 = ((((state->z4 & 4294967168UL) << 13UL) & MASK) ^ b4); return (state->z1 ^ state->z2 ^ state->z3 ^ state->z4); } double taus113_get_double (void *vstate) { return taus113_get (vstate) / 4294967296.0; } void taus113_set (void *vstate, unt long int s) { taus113_state_t *state = (taus113_state_t *) vstate; if (!s) { s = 1UL; /* default seed is 1 */ } state->z1 = LCG (s); if (state->z1 < 2UL) { state->z1 += 2UL; } state->z2 = LCG (state->z1); if (state->z2 < 8UL) { state->z2 += 8UL; } state->z3 = LCG (state->z2); if (state->z3 < 16UL) { state->z3 += 16UL; } state->z4 = LCG (state->z3); if (state->z4 < 128UL) { state->z4 += 128UL; } // Calling RNG ten times to satify recurrence condition taus113_get (state); taus113_get (state); taus113_get (state); taus113_get (state); taus113_get (state); taus113_get (state); taus113_get (state); taus113_get (state); taus113_get (state); taus113_get (state); return; } /* 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)] ] */ // Initialise rng. void init_rng (unt u) { taus113_set (&rng_state, u); } // A68G rng in R mathlib style. REAL_T a68_unif_rand (void) { // In [0, 1> return taus113_get_double (&rng_state); } static char *state_file = ".Random.seed"; void GetRNGstate (void) { INT_T fd = open (state_file, A68_READ_ACCESS); if (fd != -1) { ASSERT (read (fd, &rng_state, sizeof (taus113_state_t)) != -1); close (fd); } } void PutRNGstate (void) { INT_T fd = open (state_file, A68_WRITE_ACCESS, A68_PROTECTION); if (fd != -1) { ASSERT (write (fd, &rng_state, sizeof (taus113_state_t)) != -1); close (fd); } } algol68g-3.1.2/src/a68g/socket.c0000644000175000017500000004160214361065320013054 00000000000000//! @file socket.c //! @author J. Marcel van der Veer // //! @section Copyright // // This file is part of Algol68G - an Algol 68 compiler-interpreter. // Copyright 2001-2023 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" #include "a68g-genie.h" #include "a68g-prelude.h" #include "a68g-transput.h" #if defined (BUILD_HTTP) #define PROTOCOL "tcp" #define SERVICE "http" #define CONTENT_BUFFER_SIZE (64 * KILOBYTE) #define TIMEOUT_INTERVAL 15 #if defined (BUILD_UNIX) //! @brief Send GET request to server and yield answer (TCP/HTTP only). 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 a68_timeout; struct servent *service_address; struct hostent *host_address; struct protoent *protocol; struct sockaddr_in socket_address; char buffer[CONTENT_BUFFER_SIZE]; errno = 0; // Pop arguments. POP_OBJECT (p, &port_number, A68_INT); CHECK_INIT (p, INITIALISED (&port_number), M_INT); POP_REF (p, &path_string); CHECK_INIT (p, INITIALISED (&path_string), M_STRING); POP_REF (p, &domain_string); CHECK_INIT (p, INITIALISED (&domain_string), M_STRING); POP_REF (p, &content_string); CHECK_REF (p, content_string, M_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_VALUE (p, 1, A68_INT); return; } if (VALUE (&port_number) == 0) { SIN_PORT (&socket_address) = (uint16_t) (S_PORT (service_address)); } else { SIN_PORT (&socket_address) = (uint16_t) (htons ((uint16_t) (VALUE (&port_number)))); if (SIN_PORT (&socket_address) == 0) { PUSH_VALUE (p, (errno == 0 ? 1 : errno), A68_INT); return; } } host_address = gethostbyname (get_transput_buffer (DOMAIN_BUFFER)); if (host_address == NULL) { PUSH_VALUE (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_VALUE (p, (errno == 0 ? 1 : errno), A68_INT); return; } socket_id = socket (PF_INET, SOCK_STREAM, P_PROTO (protocol)); if (socket_id < 0) { PUSH_VALUE (p, (errno == 0 ? 1 : errno), A68_INT); return; } conn = connect (socket_id, (const struct sockaddr *) &socket_address, (socklen_t) SIZE_ALIGNED (socket_address)); if (conn < 0) { PUSH_VALUE (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_VALUE (p, errno, A68_INT); ASSERT (close (socket_id) == 0); return; } // Initialise file descriptor set. FD_ZERO (&set); FD_SET (socket_id, &set); // Initialise the a68_timeout data structure. TV_SEC (&a68_timeout) = TIMEOUT_INTERVAL; TV_USEC (&a68_timeout) = 0; // Block until server replies or a68_timeout blows up. switch (select (FD_SETSIZE, &set, NULL, NULL, &a68_timeout)) { case 0: { errno = ETIMEDOUT; PUSH_VALUE (p, errno, A68_INT); ASSERT (close (socket_id) == 0); return; } case -1: { PUSH_VALUE (p, errno, A68_INT); ASSERT (close (socket_id) == 0); return; } case 1: { break; } default: { ABEND (A68_TRUE, ERROR_ACTION, __func__); } } while ((k = (int) io_read (socket_id, &buffer, (CONTENT_BUFFER_SIZE - 1))) > 0) { add_chars_transput_buffer (p, CONTENT_BUFFER, k, buffer); } if (k < 0 || errno != 0) { PUSH_VALUE (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_VALUE (p, errno, A68_INT); } //! @brief Send request to server and yield answer (TCP only). 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 a68_timeout; struct servent *service_address; struct hostent *host_address; struct protoent *protocol; struct sockaddr_in socket_address; char buffer[CONTENT_BUFFER_SIZE]; errno = 0; // Pop arguments. POP_OBJECT (p, &port_number, A68_INT); CHECK_INIT (p, INITIALISED (&port_number), M_INT); POP_REF (p, &path_string); CHECK_INIT (p, INITIALISED (&path_string), M_STRING); POP_REF (p, &domain_string); CHECK_INIT (p, INITIALISED (&domain_string), M_STRING); POP_REF (p, &content_string); CHECK_REF (p, content_string, M_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_VALUE (p, 1, A68_INT); return; } if (VALUE (&port_number) == 0) { SIN_PORT (&socket_address) = (uint16_t) (S_PORT (service_address)); } else { SIN_PORT (&socket_address) = (uint16_t) (htons ((uint16_t) (VALUE (&port_number)))); if (SIN_PORT (&socket_address) == 0) { PUSH_VALUE (p, (errno == 0 ? 1 : errno), A68_INT); return; } } host_address = gethostbyname (get_transput_buffer (DOMAIN_BUFFER)); if (host_address == NULL) { PUSH_VALUE (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_VALUE (p, (errno == 0 ? 1 : errno), A68_INT); return; } socket_id = socket (PF_INET, SOCK_STREAM, P_PROTO (protocol)); if (socket_id < 0) { PUSH_VALUE (p, (errno == 0 ? 1 : errno), A68_INT); return; } conn = connect (socket_id, (const struct sockaddr *) &socket_address, (socklen_t) SIZE_ALIGNED (socket_address)); if (conn < 0) { PUSH_VALUE (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_VALUE (p, errno, A68_INT); ASSERT (close (socket_id) == 0); return; } // Initialise file descriptor set. FD_ZERO (&set); FD_SET (socket_id, &set); // Initialise the a68_timeout data structure. TV_SEC (&a68_timeout) = TIMEOUT_INTERVAL; TV_USEC (&a68_timeout) = 0; // Block until server replies or a68_timeout blows up. switch (select (FD_SETSIZE, &set, NULL, NULL, &a68_timeout)) { case 0: { errno = ETIMEDOUT; PUSH_VALUE (p, errno, A68_INT); ASSERT (close (socket_id) == 0); return; } case -1: { PUSH_VALUE (p, errno, A68_INT); ASSERT (close (socket_id) == 0); return; } case 1: { break; } default: { ABEND (A68_TRUE, ERROR_ACTION, __func__); } } while ((k = (int) io_read (socket_id, &buffer, (CONTENT_BUFFER_SIZE - 1))) > 0) { add_chars_transput_buffer (p, CONTENT_BUFFER, k, buffer); } if (k < 0 || errno != 0) { PUSH_VALUE (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_VALUE (p, errno, A68_INT); } #endif #if defined (BUILD_WIN32) #if defined (HAVE_WINSOCK_H) #include #endif typedef int socklen_t; //! @brief Send GET request to server and yield answer (TCP/HTTP only). 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; errno = 0; // Pop arguments. POP_OBJECT (p, &port_number, A68_INT); CHECK_INIT (p, INITIALISED (&port_number), M_INT); POP_REF (p, &path_string); CHECK_INIT (p, INITIALISED (&path_string), M_STRING); POP_REF (p, &domain_string); CHECK_INIT (p, INITIALISED (&domain_string), M_STRING); POP_REF (p, &content_string); CHECK_REF (p, content_string, M_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_VALUE (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_VALUE (p, 1, A68_INT); WSACleanup (); return; } if (VALUE (&port_number) == 0) { SIN_PORT (&socket_address) = (uint16_t) (S_PORT (service_address)); } else { SIN_PORT (&socket_address) = (uint16_t) (htons ((uint16_t) (VALUE (&port_number)))); if (SIN_PORT (&socket_address) == 0) { PUSH_VALUE (p, (errno == 0 ? 1 : errno), A68_INT); WSACleanup (); return; } } host_address = gethostbyname (get_transput_buffer (DOMAIN_BUFFER)); if (host_address == NULL) { PUSH_VALUE (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_VALUE (p, (errno == 0 ? 1 : errno), A68_INT); WSACleanup (); return; } socket_id = socket (PF_INET, SOCK_STREAM, P_PROTO (protocol)); if (socket_id < 0) { PUSH_VALUE (p, (errno == 0 ? 1 : errno), A68_INT); WSACleanup (); return; } conn = connect (socket_id, (const struct sockaddr *) &socket_address, (socklen_t) SIZE_ALIGNED (socket_address)); if (conn < 0) { PUSH_VALUE (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_VALUE (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) { add_chars_transput_buffer (p, CONTENT_BUFFER, k, buffer); } if (k < 0 || errno != 0) { PUSH_VALUE (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_VALUE (p, errno, A68_INT); WSACleanup (); } //! @brief Send request to server and yield answer (TCP only). 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; errno = 0; // Pop arguments. POP_OBJECT (p, &port_number, A68_INT); CHECK_INIT (p, INITIALISED (&port_number), M_INT); POP_REF (p, &path_string); CHECK_INIT (p, INITIALISED (&path_string), M_STRING); POP_REF (p, &domain_string); CHECK_INIT (p, INITIALISED (&domain_string), M_STRING); POP_REF (p, &content_string); CHECK_REF (p, content_string, M_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_VALUE (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_VALUE (p, 1, A68_INT); WSACleanup (); return; } if (VALUE (&port_number) == 0) { SIN_PORT (&socket_address) = (uint16_t) (S_PORT (service_address)); } else { SIN_PORT (&socket_address) = (uint16_t) (htons ((uint16_t) (VALUE (&port_number)))); if (SIN_PORT (&socket_address) == 0) { PUSH_VALUE (p, (errno == 0 ? 1 : errno), A68_INT); WSACleanup (); return; } } host_address = gethostbyname (get_transput_buffer (DOMAIN_BUFFER)); if (host_address == NULL) { PUSH_VALUE (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_VALUE (p, (errno == 0 ? 1 : errno), A68_INT); WSACleanup (); return; } socket_id = socket (PF_INET, SOCK_STREAM, P_PROTO (protocol)); if (socket_id < 0) { PUSH_VALUE (p, (errno == 0 ? 1 : errno), A68_INT); WSACleanup (); return; } conn = connect (socket_id, (const struct sockaddr *) &socket_address, (socklen_t) SIZE_ALIGNED (socket_address)); if (conn < 0) { PUSH_VALUE (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_VALUE (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) { add_chars_transput_buffer (p, CONTENT_BUFFER, k, buffer); } if (k < 0 || errno != 0) { PUSH_VALUE (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_VALUE (p, errno, A68_INT); WSACleanup (); } #endif #endif algol68g-3.1.2/src/a68g/bool.c0000644000175000017500000000323614361065320012520 00000000000000//! @file bool.c //! @author J. Marcel van der Veer // //! @section Copyright // // This file is part of Algol68G - an Algol 68 compiler-interpreter. // Copyright 2001-2023 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" #include "a68g-genie.h" #include "a68g-prelude.h" #include "a68g-mp.h" #include "a68g-physics.h" #include "a68g-numbers.h" #include "a68g-optimiser.h" #include "a68g-double.h" // BOOL operations. // OP NOT = (BOOL) BOOL. A68_MONAD (genie_not_bool, A68_BOOL, (BOOL_T) !); //! @brief OP ABS = (BOOL) INT void genie_abs_bool (NODE_T * p) { A68_BOOL j; POP_OBJECT (p, &j, A68_BOOL); PUSH_VALUE (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, !=); algol68g-3.1.2/src/a68g/a68g.c0000644000175000017500000006476214361065320012345 00000000000000//! @file a68g.c //! @author J. Marcel van der Veer // //! @section Copyright // // This file is part of Algol68G - an Algol 68 compiler-interpreter. // Copyright 2001-2023 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" #include "a68g-prelude.h" #include "a68g-mp.h" #include "a68g-genie.h" #include "a68g-prelude-mathlib.h" #include "a68g-postulates.h" #include "a68g-parser.h" #include "a68g-options.h" #include "a68g-optimiser.h" #include "a68g-listing.h" #if defined (HAVE_MATHLIB) #include #endif GLOBALS_T common; #define EXTENSIONS 11 static char *extensions[EXTENSIONS] = { NO_TEXT, ".a68", ".A68", ".a68g", ".A68G", ".algol", ".ALGOL", ".algol68", ".ALGOL68", ".algol68g", ".ALGOL68G" }; void compiler_interpreter (void); //! @brief Verbose statistics, only useful when debugging a68g. void verbosity (void) { #if defined (A68_DEBUG) ; #else ; #endif } //! @brief State license of running a68g image. void state_license (FILE_T f) { #define PR(s)\ ASSERT (snprintf(A68 (output_line), SNPRINTF_SIZE, "%s\n", (s)) >= 0);\ WRITE (f, A68 (output_line)); // if (f == STDOUT_FILENO) { io_close_tty_line (); } ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "Algol 68 Genie %s\n", PACKAGE_VERSION) >= 0); WRITE (f, A68 (output_line)); ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "Copyright 2001-2023 %s.\n", PACKAGE_BUGREPORT) >= 0); WRITE (f, A68 (output_line)); PR (""); ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "This is free software covered by the GNU General Public License.\n") >= 0); WRITE (f, A68 (output_line)); ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "There is ABSOLUTELY NO WARRANTY for Algol 68 Genie;\n") >= 0); WRITE (f, A68 (output_line)); ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.\n") >= 0); WRITE (f, A68 (output_line)); PR ("See the GNU General Public License for more details."); PR (""); ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "Please report bugs to %s.\n", PACKAGE_BUGREPORT) >= 0); WRITE (f, A68 (output_line)); #undef PR } //! @brief State version of running a68g image. void state_version (FILE_T f) { #define PR(s)\ ASSERT (snprintf(A68 (output_line), SNPRINTF_SIZE, "%s\n", (s)) >= 0);\ WRITE (f, A68 (output_line)); // if (f == STDOUT_FILENO) { io_close_tty_line (); } state_license (f); PR (""); #if defined (BUILD_WIN32) ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "WIN32 executable\n") >= 0); WRITE (f, A68 (output_line)); WRITELN (f, ""); #endif //ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "Algol 68 Genie version %d\n", A68_LEVEL) >= 0); //WRITE (f, A68 (output_line)); #if (A68_LEVEL >= 3) ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "With hardware support for long modes\n") >= 0); WRITE (f, A68 (output_line)); #endif #if defined (BUILD_A68_COMPILER) ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "With compilation support\n") >= 0); WRITE (f, A68 (output_line)); #if defined (C_COMPILER) ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, " C compiler is %s\n", C_COMPILER) >= 0); WRITE (f, A68 (output_line)); #endif #endif #if defined (BUILD_PARALLEL_CLAUSE) ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "With parallel-clause support\n") >= 0); WRITE (f, A68 (output_line)); #endif #if defined (HAVE_GNU_MPFR) ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "With GNU MP %s\n", gmp_version) >= 0); WRITE (f, A68 (output_line)); ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "With GNU MPFR %s\n", mpfr_get_version ()) >= 0); WRITE (f, A68 (output_line)); #endif #if defined (HAVE_MATHLIB) ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "With mathlib from R %s\n", R_VERSION_STRING) >= 0); WRITE (f, A68 (output_line)); #endif #if defined (HAVE_GSL) ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "With GNU Scientific Library %s\n", GSL_VERSION) >= 0); WRITE (f, A68 (output_line)); #endif #if defined (HAVE_GNU_PLOTUTILS) ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "With GNU plotutils %s\n", PL_LIBPLOT_VER_STRING) >= 0); WRITE (f, A68 (output_line)); #endif #if defined (HAVE_CURSES) ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "With curses %s\n", NCURSES_VERSION) >= 0); WRITE (f, A68 (output_line)); #endif #if defined (BUILD_HTTP) ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "With TCP/IP support\n") >= 0); WRITE (f, A68 (output_line)); #endif #if defined (HAVE_POSTGRESQL) ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "With PostgreSQL support\n") >= 0); WRITE (f, A68 (output_line)); #endif #if defined (_CS_GNU_LIBC_VERSION) && defined (BUILD_UNIX) if (confstr (_CS_GNU_LIBC_VERSION, A68 (input_line), BUFFER_SIZE) > (size_t) 0) { ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "GNU libc version %s\n", A68 (input_line)) >= 0); WRITE (f, A68 (output_line)); } #if (defined (BUILD_PARALLEL_CLAUSE) && defined (_CS_GNU_LIBPTHREAD_VERSION)) if (confstr (_CS_GNU_LIBPTHREAD_VERSION, A68 (input_line), BUFFER_SIZE) > (size_t) 0) { ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "GNU libpthread version %s\n", A68 (input_line)) >= 0); WRITE (f, A68 (output_line)); } #endif #endif #undef PR } //! @brief Give brief help if someone types 'a68g --help'. void online_help (FILE_T f) { if (f == STDOUT_FILENO) { io_close_tty_line (); } state_license (f); ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "Usage: %s [options | filename]", A68 (a68_cmd_name)) >= 0); WRITELN (f, A68 (output_line)); ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "For help: %s --apropos [keyword]", A68 (a68_cmd_name)) >= 0); WRITELN (f, A68 (output_line)); } //! @brief Start book keeping for a phase. void announce_phase (char *t) { if (OPTION_VERBOSE (&A68_JOB)) { ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "%s: %s", A68 (a68_cmd_name), t) >= 0); io_close_tty_line (); WRITE (STDOUT_FILENO, A68 (output_line)); } } //! @brief Test extension and strip. BOOL_T strip_extension (char *ext) { if (ext == NO_TEXT) { return A68_FALSE; } int nlen = (int) strlen (FILE_SOURCE_NAME (&A68_JOB)), xlen = (int) strlen (ext); if (nlen > xlen && strcmp (&(FILE_SOURCE_NAME (&A68_JOB)[nlen - xlen]), ext) == 0) { char *fn = (char *) get_heap_space ((size_t) (nlen + 1)); bufcpy (fn, FILE_SOURCE_NAME (&A68_JOB), nlen); fn[nlen - xlen] = NULL_CHAR; a68_free (FILE_GENERIC_NAME (&A68_JOB)); FILE_GENERIC_NAME (&A68_JOB) = new_string (fn, NO_TEXT); a68_free (fn); return A68_TRUE; } else { return A68_FALSE; } } //! @brief Try opening with an extension. void open_with_extensions (void) { int k; FILE_SOURCE_FD (&A68_JOB) = -1; for (k = 0; k < EXTENSIONS && FILE_SOURCE_FD (&A68_JOB) == -1; k++) { int len; char *fn = NULL; if (extensions[k] == NO_TEXT) { len = (int) strlen (FILE_INITIAL_NAME (&A68_JOB)) + 1; fn = (char *) get_heap_space ((size_t) len); bufcpy (fn, FILE_INITIAL_NAME (&A68_JOB), len); } else { len = (int) strlen (FILE_INITIAL_NAME (&A68_JOB)) + (int) strlen (extensions[k]) + 1; fn = (char *) get_heap_space ((size_t) len); bufcpy (fn, FILE_INITIAL_NAME (&A68_JOB), len); bufcat (fn, extensions[k], len); } FILE_SOURCE_FD (&A68_JOB) = open (fn, O_RDONLY | O_BINARY); if (FILE_SOURCE_FD (&A68_JOB) != -1) { int l; BOOL_T cont = A68_TRUE; a68_free (FILE_SOURCE_NAME (&A68_JOB)); a68_free (FILE_GENERIC_NAME (&A68_JOB)); FILE_SOURCE_NAME (&A68_JOB) = new_string (fn, NO_TEXT); FILE_GENERIC_NAME (&A68_JOB) = new_string (a68_basename (fn), NO_TEXT); FILE_PATH (&A68_JOB) = new_string (a68_dirname (fn), NO_TEXT); for (l = 0; l < EXTENSIONS && cont; l++) { if (strip_extension (extensions[l])) { cont = A68_FALSE; } } } a68_free (fn); } } //! @brief Remove a regular file. void a68_rm (char *fn) { struct stat path_stat; if (stat (fn, &path_stat) == 0) { if (S_ISREG (path_stat.st_mode)) { ABEND (remove (fn) != 0, ERROR_ACTION, FILE_OBJECT_NAME (&A68_JOB)); } } } //! @brief Drives compilation and interpretation. void compiler_interpreter (void) { int len, num; #if defined (BUILD_A68_COMPILER) BOOL_T emitted = A68_FALSE; #endif TREE_LISTING_SAFE (&A68_JOB) = A68_FALSE; CROSS_REFERENCE_SAFE (&A68_JOB) = A68_FALSE; A68 (in_execution) = A68_FALSE; A68 (new_nodes) = 0; A68 (new_modes) = 0; A68 (new_postulates) = 0; A68 (new_node_infos) = 0; A68 (new_genie_infos) = 0; A68 (symbol_table_count) = 0; A68 (mode_count) = 0; A68 (node_register) = NO_VAR; init_postulates (); A68 (do_confirm_exit) = A68_TRUE; A68 (f_entry) = NO_NODE; A68 (global_level) = 0; A68 (max_lex_lvl) = 0; A68_PARSER (stop_scanner) = A68_FALSE; A68_PARSER (read_error) = A68_FALSE; A68_PARSER (no_preprocessing) = A68_FALSE; A68_PARSER (reductions) = 0; A68_PARSER (tag_number) = 0; A68 (curses_mode) = A68_FALSE; A68 (top_soid_list) = NO_SOID; A68 (max_simplout_size) = 0; A68_MON (in_monitor) = A68_FALSE; A68_MP (mp_ln_scale_size) = -1; A68_MP (mp_ln_10_size) = -1; A68_MP (mp_gamma_size) = -1; A68_MP (mp_one_size) = -1; A68_MP (mp_pi_size) = -1; // File set-up. SCAN_ERROR (FILE_INITIAL_NAME (&A68_JOB) == NO_TEXT, NO_LINE, NO_TEXT, ERROR_NO_SOURCE_FILE); FILE_BINARY_OPENED (&A68_JOB) = A68_FALSE; FILE_BINARY_WRITEMOOD (&A68_JOB) = A68_TRUE; FILE_LIBRARY_OPENED (&A68_JOB) = A68_FALSE; FILE_LIBRARY_WRITEMOOD (&A68_JOB) = A68_TRUE; FILE_LISTING_OPENED (&A68_JOB) = A68_FALSE; FILE_LISTING_WRITEMOOD (&A68_JOB) = A68_TRUE; FILE_OBJECT_OPENED (&A68_JOB) = A68_FALSE; FILE_OBJECT_WRITEMOOD (&A68_JOB) = A68_TRUE; FILE_PRETTY_OPENED (&A68_JOB) = A68_FALSE; FILE_SCRIPT_OPENED (&A68_JOB) = A68_FALSE; FILE_SCRIPT_WRITEMOOD (&A68_JOB) = A68_FALSE; FILE_SOURCE_OPENED (&A68_JOB) = A68_FALSE; FILE_SOURCE_WRITEMOOD (&A68_JOB) = A68_FALSE; FILE_DIAGS_OPENED (&A68_JOB) = A68_FALSE; FILE_DIAGS_WRITEMOOD (&A68_JOB) = 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 (&A68_JOB) = NO_TEXT; FILE_GENERIC_NAME (&A68_JOB) = NO_TEXT; open_with_extensions (); if (FILE_SOURCE_NAME (&A68_JOB) == NO_TEXT) { errno = ENOENT; SCAN_ERROR (A68_TRUE, NO_LINE, NO_TEXT, ERROR_SOURCE_FILE_OPEN); } else { struct stat path_stat; errno = 0; SCAN_ERROR (stat (FILE_SOURCE_NAME (&A68_JOB), &path_stat) != 0, NO_LINE, NO_TEXT, ERROR_SOURCE_FILE_OPEN); SCAN_ERROR (S_ISDIR (path_stat.st_mode), NO_LINE, NO_TEXT, ERROR_IS_DIRECTORY); SCAN_ERROR (!S_ISREG (path_stat.st_mode), NO_LINE, NO_TEXT, ERROR_NO_REGULAR_FILE); } if (FILE_SOURCE_FD (&A68_JOB) == -1) { scan_error (NO_LINE, NO_TEXT, ERROR_SOURCE_FILE_OPEN); } ABEND (FILE_SOURCE_NAME (&A68_JOB) == NO_TEXT, ERROR_INTERNAL_CONSISTENCY, __func__); ABEND (FILE_GENERIC_NAME (&A68_JOB) == NO_TEXT, ERROR_INTERNAL_CONSISTENCY, __func__); // Object file. len = 1 + (int) strlen (FILE_GENERIC_NAME (&A68_JOB)) + (int) strlen (OBJECT_EXTENSION); FILE_OBJECT_NAME (&A68_JOB) = (char *) get_heap_space ((size_t) len); bufcpy (FILE_OBJECT_NAME (&A68_JOB), FILE_GENERIC_NAME (&A68_JOB), len); bufcat (FILE_OBJECT_NAME (&A68_JOB), OBJECT_EXTENSION, len); // Binary. len = 1 + (int) strlen (FILE_GENERIC_NAME (&A68_JOB)) + (int) strlen (LIBRARY_EXTENSION); FILE_BINARY_NAME (&A68_JOB) = (char *) get_heap_space ((size_t) len); bufcpy (FILE_BINARY_NAME (&A68_JOB), FILE_GENERIC_NAME (&A68_JOB), len); bufcat (FILE_BINARY_NAME (&A68_JOB), BINARY_EXTENSION, len); // Library file. len = 1 + (int) strlen (FILE_GENERIC_NAME (&A68_JOB)) + (int) strlen (LIBRARY_EXTENSION); FILE_LIBRARY_NAME (&A68_JOB) = (char *) get_heap_space ((size_t) len); bufcpy (FILE_LIBRARY_NAME (&A68_JOB), FILE_GENERIC_NAME (&A68_JOB), len); bufcat (FILE_LIBRARY_NAME (&A68_JOB), LIBRARY_EXTENSION, len); // Listing file. len = 1 + (int) strlen (FILE_GENERIC_NAME (&A68_JOB)) + (int) strlen (LISTING_EXTENSION); FILE_LISTING_NAME (&A68_JOB) = (char *) get_heap_space ((size_t) len); bufcpy (FILE_LISTING_NAME (&A68_JOB), FILE_GENERIC_NAME (&A68_JOB), len); bufcat (FILE_LISTING_NAME (&A68_JOB), LISTING_EXTENSION, len); // Pretty file. len = 1 + (int) strlen (FILE_GENERIC_NAME (&A68_JOB)) + (int) strlen (PRETTY_EXTENSION); FILE_PRETTY_NAME (&A68_JOB) = (char *) get_heap_space ((size_t) len); bufcpy (FILE_PRETTY_NAME (&A68_JOB), FILE_GENERIC_NAME (&A68_JOB), len); bufcat (FILE_PRETTY_NAME (&A68_JOB), PRETTY_EXTENSION, len); // Script file. len = 1 + (int) strlen (FILE_GENERIC_NAME (&A68_JOB)) + (int) strlen (SCRIPT_EXTENSION); FILE_SCRIPT_NAME (&A68_JOB) = (char *) get_heap_space ((size_t) len); bufcpy (FILE_SCRIPT_NAME (&A68_JOB), FILE_GENERIC_NAME (&A68_JOB), len); bufcat (FILE_SCRIPT_NAME (&A68_JOB), SCRIPT_EXTENSION, len); // Parser. a68_parser (); if (TOP_NODE (&A68_JOB) == NO_NODE) { errno = ECANCELED; ABEND (A68_TRUE, ERROR_SOURCE_FILE_EMPTY, NO_TEXT); } // Portability checker. if (ERROR_COUNT (&A68_JOB) == 0) { announce_phase ("portability checker"); portcheck (TOP_NODE (&A68_JOB)); verbosity (); } // Finalise syntax tree. if (ERROR_COUNT (&A68_JOB) == 0) { num = 0; renumber_nodes (TOP_NODE (&A68_JOB), &num); NEST (TABLE (TOP_NODE (&A68_JOB))) = A68 (symbol_table_count) = 3; reset_symbol_table_nest_count (TOP_NODE (&A68_JOB)); verbosity (); } // if (A68_MP (varying_mp_digits) > width_to_mp_digits (MP_MAX_DECIMALS)) { diagnostic (A68_WARNING, NO_NODE, WARNING_PRECISION, NO_LINE, 0, A68_MP (varying_mp_digits) * LOG_MP_RADIX); } // Compiler. if (ERROR_COUNT (&A68_JOB) == 0 && OPTION_OPT_LEVEL (&A68_JOB) > NO_OPTIMISE) { announce_phase ("optimiser (code generator)"); num = 0; renumber_nodes (TOP_NODE (&A68_JOB), &num); A68 (node_register) = (NODE_T **) get_heap_space ((size_t) num * sizeof (NODE_T)); ABEND (A68 (node_register) == NO_VAR, ERROR_ACTION, __func__); register_nodes (TOP_NODE (&A68_JOB)); FILE_OBJECT_FD (&A68_JOB) = open (FILE_OBJECT_NAME (&A68_JOB), O_WRONLY | O_CREAT | O_TRUNC, A68_PROTECTION); ABEND (FILE_OBJECT_FD (&A68_JOB) == -1, ERROR_ACTION, FILE_OBJECT_NAME (&A68_JOB)); FILE_OBJECT_OPENED (&A68_JOB) = A68_TRUE; compiler (FILE_OBJECT_FD (&A68_JOB)); ASSERT (close (FILE_OBJECT_FD (&A68_JOB)) == 0); FILE_OBJECT_OPENED (&A68_JOB) = A68_FALSE; #if defined (BUILD_A68_COMPILER) emitted = A68_TRUE; #endif } #if defined (BUILD_A68_COMPILER) // Only compile C if the A68 compiler found no errors (constant folder for instance). if (ERROR_COUNT (&A68_JOB) == 0 && OPTION_OPT_LEVEL (&A68_JOB) > 0 && !OPTION_RUN_SCRIPT (&A68_JOB)) { char cmd[BUFFER_SIZE], options[BUFFER_SIZE]; if (OPTION_RERUN (&A68_JOB) == A68_FALSE) { announce_phase ("optimiser (code compiler)"); errno = 0; // // Compilation on Linux, BSD. // Build shared library using gcc or clang. // TODO: One day this should be all portable between platforms. // // -fno-stack-protector is needed for OS's that enforce -fstack-protector-strong which may give // undefined reference to `__stack_chk_fail_local' // by ld. Ubuntu is one such. // ASSERT (snprintf (options, SNPRINTF_SIZE, "%s %s", optimisation_option (), A68_GCC_OPTIONS) >= 0); #if defined (HAVE_PIC) bufcat (options, " ", BUFFER_SIZE); bufcat (options, HAVE_PIC, BUFFER_SIZE); #endif ASSERT (snprintf (cmd, SNPRINTF_SIZE, "%s -I%s %s -c -o \"%s\" \"%s\"", C_COMPILER, INCLUDEDIR, options, FILE_BINARY_NAME (&A68_JOB), FILE_OBJECT_NAME (&A68_JOB)) >= 0); ABEND (system (cmd) != 0, ERROR_ACTION, cmd); ASSERT (snprintf (cmd, SNPRINTF_SIZE, "ld -export-dynamic -shared -o \"%s\" \"%s\"", FILE_LIBRARY_NAME (&A68_JOB), FILE_BINARY_NAME (&A68_JOB)) >= 0); ABEND (system (cmd) != 0, ERROR_ACTION, cmd); a68_rm (FILE_BINARY_NAME (&A68_JOB)); } verbosity (); } #else if (OPTION_OPT_LEVEL (&A68_JOB) > 0) { diagnostic (A68_WARNING | A68_FORCE_DIAGNOSTICS, TOP_NODE (&A68_JOB), WARNING_OPTIMISATION); } #endif // Indenter. if (ERROR_COUNT (&A68_JOB) == 0 && OPTION_PRETTY (&A68_JOB)) { announce_phase ("indenter"); indenter (&A68_JOB); verbosity (); } // Interpreter. diagnostics_to_terminal (TOP_LINE (&A68_JOB), A68_ALL_DIAGNOSTICS); // Restore seed for rng. GetRNGstate (); A68 (f_entry) = TOP_NODE (&A68_JOB); // if (ERROR_COUNT (&A68_JOB) == 0 && OPTION_COMPILE (&A68_JOB) == A68_FALSE && (OPTION_CHECK_ONLY (&A68_JOB) ? OPTION_RUN (&A68_JOB) : A68_TRUE)) { #if defined (BUILD_A68_COMPILER) void *compile_lib; #endif A68 (close_tty_on_exit) = A68_FALSE; // Assuming no runtime errors a priori #if defined (BUILD_A68_COMPILER) if (OPTION_RUN_SCRIPT (&A68_JOB)) { rewrite_script_source (); } #endif if (OPTION_DEBUG (&A68_JOB)) { state_license (STDOUT_FILENO); } #if defined (BUILD_A68_COMPILER) if (OPTION_OPT_LEVEL (&A68_JOB) > 0) { char libname[BUFFER_SIZE]; void *a68_lib; struct stat srcstat, objstat; int ret; announce_phase ("dynamic linker"); ASSERT (snprintf (libname, SNPRINTF_SIZE, "%s", FILE_LIBRARY_NAME (&A68_JOB)) >= 0); // Check whether we are doing something rash. ret = stat (FILE_SOURCE_NAME (&A68_JOB), &srcstat); ABEND (ret != 0, ERROR_ACTION, FILE_SOURCE_NAME (&A68_JOB)); ret = stat (libname, &objstat); ABEND (ret != 0, ERROR_ACTION, libname); if (OPTION_RERUN (&A68_JOB)) { ABEND (ST_MTIME (&srcstat) > ST_MTIME (&objstat), "library outdates source", "cannot RERUN"); } // First load a68g itself so compiler code can resolve a68g symbols. a68_lib = dlopen (NULL, RTLD_NOW | RTLD_GLOBAL); ABEND (a68_lib == NULL, ERROR_RESOLVE, dlerror ()); // Then load compiler code. compile_lib = dlopen (libname, RTLD_NOW | RTLD_GLOBAL); ABEND (compile_lib == NULL, ERROR_RESOLVE, dlerror ()); } else { compile_lib = NULL; } announce_phase ("genie"); genie (compile_lib); // Unload compiler library. if (OPTION_OPT_LEVEL (&A68_JOB) > 0) { int ret = dlclose (compile_lib); ABEND (ret != 0, ERROR_ACTION, dlerror ()); } #else announce_phase ("genie"); genie (NO_NODE); #endif // Free heap allocated by genie. genie_free (TOP_NODE (&A68_JOB)); // Store seed for rng. announce_phase ("store rng state"); PutRNGstate (); // Normal end of program. diagnostics_to_terminal (TOP_LINE (&A68_JOB), A68_RUNTIME_ERROR); if (OPTION_DEBUG (&A68_JOB) || OPTION_TRACE (&A68_JOB) || OPTION_CLOCK (&A68_JOB)) { ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "\nGenie finished in %.2f seconds\n", seconds () - A68 (cputime_0)) >= 0); WRITE (STDOUT_FILENO, A68 (output_line)); } verbosity (); } // Setting up listing file. announce_phase ("write listing"); if (OPTION_MOID_LISTING (&A68_JOB) || OPTION_TREE_LISTING (&A68_JOB) || OPTION_SOURCE_LISTING (&A68_JOB) || OPTION_OBJECT_LISTING (&A68_JOB) || OPTION_STATISTICS_LISTING (&A68_JOB)) { FILE_LISTING_FD (&A68_JOB) = open (FILE_LISTING_NAME (&A68_JOB), O_WRONLY | O_CREAT | O_TRUNC, A68_PROTECTION); ABEND (FILE_LISTING_FD (&A68_JOB) == -1, ERROR_ACTION, __func__); FILE_LISTING_OPENED (&A68_JOB) = A68_TRUE; } else { FILE_LISTING_OPENED (&A68_JOB) = A68_FALSE; } // Write listing. if (FILE_LISTING_OPENED (&A68_JOB)) { A68 (heap_is_fluid) = A68_TRUE; write_listing_header (); write_source_listing (); write_tree_listing (); if (ERROR_COUNT (&A68_JOB) == 0 && OPTION_OPT_LEVEL (&A68_JOB) > 0) { write_object_listing (); } write_listing (); ASSERT (close (FILE_LISTING_FD (&A68_JOB)) == 0); FILE_LISTING_OPENED (&A68_JOB) = A68_FALSE; verbosity (); } // Cleaning up the intermediate files. #if defined (BUILD_A68_COMPILER) announce_phase ("clean up intermediate files"); if (OPTION_OPT_LEVEL (&A68_JOB) >= OPTIMISE_0 && OPTION_REGRESSION_TEST (&A68_JOB) && !OPTION_KEEP (&A68_JOB)) { if (emitted) { a68_rm (FILE_OBJECT_NAME (&A68_JOB)); } a68_rm (FILE_LIBRARY_NAME (&A68_JOB)); } if (OPTION_RUN_SCRIPT (&A68_JOB) && !OPTION_KEEP (&A68_JOB)) { if (emitted) { a68_rm (FILE_OBJECT_NAME (&A68_JOB)); } a68_rm (FILE_SOURCE_NAME (&A68_JOB)); a68_rm (FILE_LIBRARY_NAME (&A68_JOB)); } else if (OPTION_COMPILE (&A68_JOB)) { build_script (); if (!OPTION_KEEP (&A68_JOB)) { if (emitted) { a68_rm (FILE_OBJECT_NAME (&A68_JOB)); } a68_rm (FILE_LIBRARY_NAME (&A68_JOB)); } } else if (OPTION_OPT_LEVEL (&A68_JOB) == OPTIMISE_0 && !OPTION_KEEP (&A68_JOB)) { if (emitted) { a68_rm (FILE_OBJECT_NAME (&A68_JOB)); } a68_rm (FILE_LIBRARY_NAME (&A68_JOB)); } else if (OPTION_OPT_LEVEL (&A68_JOB) > OPTIMISE_0 && !OPTION_KEEP (&A68_JOB)) { if (emitted) { a68_rm (FILE_OBJECT_NAME (&A68_JOB)); } } else if (OPTION_RERUN (&A68_JOB) && !OPTION_KEEP (&A68_JOB)) { if (emitted) { a68_rm (FILE_OBJECT_NAME (&A68_JOB)); } } #endif } //! @brief Exit a68g in an orderly manner. void a68_exit (int code) { announce_phase ("exit"); #if defined (HAVE_GNU_MPFR) mpfr_free_cache (); #endif // Close unclosed files, remove temp files. free_file_entries (); // Close the terminal. if (A68 (close_tty_on_exit) || OPTION_REGRESSION_TEST (&A68_JOB)) { io_close_tty_line (); } else if (OPTION_VERBOSE (&A68_JOB)) { 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 // Clean up stale things. free_syntax_tree (TOP_NODE (&A68_JOB)); free_option_list (OPTION_LIST (&A68_JOB)); a68_free (A68 (node_register)); a68_free (A68 (options)); // discard_heap (); // a68_free (FILE_PATH (&A68_JOB)); a68_free (FILE_INITIAL_NAME (&A68_JOB)); a68_free (FILE_GENERIC_NAME (&A68_JOB)); a68_free (FILE_SOURCE_NAME (&A68_JOB)); a68_free (FILE_LISTING_NAME (&A68_JOB)); a68_free (FILE_OBJECT_NAME (&A68_JOB)); a68_free (FILE_LIBRARY_NAME (&A68_JOB)); a68_free (FILE_BINARY_NAME (&A68_JOB)); a68_free (FILE_PRETTY_NAME (&A68_JOB)); a68_free (FILE_SCRIPT_NAME (&A68_JOB)); a68_free (FILE_DIAGS_NAME (&A68_JOB)); // a68_free (A68_MP (mp_one)); a68_free (A68_MP (mp_pi)); a68_free (A68_MP (mp_half_pi)); a68_free (A68_MP (mp_two_pi)); a68_free (A68_MP (mp_sqrt_two_pi)); a68_free (A68_MP (mp_sqrt_pi)); a68_free (A68_MP (mp_ln_pi)); a68_free (A68_MP (mp_180_over_pi)); a68_free (A68_MP (mp_pi_over_180)); // exit (code); } //! @brief Main entry point. int main (int argc, char *argv[]) { BYTE_T stack_offset; // Leave this here! A68 (argc) = argc; A68 (argv) = argv; A68 (close_tty_on_exit) = A68_TRUE; FILE_DIAGS_FD (&A68_JOB) = -1; // Get command name and discard path. bufcpy (A68 (a68_cmd_name), argv[0], BUFFER_SIZE); int k; for (k = (int) strlen (A68 (a68_cmd_name)) - 1; k >= 0; k--) { #if defined (BUILD_WIN32) char delim = '\\'; #else char delim = '/'; #endif if (A68 (a68_cmd_name)[k] == delim) { MOVE (&A68 (a68_cmd_name)[0], &A68 (a68_cmd_name)[k + 1], (int) strlen (A68 (a68_cmd_name)) - k + 1); k = -1; } } // Try to read maximum line width on the terminal, // used to pretty print diagnostics to same. a68_getty (&A68 (term_heigth), &A68 (term_width)); // Determine clock resolution. { clock_t t0 = clock (), t1; do { t1 = clock (); } while (t1 == t0); A68 (clock_res) = (t1 - t0) / (clock_t) CLOCKS_PER_SEC; } // Set the main thread id. #if defined (BUILD_PARALLEL_CLAUSE) A68_PAR (main_thread_id) = pthread_self (); #endif A68 (heap_is_fluid) = A68_TRUE; A68 (system_stack_offset) = &stack_offset; init_file_entries (); if (!setjmp (RENDEZ_VOUS (&A68_JOB))) { init_tty (); // Initialise option handling. init_options (); SOURCE_SCAN (&A68_JOB) = 1; default_options (&A68_JOB); default_mem_sizes (1); // Initialise core. A68_STACK = NO_BYTE; A68_HEAP = NO_BYTE; A68_HANDLES = NO_BYTE; get_stack_size (); // Well, let's start. TOP_REFINEMENT (&A68_JOB) = NO_REFINEMENT; FILE_INITIAL_NAME (&A68_JOB) = NO_TEXT; FILE_GENERIC_NAME (&A68_JOB) = NO_TEXT; FILE_SOURCE_NAME (&A68_JOB) = NO_TEXT; FILE_LISTING_NAME (&A68_JOB) = NO_TEXT; FILE_OBJECT_NAME (&A68_JOB) = NO_TEXT; FILE_LIBRARY_NAME (&A68_JOB) = NO_TEXT; FILE_BINARY_NAME (&A68_JOB) = NO_TEXT; FILE_PRETTY_NAME (&A68_JOB) = NO_TEXT; FILE_SCRIPT_NAME (&A68_JOB) = NO_TEXT; FILE_DIAGS_NAME (&A68_JOB) = 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); a68_exit (EXIT_FAILURE); } int argcc; for (argcc = 1; argcc < argc; argcc++) { add_option_list (&(OPTION_LIST (&A68_JOB)), argv[argcc], NO_LINE); } if (!set_options (OPTION_LIST (&A68_JOB), A68_TRUE)) { a68_exit (EXIT_FAILURE); } // State license. if (OPTION_LICENSE (&A68_JOB)) { state_license (STDOUT_FILENO); } // State version. if (OPTION_VERSION (&A68_JOB)) { state_version (STDOUT_FILENO); } // Start the UI. init_before_tokeniser (); // Running a script. #if defined (BUILD_A68_COMPILER) if (OPTION_RUN_SCRIPT (&A68_JOB)) { load_script (); } #endif // We translate the program. if (FILE_INITIAL_NAME (&A68_JOB) == NO_TEXT || strlen (FILE_INITIAL_NAME (&A68_JOB)) == 0) { SCAN_ERROR (!(OPTION_LICENSE (&A68_JOB) || OPTION_VERSION (&A68_JOB)), NO_LINE, NO_TEXT, ERROR_NO_SOURCE_FILE); } else { compiler_interpreter (); } a68_exit (ERROR_COUNT (&A68_JOB) == 0 ? EXIT_SUCCESS : EXIT_FAILURE); return EXIT_SUCCESS; } else { diagnostics_to_terminal (TOP_LINE (&A68_JOB), A68_ALL_DIAGNOSTICS); a68_exit (EXIT_FAILURE); return EXIT_FAILURE; } } algol68g-3.1.2/src/a68g/pretty.c0000644000175000017500000010723314361065320013116 00000000000000//! @file pretty.c //! @author J. Marcel van der Veer // //! @section Copyright // // This file is part of Algol68G - an Algol 68 compiler-interpreter. // Copyright 2001-2023 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 . // Basic indenter for hopeless code. // It applies one style only. #include "a68g.h" #include "a68g-genie.h" #include "a68g-parser.h" #include "a68g-prelude.h" #include "a68g-optimiser.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)) void indent_declarer (NODE_T *); void indent_serial (NODE_T *, BOOL_T, NODE_T **); void indent_statement (NODE_T *); void indent_format (NODE_T *); //! @brief Write newline and indent. void put_nl (void) { WRITE (A68_INDENT (fd), "\n"); for (A68_INDENT (col) = 1; A68_INDENT (col) < A68_INDENT (ind); A68_INDENT (col)++) { WRITE (A68_INDENT (fd), " "); } } //! @brief Write a string. void put_str (char *txt) { WRITE (A68_INDENT (fd), txt); A68_INDENT (col) += (int) strlen (txt); } //! @brief Write a character. void put_ch (char ch) { char str[2]; str[0] = ch; str[1] = NULL_CHAR; put_str (str); } //! @brief Write pragment string. 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. void pretty_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 (A68_INDENT (col) > A68_INDENT (ind)) { BLANK; } put_pragment (p); BLANK; } else { if (A68_INDENT (col) > A68_INDENT (ind)) { put_nl (); } put_pragment (p); put_nl (); } } } } //! @brief Write with typographic display features. 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); pretty_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. 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 if (IS (p, CLOSED_CLAUSE)) { (*units)--; } else if (IS (p, COLLATERAL_CLAUSE)) { (*units)--; count (SUB (p), units, seps); } else { count (SUB (p), units, seps); } } } //! @brief Count units and separators in a sub-tree. 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_FLEX (v) || IS_ROW (v) || IS_STRUCT (v)); 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. 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. void indent_sizety (NODE_T * p) { for (; p != NO_NODE; FORWARD (p)) { if (IS (p, LONGETY) || IS (p, SHORTETY)) { indent_sizety (SUB (p)); } else if (IS (p, LONG_SYMBOL) || IS (p, SHORT_SYMBOL)) { put_sym (p, !KEYWORD); BLANK; } } } //! @brief Indent generic list. void indent_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); A68_INDENT (ind) = A68_INDENT (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; indent_statement (SUB (p)); } else if (IS (p, SPECIFIER)) { NODE_T *q = SUB (p); put_sym (q, KEYWORD); FORWARD (q); indent_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 { indent_generic_list (SUB (p), what, one_liner); } } } //! @brief Indent declarer pack. void indent_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)) { indent_declarer (p); if (NEXT (p) != NO_NODE && IS_IDENTIFIER (NEXT (p))) { BLANK; } } else if (IS_IDENTIFIER (p)) { put_sym (p, !KEYWORD); } else { indent_pack (SUB (p)); } } } //! @brief Indent declarer. void indent_declarer (NODE_T * p) { if (IS (p, DECLARER)) { indent_declarer (SUB (p)); } else if (IS (p, LONGETY) || IS (p, SHORTETY)) { indent_sizety (SUB (p)); indent_declarer (NEXT (p)); } else if (IS (p, VOID_SYMBOL)) { put_sym (p, !KEYWORD); } else if (IS (p, REF_SYMBOL)) { put_sym (p, !KEYWORD); BLANK; indent_declarer (NEXT (p)); } else if (IS_FLEX (p)) { put_sym (p, !KEYWORD); BLANK; indent_declarer (NEXT (p)); } else if (IS (p, BOUNDS) || IS (p, FORMAL_BOUNDS)) { NODE_T *what = NO_NODE; int pop_ind = A68_INDENT (ind); indent_generic_list (SUB (p), &what, ONE_LINER); A68_INDENT (ind) = pop_ind; BLANK; indent_declarer (NEXT (p)); } else if (IS_STRUCT (p) || IS_UNION (p)) { NODE_T *pack = NEXT (p); put_sym (p, !KEYWORD); BLANK; indent_pack (pack); } else if (IS (p, PROC_SYMBOL)) { NODE_T *q = NEXT (p); put_sym (p, KEYWORD); BLANK; if (IS (q, FORMAL_DECLARERS)) { indent_pack (SUB (q)); BLANK; FORWARD (q); } indent_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)) { indent_pack (SUB (q)); BLANK; FORWARD (q); } indent_declarer (q); return; } else if (IS (p, INDICANT)) { put_sym (p, !KEYWORD); } } //! @brief Indent conditional. void indent_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 = A68_INDENT (col); put_sym (SUB (p), KEYWORD); BLANK; A68_INDENT (ind) = A68_INDENT (col); indent_serial (NEXT_SUB (p), !ONE_LINER, &what); A68_INDENT (ind) = pop_ind; put_nl (); } else if (IS (p, THEN_PART)) { NODE_T *what = NO_NODE; int pop_ind = A68_INDENT (col); put_sym (SUB (p), KEYWORD); BLANK; A68_INDENT (ind) = A68_INDENT (col); indent_serial (NEXT_SUB (p), !ONE_LINER, &what); A68_INDENT (ind) = pop_ind; put_nl (); } else if (IS (p, ELSE_PART)) { NODE_T *what = NO_NODE; int pop_ind = A68_INDENT (col); put_sym (SUB (p), KEYWORD); BLANK; A68_INDENT (ind) = A68_INDENT (col); indent_serial (NEXT_SUB (p), !ONE_LINER, &what); A68_INDENT (ind) = pop_ind; put_nl (); } else if (IS (p, ELIF_PART)) { indent_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); indent_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; indent_serial (NEXT_SUB (p), ONE_LINER, &what); } else if (IS (p, CHOICE)) { NODE_T *what = NO_NODE; BLANK; put_sym (SUB (p), KEYWORD); BLANK; indent_serial (NEXT_SUB (p), ONE_LINER, &what); } else if (IS (p, BRIEF_ELIF_PART)) { indent_conditional (SUB (p)); } else if (IS_CLOSE_SYMBOL (p)) { put_sym (p, KEYWORD); } } } //! @brief Indent integer case clause. void indent_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 = A68_INDENT (col); put_sym (SUB (p), KEYWORD); BLANK; A68_INDENT (ind) = A68_INDENT (col); indent_serial (NEXT_SUB (p), !ONE_LINER, &what); A68_INDENT (ind) = pop_ind; put_nl (); } else if (IS (p, CASE_IN_PART)) { NODE_T *what = NO_NODE; int pop_ind = A68_INDENT (col); put_sym (SUB (p), KEYWORD); BLANK; A68_INDENT (ind) = A68_INDENT (col); indent_generic_list (NEXT_SUB (p), &what, ONE_LINER); A68_INDENT (ind) = pop_ind; put_nl (); } else if (IS (p, OUT_PART)) { NODE_T *what = NO_NODE; int pop_ind = A68_INDENT (col); put_sym (SUB (p), KEYWORD); BLANK; A68_INDENT (ind) = A68_INDENT (col); indent_serial (NEXT_SUB (p), !ONE_LINER, &what); A68_INDENT (ind) = pop_ind; put_nl (); } else if (IS (p, CASE_OUSE_PART)) { indent_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); indent_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; indent_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; indent_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; indent_serial (NEXT_SUB (p), ONE_LINER, &what); } else if (IS (p, BRIEF_OUSE_PART)) { indent_case (SUB (p)); } else if (IS_CLOSE_SYMBOL (p)) { put_sym (p, KEYWORD); } } } //! @brief Indent conformity clause. void indent_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 = A68_INDENT (col); put_sym (SUB (p), KEYWORD); BLANK; A68_INDENT (ind) = A68_INDENT (col); indent_serial (NEXT_SUB (p), !ONE_LINER, &what); A68_INDENT (ind) = pop_ind; put_nl (); } else if (IS (p, CONFORMITY_IN_PART)) { NODE_T *what = NO_NODE; int pop_ind = A68_INDENT (col); put_sym (SUB (p), KEYWORD); BLANK; A68_INDENT (ind) = A68_INDENT (col); indent_generic_list (NEXT_SUB (p), &what, ONE_LINER); A68_INDENT (ind) = pop_ind; put_nl (); } else if (IS (p, OUT_PART)) { NODE_T *what = NO_NODE; int pop_ind = A68_INDENT (col); put_sym (SUB (p), KEYWORD); BLANK; A68_INDENT (ind) = A68_INDENT (col); indent_serial (NEXT_SUB (p), !ONE_LINER, &what); A68_INDENT (ind) = pop_ind; put_nl (); } else if (IS (p, CONFORMITY_OUSE_PART)) { indent_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); indent_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; indent_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; indent_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; indent_serial (NEXT_SUB (p), ONE_LINER, &what); } else if (IS (p, BRIEF_CONFORMITY_OUSE_PART)) { indent_conformity (SUB (p)); } else if (IS_CLOSE_SYMBOL (p)) { put_sym (p, KEYWORD); } } } //! @brief Indent loop. void indent_loop (NODE_T * p) { int parts = 0, pop_ind = A68_INDENT (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; indent_statement (NEXT_SUB (p)); BLANK; parts++; } else if (IS (p, WHILE_PART)) { NODE_T *what = NO_NODE; A68_INDENT (ind) = pop_ind; if (parts > 0) { put_nl (); } put_sym (SUB (p), KEYWORD); BLANK; A68_INDENT (ind) = A68_INDENT (col); indent_serial (NEXT_SUB (p), !ONE_LINER, &what); A68_INDENT (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; A68_INDENT (ind) = pop_ind; if (parts > 0) { put_nl (); } put_sym (q, KEYWORD); // DO BLANK; A68_INDENT (ind) = A68_INDENT (col); FORWARD (q); parts = 0; if (IS (q, SERIAL_CLAUSE)) { indent_serial (SUB (q), !ONE_LINER, &what); FORWARD (q); parts++; } if (IS (q, UNTIL_PART)) { int pop_ind2 = A68_INDENT (ind); if (parts > 0) { put_nl (); } put_sym (SUB (q), KEYWORD); BLANK; A68_INDENT (ind) = A68_INDENT (col); indent_serial (NEXT_SUB (q), !ONE_LINER, &what); A68_INDENT (ind) = pop_ind2; FORWARD (q); } A68_INDENT (ind) = pop_ind; put_nl (); put_sym (q, KEYWORD); // OD parts++; } } } //! @brief Indent closed clause. void indent_closed (NODE_T * p) { int units = 0, seps = 0; count (SUB_NEXT (p), &units, &seps); if (units <= 3 && seps == (units - 1)) { put_sym (p, KEYWORD); if (IS (p, BEGIN_SYMBOL)) { NODE_T *what = NO_NODE; BLANK; indent_serial (SUB_NEXT (p), ONE_LINER, &what); BLANK; } else { NODE_T *what = NO_NODE; indent_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); indent_serial (SUB_NEXT (p), ONE_LINER, &what); put_sym (NEXT_NEXT (p), KEYWORD); } else { NODE_T *what = NO_NODE; int pop_ind = A68_INDENT (col); put_sym (p, KEYWORD); if (IS (p, BEGIN_SYMBOL)) { BLANK; } A68_INDENT (ind) = A68_INDENT (col); indent_serial (SUB_NEXT (p), !ONE_LINER, &what); A68_INDENT (ind) = pop_ind; if (IS (NEXT_NEXT (p), END_SYMBOL)) { put_nl (); } put_sym (NEXT_NEXT (p), KEYWORD); } } //! @brief Indent collateral clause. void indent_collateral (NODE_T * p) { int units = 0, seps = 0; NODE_T *what = NO_NODE; int pop_ind = A68_INDENT (col); count_stowed (p, &units, &seps); if (units <= 3) { indent_generic_list (p, &what, ONE_LINER); } else { indent_generic_list (p, &what, !ONE_LINER); } A68_INDENT (ind) = pop_ind; } //! @brief Indent enclosed clause. void indent_enclosed (NODE_T * p) { if (IS (p, ENCLOSED_CLAUSE)) { indent_enclosed (SUB (p)); } else if (IS (p, CLOSED_CLAUSE)) { indent_closed (SUB (p)); } else if (IS (p, COLLATERAL_CLAUSE)) { indent_collateral (SUB (p)); } else if (IS (p, PARALLEL_CLAUSE)) { put_sym (SUB (p), KEYWORD); indent_enclosed (NEXT_SUB (p)); } else if (IS (p, CONDITIONAL_CLAUSE)) { indent_conditional (SUB (p)); } else if (IS (p, CASE_CLAUSE)) { indent_case (SUB (p)); } else if (IS (p, CONFORMITY_CLAUSE)) { indent_conformity (SUB (p)); } else if (IS (p, LOOP_CLAUSE)) { indent_loop (SUB (p)); } } //! @brief Indent a literal. void indent_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. void indent_denotation (NODE_T * p) { if (IS (p, ROW_CHAR_DENOTATION)) { indent_literal (NSYMBOL (p)); } else if (IS (p, LONGETY) || IS (p, SHORTETY)) { indent_sizety (SUB (p)); indent_denotation (NEXT (p)); } else { put_sym (p, !KEYWORD); } } //! @brief Indent label. void indent_label (NODE_T * p) { for (; p != NO_NODE; FORWARD (p)) { if (SUB (p) != NULL) { indent_label (SUB (p)); } else if (IS (p, DEFINING_IDENTIFIER)) { put_sym (p, !KEYWORD); put_sym (NEXT (p), KEYWORD); } } } //! @brief Indent literal list. void indent_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 { indent_format (SUB (p)); } } } //! @brief Indent format text. void indent_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)) { indent_collection (SUB (p)); } else if (IS (p, ENCLOSED_CLAUSE)) { indent_enclosed (SUB (p)); } else if (IS (p, LITERAL)) { indent_literal (NSYMBOL (p)); } else if (IS (p, STATIC_REPLICATOR)) { indent_denotation (p); } else if (IS (p, COMMA_SYMBOL)) { put_sym (p, !KEYWORD); BLANK; } else { if (SUB (p) != NO_NODE) { indent_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. BOOL_T indent_folder (NODE_T * p) { if (MOID (p) == M_INT) { A68_INT k; A68_SP = 0; push_unit (p); POP_OBJECT (p, &k, A68_INT); if (ERROR_COUNT (&A68_JOB) == 0) { ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, A68_LD, VALUE (&k)) >= 0); put_str (A68 (output_line)); return A68_TRUE; } else { return A68_FALSE; } } else if (MOID (p) == M_REAL) { A68_REAL x; REAL_T conv; A68_SP = 0; push_unit (p); POP_OBJECT (p, &x, A68_REAL); // Mind overflowing or underflowing values. if (ERROR_COUNT (&A68_JOB) != 0) { return A68_FALSE; } else if (VALUE (&x) == REAL_MAX) { return A68_FALSE; } else if (VALUE (&x) == -REAL_MAX) { return A68_FALSE; } else { ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "%.*g", REAL_WIDTH, VALUE (&x)) >= 0); errno = 0; conv = strtod (A68 (output_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 (A68 (output_line), '.') == NO_TEXT && strchr (A68 (output_line), 'e') == NO_TEXT && strchr (A68 (output_line), 'E') == NO_TEXT) { strncat (A68 (output_line), ".0", BUFFER_SIZE - 1); } put_str (A68 (output_line)); return A68_TRUE; } } } else if (MOID (p) == M_BOOL) { A68_BOOL b; A68_SP = 0; push_unit (p); POP_OBJECT (p, &b, A68_BOOL); if (ERROR_COUNT (&A68_JOB) != 0) { return A68_FALSE; } else { ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "%s", (VALUE (&b) ? "TRUE" : "FALSE")) >= 0); put_str (A68 (output_line)); return A68_TRUE; } } else if (MOID (p) == M_CHAR) { A68_CHAR c; A68_SP = 0; push_unit (p); POP_OBJECT (p, &c, A68_CHAR); if (ERROR_COUNT (&A68_JOB) == 0) { return A68_FALSE; } else if (VALUE (&c) == '\"') { put_str ("\"\"\"\""); return A68_TRUE; } else { ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "\"%c\"", (int) VALUE (&c)) >= 0); return A68_TRUE; } } return A68_FALSE; } //! @brief Indent statement. void indent_statement (NODE_T * p) { if (IS (p, LABEL)) { int enclos = 0, seps = 0; indent_label (SUB (p)); FORWARD (p); count_enclos (SUB (p), &enclos, &seps); if (enclos == 0) { BLANK; } else { put_nl (); } } if (A68_INDENT (use_folder) && folder_mode (MOID (p)) && constant_unit (p)) { if (indent_folder (p)) { return; }; } if (is_coercion (p)) { indent_statement (SUB (p)); } else if (is_one_of (p, PRIMARY, SECONDARY, TERTIARY, UNIT, LABELED_UNIT, STOP)) { indent_statement (SUB (p)); } else if (IS (p, ENCLOSED_CLAUSE)) { indent_enclosed (SUB (p)); } else if (IS (p, DENOTATION)) { indent_denotation (SUB (p)); } else if (IS (p, FORMAT_TEXT)) { indent_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); indent_declarer (decl); BLANK; indent_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 = A68_INDENT (col); indent_statement (primary); BLANK; indent_generic_list (arguments, &what, ONE_LINER); A68_INDENT (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 = A68_INDENT (col); indent_statement (primary); indent_generic_list (indexer, &what, ONE_LINER); A68_INDENT (ind) = pop_ind; } else if (IS (p, SELECTION)) { NODE_T *selector = SUB (p); NODE_T *secondary = NEXT (selector); indent_statement (selector); indent_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; indent_declarer (NEXT (q)); } else if (IS (p, FORMULA)) { NODE_T *lhs = SUB (p); NODE_T *op = NEXT (lhs); indent_statement (lhs); if (op != NO_NODE) { NODE_T *rhs = NEXT (op); BLANK; put_sym (op, !KEYWORD); BLANK; indent_statement (rhs); } } else if (IS (p, MONADIC_FORMULA)) { NODE_T *op = SUB (p); NODE_T *rhs = NEXT (op); put_sym (op, !KEYWORD); if (strchr (MONADS, (NSYMBOL (op))[0]) == NO_TEXT) { BLANK; } indent_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); indent_statement (lhs); BLANK; put_sym (op, !KEYWORD); BLANK; indent_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)) { indent_statement (q); BLANK; FORWARD (q); } put_sym (q, !KEYWORD); BLANK; indent_statement (NEXT (q)); } else if (IS (p, ASSIGNATION)) { NODE_T *dst = SUB (p); NODE_T *bec = NEXT (dst); NODE_T *src = NEXT (bec); indent_statement (dst); BLANK; put_sym (bec, !KEYWORD); BLANK; indent_statement (src); } else if (IS (p, ROUTINE_TEXT)) { NODE_T *q = SUB (p); int units, seps; if (IS (q, PARAMETER_PACK)) { indent_pack (SUB (q)); BLANK; FORWARD (q); } indent_declarer (q); FORWARD (q); put_sym (q, !KEYWORD); // : FORWARD (q); units = 0; seps = 0; count (q, &units, &seps); if (units <= 1) { BLANK; indent_statement (q); } else { put_nl (); indent_statement (q); } } else if (IS (p, IDENTITY_RELATION)) { NODE_T *lhs = SUB (p); NODE_T *op = NEXT (lhs); NODE_T *rhs = NEXT (op); indent_statement (lhs); BLANK; put_sym (op, !KEYWORD); BLANK; indent_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; indent_enclosed (NEXT (q)); } else if (IS (p, CODE_CLAUSE)) { NODE_T *q = SUB (p); put_sym (q, KEYWORD); BLANK; FORWARD (q); indent_collection (SUB (q)); FORWARD (q); put_sym (q, KEYWORD); } } //! @brief Indent identifier declarations. void indent_iddecl (NODE_T * p) { for (; p != NO_NODE; FORWARD (p)) { if (IS (p, IDENTITY_DECLARATION) || IS (p, VARIABLE_DECLARATION)) { indent_iddecl (SUB (p)); } else if (IS (p, QUALIFIER)) { put_sym (SUB (p), !KEYWORD); BLANK; } else if (IS (p, DECLARER)) { indent_declarer (SUB (p)); BLANK; } else if (IS (p, DEFINING_IDENTIFIER)) { NODE_T *q = p; int pop_ind = A68_INDENT (ind); put_sym (q, !KEYWORD); FORWARD (q); if (q != NO_NODE) { // := unit BLANK; put_sym (q, !KEYWORD); BLANK; FORWARD (q); indent_statement (q); } A68_INDENT (ind) = pop_ind; } else if (IS (p, COMMA_SYMBOL)) { put_sym (p, !KEYWORD); BLANK; } } } //! @brief Indent procedure declarations. void indent_procdecl (NODE_T * p) { for (; p != NO_NODE; FORWARD (p)) { if (IS (p, PROCEDURE_DECLARATION) || IS (p, PROCEDURE_VARIABLE_DECLARATION)) { indent_procdecl (SUB (p)); } else if (IS (p, PROC_SYMBOL)) { put_sym (p, KEYWORD); BLANK; A68_INDENT (ind) = A68_INDENT (col); } else if (IS (p, DEFINING_IDENTIFIER)) { NODE_T *q = p; int pop_ind = A68_INDENT (ind); put_sym (q, !KEYWORD); FORWARD (q); BLANK; put_sym (q, !KEYWORD); BLANK; FORWARD (q); indent_statement (q); A68_INDENT (ind) = pop_ind; } else if (IS (p, COMMA_SYMBOL)) { put_sym (p, !KEYWORD); put_nl (); } } } //! @brief Indent operator declarations. void indent_opdecl (NODE_T * p) { for (; p != NO_NODE; FORWARD (p)) { if (IS (p, OPERATOR_DECLARATION) || IS (p, BRIEF_OPERATOR_DECLARATION)) { indent_opdecl (SUB (p)); } else if (IS (p, OP_SYMBOL)) { put_sym (p, KEYWORD); BLANK; A68_INDENT (ind) = A68_INDENT (col); } else if (IS (p, OPERATOR_PLAN)) { indent_declarer (SUB (p)); BLANK; A68_INDENT (ind) = A68_INDENT (col); } else if (IS (p, DEFINING_OPERATOR)) { NODE_T *q = p; int pop_ind = A68_INDENT (ind); put_sym (q, !KEYWORD); FORWARD (q); BLANK; put_sym (q, !KEYWORD); BLANK; FORWARD (q); indent_statement (q); A68_INDENT (ind) = pop_ind; } else if (IS (p, COMMA_SYMBOL)) { put_sym (p, !KEYWORD); put_nl (); } } } //! @brief Indent priority declarations. void indent_priodecl (NODE_T * p) { for (; p != NO_NODE; FORWARD (p)) { if (IS (p, PRIORITY_DECLARATION)) { indent_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. void indent_modedecl (NODE_T * p) { for (; p != NO_NODE; FORWARD (p)) { if (IS (p, MODE_DECLARATION)) { indent_modedecl (SUB (p)); } else if (IS (p, MODE_SYMBOL)) { put_sym (p, KEYWORD); BLANK; A68_INDENT (ind) = A68_INDENT (col); } else if (IS (p, DEFINING_INDICANT)) { NODE_T *q = p; int pop_ind = A68_INDENT (ind); put_sym (q, !KEYWORD); FORWARD (q); BLANK; put_sym (q, !KEYWORD); BLANK; FORWARD (q); indent_declarer (q); A68_INDENT (ind) = pop_ind; } else if (IS (p, COMMA_SYMBOL)) { put_sym (p, !KEYWORD); put_nl (); } } } //! @brief Indent declaration list. void indent_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 = A68_INDENT (ind); indent_iddecl (p); A68_INDENT (ind) = pop_ind; } else if (IS (p, PROCEDURE_DECLARATION) || IS (p, PROCEDURE_VARIABLE_DECLARATION)) { int pop_ind = A68_INDENT (ind); indent_procdecl (p); A68_INDENT (ind) = pop_ind; } else if (IS (p, OPERATOR_DECLARATION) || IS (p, BRIEF_OPERATOR_DECLARATION)) { int pop_ind = A68_INDENT (ind); indent_opdecl (p); A68_INDENT (ind) = pop_ind; } else if (IS (p, PRIORITY_DECLARATION)) { int pop_ind = A68_INDENT (ind); indent_priodecl (p); A68_INDENT (ind) = pop_ind; } else if (IS (p, MODE_DECLARATION)) { int pop_ind = A68_INDENT (ind); indent_modedecl (p); A68_INDENT (ind) = pop_ind; } else if (IS (p, COMMA_SYMBOL)) { put_sym (p, !KEYWORD); if (one_liner) { BLANK; } else { put_nl (); } } else { indent_declist (SUB (p), one_liner); } } } //! @brief Indent serial clause. void indent_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 = A68_INDENT (col); (*what) = p; indent_statement (p); A68_INDENT (ind) = pop_ind; } else if (IS (p, DECLARATION_LIST)) { (*what) = p; indent_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 { indent_serial (SUB (p), one_liner, what); } } } //! @brief Do not pretty-print the environ. void skip_environ (NODE_T * p) { for (; p != NO_NODE; FORWARD (p)) { if (LINE_NUMBER (p) == 0) { pretty_pragment (p, !KEYWORD); skip_environ (SUB (p)); } else { NODE_T *what = NO_NODE; indent_serial (p, !ONE_LINER, &what); } } } //! @brief Indenter driver. void indenter (MODULE_T * q) { A68_INDENT (ind) = 1; A68_INDENT (col) = 1; A68_INDENT (indentation) = OPTION_INDENT (q); A68_INDENT (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, ERROR_ACTION, __func__); FILE_PRETTY_OPENED (q) = A68_TRUE; A68_INDENT (fd) = FILE_PRETTY_FD (q); skip_environ (TOP_NODE (q)); ASSERT (close (A68_INDENT (fd)) == 0); FILE_PRETTY_OPENED (q) = A68_FALSE; return; } algol68g-3.1.2/src/a68g/genie-coerce.c0000644000175000017500000003523414361065320014115 00000000000000//! @file genie.c //! @author J. Marcel van der Veer // //! @section Copyright // // This file is part of Algol68G - an Algol 68 compiler-interpreter. // Copyright 2001-2023 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" #include "a68g-genie.h" #include "a68g-frames.h" #include "a68g-prelude.h" #include "a68g-mp.h" #include "a68g-double.h" #include "a68g-parser.h" #include "a68g-transput.h" //! @brief Unite value in the stack and push result. PROP_T genie_uniting (NODE_T * p) { PROP_T self; ADDR_T sp = A68_SP; MOID_T *u = MOID (p), *v = MOID (SUB (p)); int size = SIZE (u); if (ATTRIBUTE (v) != UNION_SYMBOL) { MOID_T *w = unites_to (v, u); PUSH_UNION (p, (void *) w); EXECUTE_UNIT (SUB (p)); STACK_DNS (p, SUB (v), A68_FP); } else { A68_UNION *m = (A68_UNION *) STACK_TOP; EXECUTE_UNIT (SUB (p)); STACK_DNS (p, SUB (v), A68_FP); VALUE (m) = (void *) unites_to ((MOID_T *) VALUE (m), u); } A68_SP = sp + size; UNIT (&self) = genie_uniting; SOURCE (&self) = p; return self; } //! @brief Store widened constant as a constant. 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 ((size_t) size); SIZE (GINFO (p)) = size; COPY (CONSTANT (GINFO (p)), (void *) (STACK_OFFSET (-size)), size); } } //! @brief (optimised) push INT widened to REAL PROP_T genie_widen_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_ALIGNED (A68_REAL) - SIZE (M_INT)); VALUE (z) = (REAL_T) VALUE (i); STATUS (z) = INIT_MASK; return GPROP (p); } //! @brief Widen value in the stack. PROP_T genie_widen (NODE_T * p) { #define COERCE_FROM_TO(p, a, b) (MOID (p) == (b) && MOID (SUB (p)) == (a)) PROP_T self; UNIT (&self) = genie_widen; SOURCE (&self) = p; // INT widenings. if (COERCE_FROM_TO (p, M_INT, M_REAL)) { (void) genie_widen_int_to_real (p); UNIT (&self) = genie_widen_int_to_real; make_constant_widening (p, M_REAL, &self); } else if (COERCE_FROM_TO (p, M_INT, M_LONG_INT)) { EXECUTE_UNIT (SUB (p)); #if (A68_LEVEL >= 3) genie_lengthen_int_to_int_16 (p); #else genie_lengthen_int_to_mp (p); #endif make_constant_widening (p, M_LONG_INT, &self); } else if (COERCE_FROM_TO (p, M_LONG_INT, M_LONG_LONG_INT)) { EXECUTE_UNIT (SUB (p)); #if (A68_LEVEL >= 3) genie_lengthen_int_16_to_mp (p); #else genie_lengthen_mp_to_long_mp (p); #endif make_constant_widening (p, M_LONG_LONG_INT, &self); } else if (COERCE_FROM_TO (p, M_LONG_INT, M_LONG_REAL)) { #if (A68_LEVEL >= 3) (void) genie_widen_int_16_to_real_16 (p); #else // 1-1 mapping. EXECUTE_UNIT (SUB (p)); #endif make_constant_widening (p, M_LONG_REAL, &self); } else if (COERCE_FROM_TO (p, M_LONG_LONG_INT, M_LONG_LONG_REAL)) { EXECUTE_UNIT (SUB (p)); // 1-1 mapping. make_constant_widening (p, M_LONG_LONG_REAL, &self); } // REAL widenings. else if (COERCE_FROM_TO (p, M_REAL, M_LONG_REAL)) { EXECUTE_UNIT (SUB (p)); #if (A68_LEVEL >= 3) genie_lengthen_real_to_real_16 (p); #else genie_lengthen_real_to_mp (p); #endif make_constant_widening (p, M_LONG_REAL, &self); } else if (COERCE_FROM_TO (p, M_LONG_REAL, M_LONG_LONG_REAL)) { EXECUTE_UNIT (SUB (p)); #if (A68_LEVEL >= 3) genie_lengthen_real_16_to_mp (p); #else genie_lengthen_mp_to_long_mp (p); #endif make_constant_widening (p, M_LONG_LONG_REAL, &self); } else if (COERCE_FROM_TO (p, M_REAL, M_COMPLEX)) { EXECUTE_UNIT (SUB (p)); PUSH_VALUE (p, 0.0, A68_REAL); make_constant_widening (p, M_COMPLEX, &self); } else if (COERCE_FROM_TO (p, M_LONG_REAL, M_LONG_COMPLEX)) { #if (A68_LEVEL >= 3) QUAD_WORD_T z; z.f = 0.0q; EXECUTE_UNIT (SUB (p)); PUSH_VALUE (p, z, A68_LONG_REAL); #else EXECUTE_UNIT (SUB (p)); (void) nil_mp (p, DIGITS (M_LONG_REAL)); make_constant_widening (p, M_LONG_COMPLEX, &self); #endif } else if (COERCE_FROM_TO (p, M_LONG_LONG_REAL, M_LONG_LONG_COMPLEX)) { EXECUTE_UNIT (SUB (p)); (void) nil_mp (p, DIGITS (M_LONG_LONG_REAL)); make_constant_widening (p, M_LONG_LONG_COMPLEX, &self); } else if (COERCE_FROM_TO (p, M_COMPLEX, M_LONG_COMPLEX)) { // COMPLEX widenings. EXECUTE_UNIT (SUB (p)); #if (A68_LEVEL >= 3) genie_lengthen_complex_to_complex_32 (p); #else genie_lengthen_complex_to_mp_complex (p); #endif make_constant_widening (p, M_LONG_COMPLEX, &self); } else if (COERCE_FROM_TO (p, M_LONG_COMPLEX, M_LONG_LONG_COMPLEX)) { EXECUTE_UNIT (SUB (p)); #if (A68_LEVEL >= 3) genie_lengthen_complex_32_to_long_mp_complex (p); #else genie_lengthen_mp_complex_to_long_mp_complex (p); #endif make_constant_widening (p, M_LONG_LONG_COMPLEX, &self); } else if (COERCE_FROM_TO (p, M_BITS, M_LONG_BITS)) { // BITS widenings. EXECUTE_UNIT (SUB (p)); #if (A68_LEVEL >= 3) genie_lengthen_bits_to_double_bits (p); #else genie_lengthen_int_to_mp (p); #endif make_constant_widening (p, M_LONG_BITS, &self); } else if (COERCE_FROM_TO (p, M_LONG_BITS, M_LONG_LONG_BITS)) { #if (A68_LEVEL >= 3) ABEND (A68_TRUE, ERROR_INTERNAL_CONSISTENCY, __func__); #else EXECUTE_UNIT (SUB (p)); genie_lengthen_mp_to_long_mp (p); make_constant_widening (p, M_LONG_LONG_BITS, &self); #endif } else if (COERCE_FROM_TO (p, M_BITS, M_ROW_BOOL) || COERCE_FROM_TO (p, M_BITS, M_FLEX_ROW_BOOL)) { A68_BITS x; A68_REF z, row; A68_ARRAY arr; A68_TUPLE tup; int k; UNSIGNED_T bit; BYTE_T *base; EXECUTE_UNIT (SUB (p)); POP_OBJECT (p, &x, A68_BITS); NEW_ROW_1D (z, row, arr, tup, M_ROW_BOOL, M_BOOL, BITS_WIDTH); base = ADDRESS (&row) + SIZE (M_BOOL) * (BITS_WIDTH - 1); bit = 1; for (k = BITS_WIDTH - 1; k >= 0; k--, base -= SIZE (M_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, M_LONG_BITS, M_ROW_BOOL) || COERCE_FROM_TO (p, M_LONG_BITS, M_FLEX_ROW_BOOL)) { #if (A68_LEVEL >= 3) A68_LONG_BITS x; A68_REF z, row; A68_ARRAY arr; A68_TUPLE tup; int k; UNSIGNED_T bit; BYTE_T *base; EXECUTE_UNIT (SUB (p)); POP_OBJECT (p, &x, A68_LONG_BITS); NEW_ROW_1D (z, row, arr, tup, M_ROW_BOOL, M_BOOL, LONG_BITS_WIDTH); base = ADDRESS (&row) + SIZE (M_BOOL) * (LONG_BITS_WIDTH - 1); bit = 1; for (k = BITS_WIDTH - 1; k >= 0; k--, base -= SIZE (M_BOOL), bit <<= 1) { STATUS ((A68_BOOL *) base) = INIT_MASK; VALUE ((A68_BOOL *) base) = (BOOL_T) ((LW (VALUE (&x)) & bit) != 0 ? A68_TRUE : A68_FALSE); } bit = 1; for (k = BITS_WIDTH - 1; k >= 0; k--, base -= SIZE (M_BOOL), bit <<= 1) { STATUS ((A68_BOOL *) base) = INIT_MASK; VALUE ((A68_BOOL *) base) = (BOOL_T) ((HW (VALUE (&x)) & bit) != 0 ? A68_TRUE : A68_FALSE); } PUSH_REF (p, z); #else EXECUTE_UNIT (SUB (p)); genie_lengthen_long_bits_to_row_bool (p); #endif } else if (COERCE_FROM_TO (p, M_LONG_LONG_BITS, M_ROW_BOOL) || COERCE_FROM_TO (p, M_LONG_LONG_BITS, M_FLEX_ROW_BOOL)) { #if (A68_LEVEL <= 2) EXECUTE_UNIT (SUB (p)); genie_lengthen_long_bits_to_row_bool (p); #endif } else if (COERCE_FROM_TO (p, M_BYTES, M_ROW_CHAR) || COERCE_FROM_TO (p, M_BYTES, M_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, M_LONG_BYTES, M_ROW_CHAR) || COERCE_FROM_TO (p, M_LONG_BYTES, M_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 { diagnostic (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. 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) = M_PROC_VOID; PUSH_PROCEDURE (p, z); } //! @brief (optimised) dereference value of a unit PROP_T genie_dereferencing_quick (NODE_T * p) { A68_REF *z = (A68_REF *) STACK_TOP; ADDR_T pop_sp = A68_SP; BYTE_T *stack_top = STACK_TOP; EXECUTE_UNIT (SUB (p)); A68_SP = 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. 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. 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. 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 = A68_SP; BYTE_T *stack_top = STACK_TOP; // Get REF []. z = (A68_REF *) STACK_TOP; EXECUTE_UNIT (prim); A68_SP = 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 (A68_RUNTIME_ERROR, q, ERROR_INDEX_OUT_OF_BOUNDS); exit_genie (q, A68_RUNTIME_ERROR); } row_index += (SPAN (t) * k - SHIFT (t)); A68_SP = 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. 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 = A68_SP; BYTE_T *stack_top; EXECUTE_UNIT (NEXT (selector)); CHECK_REF (selector, *z, struct_mode); OFFSET (z) += OFFSET (NODE_PACK (SUB (selector))); A68_SP = 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. 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. PROP_T genie_deproceduring (NODE_T * p) { PROP_T self; A68_PROCEDURE *z; ADDR_T pop_sp = A68_SP, pop_fp = A68_FP; 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); A68_SP = pop_sp; genie_check_initialisation (p, (BYTE_T *) z, proc_mode); genie_call_procedure (p, proc_mode, proc_mode, M_VOID, z, pop_sp, pop_fp); STACK_DNS (p, MOID (p), A68_FP); return self; } //! @brief Voiden value in the stack. PROP_T genie_voiding (NODE_T * p) { PROP_T self, source; ADDR_T sp_for_voiding = A68_SP; SOURCE (&self) = p; EXECUTE_UNIT_2 (SUB (p), source); A68_SP = 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. 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_widen (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; } algol68g-3.1.2/src/a68g/mem.c0000644000175000017500000001665414361065320012353 00000000000000//! @file mem.c //! @author J. Marcel van der Veer // //! @section Copyright // // This file is part of Algol68G - an Algol 68 compiler-interpreter. // Copyright 2001-2023 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" #include "a68g-prelude.h" #include "a68g-mp.h" #include "a68g-genie.h" //! @brief Initialise C and A68 heap management. void init_heap (void) { unt heap_a_size = A68_ALIGN (A68 (heap_size)); unt handle_a_size = A68_ALIGN (A68 (handle_pool_size)); unt frame_a_size = A68_ALIGN (A68 (frame_stack_size)); unt expr_a_size = A68_ALIGN (A68 (expr_stack_size)); BYTE_T *core; A68_HEAP = NO_BYTE; A68_HANDLES = NO_BYTE; A68_STACK = NO_BYTE; A68_SP = 0; A68_FP = 0; A68_HP = 0; A68_GLOBALS = 0; REAL_T /* sic */ total_size = A68_ALIGN (heap_a_size + handle_a_size + frame_a_size + 2 * expr_a_size); ABEND (OVER_2G (total_size), ERROR_OUT_OF_CORE_2G, __func__); errno = 0; core = (BYTE_T *) (A68_ALIGN_T *) a68_alloc ((size_t) total_size, __func__, __LINE__); ABEND (core == NO_BYTE, ERROR_OUT_OF_CORE, __func__); A68_HEAP = &(core[0]); A68_HANDLES = &(A68_HEAP[heap_a_size]); A68_STACK = &(A68_HANDLES[handle_a_size]); A68 (fixed_heap_pointer) = A68_ALIGNMENT; A68 (temp_heap_pointer) = total_size; A68 (frame_start) = 0; A68 (frame_end) = A68 (stack_start) = A68 (frame_start) + frame_a_size; A68 (stack_end) = A68 (stack_start) + expr_a_size; ABEND (errno != 0, ERROR_ALLOCATION, __func__); } //! @brief aligned allocation. void *a68_alloc (size_t len, const char *f, int line) { // We need this since malloc aligns to "standard C types". // __float128 is not a standard type, apparently ... // Huge chunks cause trouble! ABEND (len >= 2 * GIGABYTE, ERROR_OUT_OF_CORE, __func__); if (len > 0) { void *p = NULL; int save = errno; size_t align = sizeof (A68_ALIGN_T); errno = 0; #if defined (BUILD_WIN32) p = _aligned_malloc (len, align); #elif defined (HAVE_POSIX_MEMALIGN) errno = posix_memalign (&p, align, len); if (errno != 0) { p = NULL; } #elif defined (HAVE_ALIGNED_ALLOC) // Glibc version of posix_memalign. if (align < sizeof (void *)) { errno = EINVAL; } else { p = aligned_alloc (align, len); } #else // Aude audenda. p = malloc (len); #endif if (p == (void *) NULL || errno != 0) { static char msg[BUFFER_SIZE]; snprintf (msg, SNPRINTF_SIZE, "cannot allocate %lu bytes; called from function %s, line %d", (long unt) len, f, line); ABEND (A68_TRUE, ERROR_ALLOCATION, msg); } errno = save; return p; } else { return (void *) NULL; } } void a68_free (void *z) { if (z != NULL) { #if defined (BUILD_WIN32) // On WIN32, free cannot deallocate _aligned_malloc _aligned_free (z); #else free (z); #endif } } //! @brief Give pointer to block of "s" bytes. BYTE_T *get_heap_space (size_t s) { BYTE_T *z; ABEND (s == 0, ERROR_INVALID_SIZE, __func__); z = (BYTE_T *) (A68_ALIGN_T *) a68_alloc (A68_ALIGN (s), __func__, __LINE__); ABEND (z == NO_BYTE, ERROR_OUT_OF_CORE, __func__); return z; } //! @brief Make a new copy of concatenated strings. char *new_string (char *t, ...) { va_list vl; char *q, *z; int len = 0; va_start (vl, t); q = t; if (q == NO_TEXT) { va_end (vl); return NO_TEXT; } 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". 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". 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. BYTE_T *get_fixed_heap_space (size_t s) { BYTE_T *z; if (A68 (heap_is_fluid)) { z = HEAP_ADDRESS (A68 (fixed_heap_pointer)); A68 (fixed_heap_pointer) += A68_ALIGN ((int) s); // Allow for extra storage for diagnostics etcetera ABEND (A68 (fixed_heap_pointer) >= (A68 (heap_size) - MIN_MEM_SIZE), ERROR_OUT_OF_CORE, __func__); ABEND (((unt) A68 (temp_heap_pointer) - (unt) A68 (fixed_heap_pointer)) <= MIN_MEM_SIZE, ERROR_OUT_OF_CORE, __func__); return z; } else { return get_heap_space (s); } } //! @brief Get (preferably temporary) heap space. BYTE_T *get_temp_heap_space (size_t s) { BYTE_T *z; if (A68 (heap_is_fluid)) { A68 (temp_heap_pointer) -= A68_ALIGN ((int) s); // Allow for extra storage for diagnostics etcetera. ABEND (((unt) A68 (temp_heap_pointer) - (unt) A68 (fixed_heap_pointer)) <= MIN_MEM_SIZE, ERROR_OUT_OF_CORE, __func__); z = HEAP_ADDRESS (A68 (temp_heap_pointer)); return z; } else { return get_heap_space (s); } } //! @brief Get size of stack segment. void get_stack_size (void) { #if defined (BUILD_WIN32) A68 (stack_size) = MEGABYTE; // Guestimate #else struct rlimit limits; errno = 0; // Some systems do not implement RLIMIT_STACK so if getrlimit fails, we do not abend. if (!(getrlimit (RLIMIT_STACK, &limits) == 0 && errno == 0)) { A68 (stack_size) = MEGABYTE; } A68 (stack_size) = (unt) (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 (A68 (stack_size) < KILOBYTE || (A68 (stack_size) > 96 * MEGABYTE && A68 (stack_size) > A68 (frame_stack_size))) { A68 (stack_size) = A68 (frame_stack_size); } #endif A68 (stack_limit) = (A68 (stack_size) > (4 * A68 (storage_overhead)) ? (A68 (stack_size) - A68 (storage_overhead)) : A68 (stack_size) / 2); } //! @brief Free heap allocated by genie. void genie_free (NODE_T * p) { for (; p != NO_NODE; FORWARD (p)) { genie_free (SUB (p)); if (GINFO (p) != NO_GINFO) { a68_free (CONSTANT (GINFO (p))); CONSTANT (GINFO (p)) = NO_CONSTANT; a68_free (COMPILE_NAME (GINFO (p))); COMPILE_NAME (GINFO (p)) = NO_TEXT; } } } //! @brief Free heap allocated by genie. void free_syntax_tree (NODE_T * p) { for (; p != NO_NODE; FORWARD (p)) { free_syntax_tree (SUB (p)); a68_free (NPRAGMENT (p)); NPRAGMENT (p) = NO_TEXT; DIAGNOSTIC_T *d = DIAGNOSTICS (LINE (INFO (p))); while (d != NO_DIAGNOSTIC) { a68_free (TEXT (d)); DIAGNOSTIC_T *stale = d; FORWARD (d); a68_free (stale); } DIAGNOSTICS (LINE (INFO (p))) = NO_DIAGNOSTIC; } } algol68g-3.1.2/src/a68g/mp.c0000644000175000017500000011271014361065320012177 00000000000000//! @file mp.c //! @author J. Marcel van der Veer // //! @section Copyright // // This file is part of Algol68G - an Algol 68 compiler-interpreter. // Copyright 2001-2023 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 . // Multiprecision calculations are useful in these cases: // // Ill-conditioned linear systems // Summation of large series // Long-time or large-scale simulations // Small-scale phenomena // 'Experimental mathematics' // // 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 // // The GNU MPFR library documentation // // Multiprecision libraries are (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 // // Note that recent implementations of GCC make available 64-bit LONG INT and // 128-bit LONG REAL. This suits many multiprecision needs already. // On such platforms, below code is used for LONG LONG modes only. // Now that 64-bit integers are commonplace, this library has been adapted to // exploit them. Having some more digits per word gives performance gain. // This is implemented through macros to keep the library compatible with // old platforms with 32-bit integers and 64-bit doubles. // // 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 thought to be adequate for most multiprecision applications. // // Although the maximum length of a number is in principle unbound, this // implementation is not designed for more than a few hundred decimal places. // At higher precisions, expect 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 a 32- (or 64-) bit type "int". // // Most legacy multiple precision libraries stored numbers as [] int*4. // 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 [] words were a word is real*8 (legacy) or // int*8 (on f.i. ix86 processors that have real*10), trading space for speed. // // Set a base such that "base^2" can be exactly represented by a word. // 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_RADIX + 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. #include "a68g.h" #include "a68g-genie.h" #include "a68g-prelude.h" #include "a68g-double.h" #include "a68g-mp.h" // Internal mp constants. //! @brief Set number of digits for long long numbers. void set_long_mp_digits (int n) { A68_MP (varying_mp_digits) = n; } //! @brief Convert precision to digits for long long number. int width_to_mp_digits (int n) { return (int) ceil ((REAL_T) n / (REAL_T) LOG_MP_RADIX); } //! @brief Unformatted write of z to stdout; debugging routine. #if defined (A68_DEBUG) #if !defined (BUILD_WIN32) void raw_write_mp (char *str, MP_T * z, int digs) { int i; fprintf (stdout, "\n(%d digits)%s", digs, str); for (i = 1; i <= digs; i++) { #if (A68_LEVEL >= 3) fprintf (stdout, " %09lld", (MP_INT_T) MP_DIGIT (z, i)); #else fprintf (stdout, " %07d", (MP_INT_T) MP_DIGIT (z, i)); #endif } fprintf (stdout, " E" A68_LD, (MP_INT_T) MP_EXPONENT (z)); fprintf (stdout, " S" A68_LD, (MP_INT_T) MP_STATUS (z)); fprintf (stdout, "\n"); ASSERT (fflush (stdout) == 0); } #endif #endif //! @brief Whether z is a valid representation for its mode. BOOL_T check_mp_int (MP_T * z, MOID_T * m) { if (m == M_LONG_INT || m == M_LONG_BITS) { return (BOOL_T) ((MP_EXPONENT (z) >= (MP_T) 0) && (MP_EXPONENT (z) < (MP_T) LONG_MP_DIGITS)); } else if (m == M_LONG_LONG_INT || m == M_LONG_LONG_BITS) { return (BOOL_T) ((MP_EXPONENT (z) >= (MP_T) 0) && (MP_EXPONENT (z) < (MP_T) A68_MP (varying_mp_digits))); } return A68_FALSE; } //! @brief |x| MP_T *abs_mp (NODE_T * p, MP_T * z, MP_T * x, int digs) { (void) p; if (x != z) { (void) move_mp (z, x, digs); } MP_DIGIT (z, 1) = ABS (MP_DIGIT (z, 1)); MP_STATUS (z) = (MP_T) INIT_MASK; return z; } //! @brief -x MP_T *minus_mp (NODE_T * p, MP_T * z, MP_T * x, int digs) { (void) p; if (x != z) { (void) move_mp (z, x, digs); } MP_DIGIT (z, 1) = -(MP_DIGIT (z, 1)); MP_STATUS (z) = (MP_T) INIT_MASK; return z; } //! @brief 1 - x MP_T *one_minus_mp (NODE_T * p, MP_T * z, MP_T * x, int digs) { ADDR_T pop_sp = A68_SP; (void) sub_mp (p, z, mp_one (digs), x, digs); A68_SP = pop_sp; return z; } //! @brief x - 1 MP_T *minus_one_mp (NODE_T * p, MP_T * z, MP_T * x, int digs) { ADDR_T pop_sp = A68_SP; (void) sub_mp (p, z, x, mp_one (digs), digs); A68_SP = pop_sp; return z; } //! @brief x + 1 MP_T *plus_one_mp (NODE_T * p, MP_T * z, MP_T * x, int digs) { ADDR_T pop_sp = A68_SP; (void) add_mp (p, z, x, mp_one (digs), digs); A68_SP = pop_sp; return z; } //! @brief Test whether x = y. BOOL_T same_mp (NODE_T * p, MP_T * x, MP_T * y, int digs) { int k; (void) p; if ((MP_STATUS (x) == MP_STATUS (y)) && (MP_EXPONENT (x) == MP_EXPONENT (y))) { for (k = digs; 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. MP_T *align_mp (MP_T * z, INT_T * expo, int digs) { INT_T shift; if (*expo >= 0) { shift = LOG_MP_RADIX - (*expo) % LOG_MP_RADIX - 1; (*expo) /= LOG_MP_RADIX; } else { shift = (-(*expo) - 1) % LOG_MP_RADIX; (*expo) = ((*expo) + 1) / LOG_MP_RADIX; (*expo)--; } // Optimising below code does not make the library noticeably faster. for (INT_T i = 1; i <= shift; i++) { INT_T carry = 0; for (INT_T j = 1; j <= digs; j++) { MP_INT_T k = ((MP_INT_T) MP_DIGIT (z, j)) % 10; MP_DIGIT (z, j) = (MP_T) ((MP_INT_T) (MP_DIGIT (z, j) / 10) + carry * (MP_RADIX / 10)); carry = k; } } return z; } //! @brief Transform string into multi-precision number. MP_T *strtomp (NODE_T * p, MP_T * z, char *s, int digs) { BOOL_T ok = A68_TRUE; errno = 0; SET_MP_ZERO (z, digs); while (IS_SPACE (s[0])) { s++; } // Get the sign. int sign = (s[0] == '-' ? -1 : 1); if (s[0] == '+' || s[0] == '-') { s++; } // Scan mantissa digs and put them into "z". while (s[0] == '0') { s++; } int i = 0, dig = 1; INT_T sum = 0, dot = -1, one = -1, pow = 0, W = MP_RADIX / 10; while (s[i] != NULL_CHAR && dig <= digs && (IS_DIGIT (s[i]) || s[i] == POINT_CHAR)) { if (s[i] == POINT_CHAR) { dot = i; } else { int value = (int) s[i] - (int) '0'; if (one < 0 && value > 0) { one = pow; } sum += W * value; if (one >= 0) { W /= 10; } pow++; if (W < 1) { MP_DIGIT (z, dig++) = (MP_T) sum; sum = 0; W = MP_RADIX / 10; } } i++; } // Store the last digs. if (dig <= digs) { MP_DIGIT (z, dig++) = (MP_T) sum; } // See if there is an exponent. INT_T expo; 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 { expo = 0; ok = (BOOL_T) (s[i] == NULL_CHAR); } // Calculate effective exponent. if (dot >= 0) { if (one > dot) { expo -= one - dot + 1; } else { expo += dot - 1; } } else { expo += pow - 1; } (void) align_mp (z, &expo, digs); MP_EXPONENT (z) = (MP_DIGIT (z, 1) == 0 ? 0 : (MP_T) expo); MP_DIGIT (z, 1) *= sign; check_mp_exp (p, z); if (errno == 0 && ok) { return z; } else { return NaN_MP; } } //! @brief Convert integer to multi-precison number. MP_T *int_to_mp (NODE_T * p, MP_T * z, INT_T k, int digs) { int sign_k = 1; if (k < 0) { k = -k; sign_k = -1; } int m = k, n = 0; while ((m /= MP_RADIX) != 0) { n++; } set_mp (z, 0, n, digs); int j; 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_exp (p, z); return z; } //! @brief Convert unt to multi-precison number. MP_T *unt_to_mp (NODE_T * p, MP_T * z, UNSIGNED_T k, int digs) { int m = k, n = 0; while ((m /= MP_RADIX) != 0) { n++; } set_mp (z, 0, n, digs); int j; for (j = 1 + n; j >= 1; j--) { MP_DIGIT (z, j) = (MP_T) (k % MP_RADIX); k /= MP_RADIX; } check_mp_exp (p, z); return z; } //! @brief Convert multi-precision number to integer. INT_T mp_to_int (NODE_T * p, MP_T * z, int digs) { // This routines looks a lot like "strtol". INT_T expo = (int) MP_EXPONENT (z), sum = 0, weight = 1; if (expo >= digs) { diagnostic (A68_RUNTIME_ERROR, p, ERROR_OUT_OF_BOUNDS, MOID (p)); exit_genie (p, A68_RUNTIME_ERROR); } BOOL_T negative = (BOOL_T) (MP_DIGIT (z, 1) < 0); if (negative) { MP_DIGIT (z, 1) = -MP_DIGIT (z, 1); } int j; for (j = 1 + expo; j >= 1; j--) { if ((MP_INT_T) MP_DIGIT (z, j) > A68_MAX_INT / weight) { diagnostic (A68_RUNTIME_ERROR, p, ERROR_OUT_OF_BOUNDS, M_INT); exit_genie (p, A68_RUNTIME_ERROR); } INT_T term = (MP_INT_T) MP_DIGIT (z, j) * weight; if (sum > A68_MAX_INT - term) { diagnostic (A68_RUNTIME_ERROR, p, ERROR_OUT_OF_BOUNDS, M_INT); exit_genie (p, A68_RUNTIME_ERROR); } sum += term; weight *= MP_RADIX; } return negative ? -sum : sum; } //! @brief Convert REAL_T to multi-precison number. MP_T *real_to_mp (NODE_T * p, MP_T * z, REAL_T x, int digs) { SET_MP_ZERO (z, digs); if (x == 0.0) { return z; } // Small integers can be done better by int_to_mp. if (ABS (x) < MP_RADIX && trunc (x) == x) { return int_to_mp (p, z, (INT_T) trunc (x), digs); } int sign_x = SIGN (x); // Scale to [0, 0.1>. REAL_T a = ABS (x); INT_T expo = (int) log10 (a); a /= ten_up (expo); expo--; if (a >= 1) { a /= 10; expo++; } // Transport digs of x to the mantissa of z. INT_T sum = 0, weight = (MP_RADIX / 10); int j = 1, k; for (k = 0; a != 0.0 && j <= digs && k < REAL_DIGITS; k++) { REAL_T u = a * 10; REAL_T v = floor (u); a = u - v; sum += weight * (INT_T) v; weight /= 10; if (weight < 1) { MP_DIGIT (z, j++) = (MP_T) sum; sum = 0; weight = (MP_RADIX / 10); } } // Store the last digs. if (j <= digs) { MP_DIGIT (z, j) = (MP_T) sum; } (void) align_mp (z, &expo, digs); MP_EXPONENT (z) = (MP_T) expo; MP_DIGIT (z, 1) *= sign_x; check_mp_exp (p, z); return z; } //! @brief Convert multi-precision number to real. REAL_T mp_to_real (NODE_T * p, MP_T * z, int digs) { // This routine looks a lot like "strtod". (void) p; if (MP_EXPONENT (z) * (MP_T) LOG_MP_RADIX <= (MP_T) REAL_MIN_10_EXP) { return 0; } else { REAL_T sum = 0, weight = ten_up ((int) (MP_EXPONENT (z) * LOG_MP_RADIX)); int j; for (j = 1; j <= digs && (j - 2) * LOG_MP_RADIX <= REAL_DIG; j++) { sum += ABS (MP_DIGIT (z, j)) * weight; weight /= MP_RADIX; } CHECK_REAL (p, sum); return MP_DIGIT (z, 1) >= 0 ? sum : -sum; } } //! @brief Normalise positive intermediate, fast. static inline void norm_mp_light (MP_T * w, int k, int digs) { // Bring every digit back to [0 .. MP_RADIX>. MP_T *z = &MP_DIGIT (w, digs); int j; for (j = digs; 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. static inline void norm_mp (MP_T * w, int k, int digs) { // Bring every digit back to [0 .. MP_RADIX>. int j; MP_T *z; for (j = digs, z = &MP_DIGIT (w, digs); j >= k; j--, z--) { if (z[0] >= (MP_T) MP_RADIX) { MP_T carry = (MP_T) ((MP_INT_T) (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) ((MP_INT_T) ((-z[0] - 1) / (MP_T) MP_RADIX)); z[0] += carry * (MP_T) MP_RADIX; z[-1] -= carry; } } } //! @brief Round multi-precision number. static inline void round_internal_mp (MP_T * z, MP_T * w, int digs) { // Assume that w has precision of at least 2 + digs. int last = (MP_DIGIT (w, 1) == 0 ? 2 + digs : 1 + digs); 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); // Hardly ever happens - no need to optimise } if (MP_DIGIT (w, 1) == 0) { (void) move_mp_part (&MP_DIGIT (z, 1), &MP_DIGIT (w, 2), digs); MP_EXPONENT (z) = MP_EXPONENT (w) - 1; } else if (z != w) { (void) move_mp_part (&MP_EXPONENT (z), &MP_EXPONENT (w), (1 + digs)); } // Zero is zero is zero. if (MP_DIGIT (z, 1) == 0) { MP_EXPONENT (z) = (MP_T) 0; } } //! @brief Truncate at decimal point. MP_T *trunc_mp (NODE_T * p, MP_T * z, MP_T * x, int digs) { if (MP_EXPONENT (x) < 0) { SET_MP_ZERO (z, digs); } else if (MP_EXPONENT (x) >= (MP_T) digs) { errno = EDOM; diagnostic (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; (void) move_mp (z, x, digs); for (k = (int) (MP_EXPONENT (x) + 2); k <= digs; k++) { MP_DIGIT (z, k) = (MP_T) 0; } } return z; } //! @brief Floor - largest integer smaller than x. MP_T *floor_mp (NODE_T * p, MP_T * z, MP_T * x, int digs) { if (MP_EXPONENT (x) < 0) { SET_MP_ZERO (z, digs); } else if (MP_EXPONENT (x) >= (MP_T) digs) { errno = EDOM; diagnostic (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; (void) move_mp (z, x, digs); for (k = (int) (MP_EXPONENT (x) + 2); k <= digs; k++) { MP_DIGIT (z, k) = (MP_T) 0; } } if (MP_DIGIT (x, 1) < 0 && ! same_mp (p, z, x, digs)) { (void) minus_one_mp (p, z, z, digs); } return z; } BOOL_T is_int_mp (NODE_T *p, MP_T *z, int digs) { ADDR_T pop_sp = A68_SP; MP_T *y = nil_mp (p, digs); trunc_mp (p, y, z, digs); BOOL_T tst = same_mp (p, y, z, digs); A68_SP = pop_sp; return tst; } //! @brief Shorten and round. MP_T *shorten_mp (NODE_T * p, MP_T * z, int digs, MP_T * x, int digs_x) { if (digs > digs_x) { return lengthen_mp (p, z, digs, x, digs_x); } else if (digs == digs_x) { return move_mp (z, x, digs); } else { // Reserve extra digs for proper rounding. ADDR_T pop_sp = A68_SP; int digs_h = digs + 2; BOOL_T negative = (BOOL_T) (MP_DIGIT (x, 1) < 0); MP_T *w = nil_mp (p, digs_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; (void) move_mp_part (&MP_DIGIT (w, 2), &MP_DIGIT (x, 1), digs + 1); round_internal_mp (z, w, digs); if (negative) { MP_DIGIT (z, 1) = -MP_DIGIT (z, 1); } A68_SP = pop_sp; return z; } } //! @brief Lengthen x and assign to z. MP_T *lengthen_mp (NODE_T * p, MP_T * z, int digs_z, MP_T * x, int digs_x) { if (digs_z < digs_x) { return shorten_mp (p, z, digs_z, x, digs_x); } else if (digs_z == digs_x) { return move_mp (z, x, digs_z); } else { if (z != x) { (void) move_mp_part (&MP_DIGIT (z, 1), &MP_DIGIT (x, 1), digs_x); MP_EXPONENT (z) = MP_EXPONENT (x); MP_STATUS (z) = MP_STATUS (x); } int j; for (j = 1 + digs_x; j <= digs_z; j++) { MP_DIGIT (z, j) = (MP_T) 0; } } return z; } //! @brief Set "z" to the sum of positive "x" and positive "y". MP_T *add_mp (NODE_T * p, MP_T * z, MP_T * x, MP_T * y, int digs) { MP_STATUS (z) = (MP_T) INIT_MASK; // Trivial cases. if (MP_DIGIT (x, 1) == (MP_T) 0) { (void) move_mp (z, y, digs); return z; } else if (MP_DIGIT (y, 1) == 0) { (void) move_mp (z, x, digs); return z; } // We want positive arguments. ADDR_T pop_sp = A68_SP; MP_T x_1 = MP_DIGIT (x, 1), y_1 = MP_DIGIT (y, 1); 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, digs); } else if (x_1 < 0 && y_1 >= 0) { (void) sub_mp (p, z, y, x, digs); } else if (x_1 < 0 && y_1 < 0) { (void) add_mp (p, z, x, y, digs); MP_DIGIT (z, 1) = -MP_DIGIT (z, 1); } else { // Add. int digs_h = 2 + digs; MP_T *w = nil_mp (p, digs_h); if (MP_EXPONENT (x) == MP_EXPONENT (y)) { MP_EXPONENT (w) = (MP_T) 1 + MP_EXPONENT (x); int j; for (j = 1; j <= digs; j++) { MP_DIGIT (w, j + 1) = MP_DIGIT (x, j) + MP_DIGIT (y, j); } MP_DIGIT (w, digs_h) = (MP_T) 0; } else if (MP_EXPONENT (x) > MP_EXPONENT (y)) { int j, shl_y = (int) MP_EXPONENT (x) - (int) MP_EXPONENT (y); MP_EXPONENT (w) = (MP_T) 1 + MP_EXPONENT (x); for (j = 1; j < digs_h; j++) { int i_y = j - shl_y; MP_T x_j = (j > digs ? 0 : MP_DIGIT (x, j)); MP_T y_j = (i_y <= 0 || i_y > digs ? 0 : MP_DIGIT (y, i_y)); MP_DIGIT (w, j + 1) = x_j + y_j; } } else { int j, shl_x = (int) MP_EXPONENT (y) - (int) MP_EXPONENT (x); MP_EXPONENT (w) = (MP_T) 1 + MP_EXPONENT (y); for (j = 1; j < digs_h; j++) { int i_x = j - shl_x; MP_T x_j = (i_x <= 0 || i_x > digs ? 0 : MP_DIGIT (x, i_x)); MP_T y_j = (j > digs ? 0 : MP_DIGIT (y, j)); MP_DIGIT (w, j + 1) = x_j + y_j; } } norm_mp_light (w, 2, digs_h); round_internal_mp (z, w, digs); check_mp_exp (p, z); } // Restore and exit. A68_SP = pop_sp; MP_T 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". MP_T *sub_mp (NODE_T * p, MP_T * z, MP_T * x, MP_T * y, int digs) { MP_STATUS (z) = (MP_T) INIT_MASK; // Trivial cases. if (MP_DIGIT (x, 1) == (MP_T) 0) { (void) move_mp (z, y, digs); MP_DIGIT (z, 1) = -MP_DIGIT (z, 1); return z; } else if (MP_DIGIT (y, 1) == (MP_T) 0) { (void) move_mp (z, x, digs); return z; } // We want positive arguments. ADDR_T pop_sp = A68_SP; MP_T x_1 = MP_DIGIT (x, 1), y_1 = MP_DIGIT (y, 1); MP_DIGIT (x, 1) = ABS (x_1); MP_DIGIT (y, 1) = ABS (y_1); if (x_1 >= 0 && y_1 < 0) { (void) add_mp (p, z, x, y, digs); } else if (x_1 < 0 && y_1 >= 0) { (void) add_mp (p, z, y, x, digs); MP_DIGIT (z, 1) = -MP_DIGIT (z, 1); } else if (x_1 < 0 && y_1 < 0) { (void) sub_mp (p, z, y, x, digs); } else { // Subtract. BOOL_T negative = A68_FALSE; int j, fnz, digs_h = 2 + digs; MP_T *w = nil_mp (p, digs_h); if (MP_EXPONENT (x) == MP_EXPONENT (y)) { MP_EXPONENT (w) = (MP_T) 1 + MP_EXPONENT (x); for (j = 1; j <= digs; j++) { MP_DIGIT (w, j + 1) = MP_DIGIT (x, j) - MP_DIGIT (y, j); } MP_DIGIT (w, digs_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 < digs_h; j++) { int i_y = j - shl_y; MP_T x_j = (j > digs ? 0 : MP_DIGIT (x, j)); MP_T y_j = (i_y <= 0 || i_y > digs ? 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 < digs_h; j++) { int i_x = j - shl_x; MP_T x_j = (i_x <= 0 || i_x > digs ? 0 : MP_DIGIT (x, i_x)); MP_T y_j = (j > digs ? 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 <= digs_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 <= digs_h; j++) { MP_DIGIT (w, j) = -MP_DIGIT (w, j); } } } // Normalise. norm_mp_light (w, 2, digs_h); fnz = -1; for (j = 1; j <= digs_h && fnz < 0; j++) { if (MP_DIGIT (w, j) != 0) { fnz = j; } } if (fnz > 1) { int j2 = fnz - 1; for (j = 1; j <= digs_h - j2; j++) { MP_DIGIT (w, j) = MP_DIGIT (w, j + j2); MP_DIGIT (w, j + j2) = (MP_T) 0; } MP_EXPONENT (w) -= j2; } // Round. round_internal_mp (z, w, digs); if (negative) { MP_DIGIT (z, 1) = -MP_DIGIT (z, 1); } check_mp_exp (p, z); } // Restore and exit. A68_SP = pop_sp; MP_T 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". MP_T *mul_mp (NODE_T * p, MP_T * z, MP_T * x, MP_T * y, int digs) { if (IS_ZERO_MP (x) || IS_ZERO_MP (y)) { SET_MP_ZERO (z, digs); return z; } // Grammar school algorithm with intermittent normalisation. ADDR_T pop_sp = A68_SP; int i, digs_h = 2 + digs; MP_T x_1 = MP_DIGIT (x, 1), y_1 = MP_DIGIT (y, 1); MP_DIGIT (x, 1) = ABS (x_1); MP_DIGIT (y, 1) = ABS (y_1); MP_STATUS (z) = (MP_T) INIT_MASK; MP_T *w = lit_mp (p, 0, MP_EXPONENT (x) + MP_EXPONENT (y) + 1, digs_h); int oflow = (int) FLOOR_MP ((MP_REAL_T) MAX_REPR_INT / (2 * MP_REAL_RADIX * MP_REAL_RADIX)) - 1; for (i = digs; i >= 1; i--) { MP_T yi = MP_DIGIT (y, i); if (yi != 0) { int k = digs_h - i; int j = (k > digs ? digs : k); MP_T *u = &MP_DIGIT (w, i + j), *v = &MP_DIGIT (x, j); if ((digs - i + 1) % oflow == 0) { norm_mp (w, 2, digs_h); } while (j-- >= 1) { (u--)[0] += yi * (v--)[0]; } } } norm_mp (w, 2, digs_h); round_internal_mp (z, w, digs); // Restore and exit. A68_SP = pop_sp; MP_T 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_exp (p, z); return z; } //! @brief Set "z" to the quotient of "x" and "y". MP_T *div_mp (NODE_T * p, MP_T * z, MP_T * x, MP_T * y, int digs) { // This routine is based on // // D. M. Smith, "A Multiple-Precision Division Algorithm" // Mathematics of Computation 66 (1996) 157-163. // // This 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. // // Depending on application, div_mp cost is circa 3 times that of mul_mp. // Therefore Newton-Raphson division makes no sense here. // if (IS_ZERO_MP (y)) { errno = ERANGE; return NaN_MP; } // Determine normalisation interval assuming that q < 2b in each step. #if (A68_LEVEL <= 2) int oflow = (int) FLOOR_MP ((MP_REAL_T) MAX_REPR_INT / (3 * MP_REAL_RADIX * MP_REAL_RADIX)) - 1; #else int oflow = (int) FLOOR_MP ((MP_REAL_T) MAX_REPR_INT / (2 * MP_REAL_RADIX * MP_REAL_RADIX)) - 1; #endif // MP_T x_1 = MP_DIGIT (x, 1), y_1 = MP_DIGIT (y, 1); MP_DIGIT (x, 1) = ABS (x_1); MP_DIGIT (y, 1) = ABS (y_1); MP_STATUS (z) = (MP_T) INIT_MASK; // Slight optimisation when the denominator has few digits. int nzdigs = digs; while (MP_DIGIT (y, nzdigs) == 0 && nzdigs > 1) { nzdigs--; } if (nzdigs == 1 && MP_EXPONENT (y) == 0) { (void) div_mp_digit (p, z, x, MP_DIGIT (y, 1), digs); MP_T 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_exp (p, z); return z; } // Working nominator in which the quotient develops. ADDR_T pop_sp = A68_SP; int wdigs = 4 + digs; MP_T *w = lit_mp (p, 0, MP_EXPONENT (x) - MP_EXPONENT (y), wdigs); (void) move_mp_part (&MP_DIGIT (w, 2), &MP_DIGIT (x, 1), digs); // Estimate the denominator. For small MP_RADIX add: MP_DIGIT (y, 4) / MP_REAL_RADIX. MP_REAL_T den = (MP_DIGIT (y, 1) * MP_REAL_RADIX + MP_DIGIT (y, 2)) * MP_REAL_RADIX + MP_DIGIT (y, 3); MP_T *t = &MP_DIGIT (w, 2); int k, len, first; for (k = 1, len = digs + 2, first = 3; k <= digs + 2; k++, len++, first++, t++) { // Estimate quotient digit. MP_REAL_T q, nom = ((t[-1] * MP_REAL_RADIX + t[0]) * MP_REAL_RADIX + t[1]) * MP_REAL_RADIX + (wdigs >= (first + 2) ? t[2] : 0); if (nom == 0) { q = 0; } else { // Correct the nominator. q = (MP_T) (MP_INT_T) (nom / den); int lim = MINIMUM (len, wdigs); if (nzdigs <= lim - first + 1) { lim = first + nzdigs - 1; } MP_T *u = t, *v = &MP_DIGIT (y, 1); int j; for (j = first; j <= lim; j++) { (u++)[0] -= q * (v++)[0]; } } t[0] += t[-1] * MP_RADIX; t[-1] = q; if (k % oflow == 0 || k == digs + 2) { norm_mp (w, first, wdigs); } } norm_mp (w, 2, digs); round_internal_mp (z, w, digs); // Restore and exit. A68_SP = pop_sp; MP_T 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_exp (p, z); return z; } //! @brief Set "z" to the integer quotient of "x" and "y". MP_T *over_mp (NODE_T * p, MP_T * z, MP_T * x, MP_T * y, int digs) { if (MP_DIGIT (y, 1) == 0) { errno = ERANGE; return NaN_MP; } int digs_g = FUN_DIGITS (digs); ADDR_T pop_sp = A68_SP; MP_T *x_g = len_mp (p, x, digs, digs_g); MP_T *y_g = len_mp (p, y, digs, digs_g); MP_T *z_g = nil_mp (p, digs_g); (void) div_mp (p, z_g, x_g, y_g, digs_g); trunc_mp (p, z_g, z_g, digs_g); (void) shorten_mp (p, z, digs, z_g, digs_g); MP_STATUS (z) = (MP_T) INIT_MASK; // Restore and exit. A68_SP = pop_sp; return z; } //! @brief Set "z" to x mod y. MP_T *mod_mp (NODE_T * p, MP_T * z, MP_T * x, MP_T * y, int digs) { if (MP_DIGIT (y, 1) == 0) { errno = EDOM; return NaN_MP; } int digs_g = FUN_DIGITS (digs); ADDR_T pop_sp = A68_SP; MP_T *x_g = len_mp (p, x, digs, digs_g); MP_T *y_g = len_mp (p, y, digs, digs_g); MP_T *z_g = nil_mp (p, digs_g); // x mod y = x - y * trunc (x / y). (void) over_mp (p, z_g, x_g, y_g, digs_g); (void) mul_mp (p, z_g, y_g, z_g, digs_g); (void) sub_mp (p, z_g, x_g, z_g, digs_g); (void) shorten_mp (p, z, digs, z_g, digs_g); // Restore and exit. A68_SP = pop_sp; return z; } //! @brief Set "z" to the product of x and digit y. MP_T *mul_mp_digit (NODE_T * p, MP_T * z, MP_T * x, MP_T y, int digs) { // This is an O(N) routine for multiplication by a short value. MP_T x_1 = MP_DIGIT (x, 1); int digs_h = 2 + digs; ADDR_T pop_sp = A68_SP; MP_DIGIT (x, 1) = ABS (x_1); MP_STATUS (z) = (MP_T) INIT_MASK; MP_T y_1 = y; y = ABS (y_1); if (y == 2) { (void) add_mp (p, z, x, x, digs); } else { MP_T *w = lit_mp (p, 0, MP_EXPONENT (x) + 1, digs_h); MP_T *u = &MP_DIGIT (w, 1 + digs), *v = &MP_DIGIT (x, digs); int j = digs; while (j-- >= 1) { (u--)[0] += y * (v--)[0]; } norm_mp (w, 2, digs_h); round_internal_mp (z, w, digs); } // Restore and exit. A68_SP = pop_sp; MP_T 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_exp (p, z); return z; } //! @brief Set "z" to x/2. MP_T *half_mp (NODE_T * p, MP_T * z, MP_T * x, int digs) { MP_T *w, z_1, x_1 = MP_DIGIT (x, 1), *u, *v; int j, digs_h = 2 + digs; ADDR_T pop_sp = A68_SP; MP_DIGIT (x, 1) = ABS (x_1); MP_STATUS (z) = (MP_T) INIT_MASK; // Calculate x * 0.5. w = lit_mp (p, 0, MP_EXPONENT (x), digs_h); j = digs; u = &MP_DIGIT (w, 1 + digs); v = &MP_DIGIT (x, digs); while (j-- >= 1) { (u--)[0] += (MP_RADIX / 2) * (v--)[0]; } norm_mp (w, 2, digs_h); round_internal_mp (z, w, digs); // Restore and exit. A68_SP = 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_exp (p, z); return z; } //! @brief Set "z" to x/10. MP_T *tenth_mp (NODE_T * p, MP_T * z, MP_T * x, int digs) { MP_T *w, z_1, x_1 = MP_DIGIT (x, 1), *u, *v; int j, digs_h = 2 + digs; ADDR_T pop_sp = A68_SP; MP_DIGIT (x, 1) = ABS (x_1); MP_STATUS (z) = (MP_T) INIT_MASK; // Calculate x * 0.1. w = lit_mp (p, 0, MP_EXPONENT (x), digs_h); j = digs; u = &MP_DIGIT (w, 1 + digs); v = &MP_DIGIT (x, digs); while (j-- >= 1) { (u--)[0] += (MP_RADIX / 10) * (v--)[0]; } norm_mp (w, 2, digs_h); round_internal_mp (z, w, digs); // Restore and exit. A68_SP = 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_exp (p, z); return z; } //! @brief Set "z" to the quotient of x and digit y. MP_T *div_mp_digit (NODE_T * p, MP_T * z, MP_T * x, MP_T y, int digs) { if (y == 0) { errno = ERANGE; return NaN_MP; } // Determine normalisation interval assuming that q < 2b in each step. #if (A68_LEVEL <= 2) int oflow = (int) FLOOR_MP ((MP_REAL_T) MAX_REPR_INT / (3 * MP_REAL_RADIX * MP_REAL_RADIX)) - 1; #else int oflow = (int) FLOOR_MP ((MP_REAL_T) MAX_REPR_INT / (2 * MP_REAL_RADIX * MP_REAL_RADIX)) - 1; #endif // Work with positive operands. ADDR_T pop_sp = A68_SP; MP_T x_1 = MP_DIGIT (x, 1), y_1 = y; MP_DIGIT (x, 1) = ABS (x_1); MP_STATUS (z) = (MP_T) INIT_MASK; y = ABS (y_1); // if (y == 2) { (void) half_mp (p, z, x, digs); } else if (y == 10) { (void) tenth_mp (p, z, x, digs); } else { int k, first, wdigs = 4 + digs; MP_T *w = lit_mp (p, 0, MP_EXPONENT (x), wdigs); (void) move_mp_part (&MP_DIGIT (w, 2), &MP_DIGIT (x, 1), digs); // Estimate the denominator. MP_REAL_T den = (MP_REAL_T) y * MP_REAL_RADIX * MP_REAL_RADIX; MP_T *t = &MP_DIGIT (w, 2); for (k = 1, first = 3; k <= digs + 2; k++, first++, t++) { // Estimate quotient digit and correct. MP_REAL_T nom = ((t[-1] * MP_REAL_RADIX + t[0]) * MP_REAL_RADIX + t[1]) * MP_REAL_RADIX + (wdigs >= (first + 2) ? t[2] : 0); MP_REAL_T q = (MP_T) (MP_INT_T) (nom / den); t[0] += t[-1] * MP_RADIX - q * y; t[-1] = q; if (k % oflow == 0 || k == digs + 2) { norm_mp (w, first, wdigs); } } norm_mp (w, 2, digs); round_internal_mp (z, w, digs); } // Restore and exit. A68_SP = pop_sp; MP_T 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_exp (p, z); return z; } //! @brief Set "z" to the integer quotient of "x" and "y". MP_T *over_mp_digit (NODE_T * p, MP_T * z, MP_T * x, MP_T y, int digs) { if (y == 0) { errno = ERANGE; return NaN_MP; } int digs_g = FUN_DIGITS (digs); ADDR_T pop_sp = A68_SP; MP_T *x_g = len_mp (p, x, digs, digs_g); MP_T *z_g = nil_mp (p, digs_g); (void) div_mp_digit (p, z_g, x_g, y, digs_g); trunc_mp (p, z_g, z_g, digs_g); (void) shorten_mp (p, z, digs, z_g, digs_g); // Restore and exit. A68_SP = pop_sp; return z; } //! @brief Set "z" to the reciprocal of "x". MP_T *rec_mp (NODE_T * p, MP_T * z, MP_T * x, int digs) { if (IS_ZERO_MP (x)) { errno = ERANGE; return NaN_MP; } ADDR_T pop_sp = A68_SP; (void) div_mp (p, z, mp_one (digs), x, digs); A68_SP = pop_sp; return z; } //! @brief LONG REAL long pi void genie_pi_mp (NODE_T * p) { int digs = DIGITS (MOID (p)); MP_T *z = nil_mp (p, digs); (void) mp_pi (p, z, MP_PI, digs); MP_STATUS (z) = (MP_T) INIT_MASK; } //! @brief Set "z" to "x" ** "n". MP_T *pow_mp_int (NODE_T * p, MP_T * z, MP_T * x, INT_T n, int digs) { ADDR_T pop_sp = A68_SP; int bit, digs_g = FUN_DIGITS (digs); BOOL_T negative; MP_T *x_g = len_mp (p, x, digs, digs_g); MP_T *z_g = lit_mp (p, 1, 0, digs_g); negative = (BOOL_T) (n < 0); if (negative) { n = -n; } bit = 1; while ((unt) bit <= (unt) n) { if (n & bit) { (void) mul_mp (p, z_g, z_g, x_g, digs_g); } (void) mul_mp (p, x_g, x_g, x_g, digs_g); bit <<= 1; } (void) shorten_mp (p, z, digs, z_g, digs_g); A68_SP = pop_sp; if (negative) { (void) rec_mp (p, z, z, digs); } check_mp_exp (p, z); return z; } //! @brief Set "z" to "x" ** "y". MP_T *pow_mp (NODE_T * p, MP_T * z, MP_T * x, MP_T * y, int digs) { PRELUDE_ERROR (ln_mp (p, z, x, digs) == NaN_MP, p, ERROR_INVALID_ARGUMENT, MOID (p)); (void) mul_mp (p, z, y, z, digs); (void) exp_mp (p, z, z, digs); return z; } //! @brief Set "z" to 10 ** "n". MP_T *ten_up_mp (NODE_T * p, MP_T * z, int n, int digs) { #if (A68_LEVEL >= 3) static MP_T y[LOG_MP_RADIX] = { 1, 10, 100, 1000, 10000, 100000, 1000000, 10000000, 100000000 }; #else static MP_T y[LOG_MP_RADIX] = { 1, 10, 100, 1000, 10000, 100000, 1000000 }; #endif if (n >= 0) { set_mp (z, y[n % LOG_MP_RADIX], n / LOG_MP_RADIX, digs); } else { set_mp (z, y[(LOG_MP_RADIX + n % LOG_MP_RADIX) % LOG_MP_RADIX], (n + 1) / LOG_MP_RADIX - 1, digs); } check_mp_exp (p, z); return z; } //! @brief Comparison of "x" and "y". void eq_mp (NODE_T * p, A68_BOOL * z, MP_T * x, MP_T * y, int digs) { ADDR_T pop_sp = A68_SP; MP_T *v = nil_mp (p, digs); (void) sub_mp (p, v, x, y, digs); STATUS (z) = INIT_MASK; VALUE (z) = (MP_DIGIT (v, 1) == 0 ? A68_TRUE : A68_FALSE); A68_SP = pop_sp; } //! @brief Comparison of "x" and "y". void ne_mp (NODE_T * p, A68_BOOL * z, MP_T * x, MP_T * y, int digs) { ADDR_T pop_sp = A68_SP; MP_T *v = nil_mp (p, digs); (void) sub_mp (p, v, x, y, digs); STATUS (z) = INIT_MASK; VALUE (z) = (MP_DIGIT (v, 1) != 0 ? A68_TRUE : A68_FALSE); A68_SP = pop_sp; } //! @brief Comparison of "x" and "y". void lt_mp (NODE_T * p, A68_BOOL * z, MP_T * x, MP_T * y, int digs) { ADDR_T pop_sp = A68_SP; MP_T *v = nil_mp (p, digs); (void) sub_mp (p, v, x, y, digs); STATUS (z) = INIT_MASK; VALUE (z) = (MP_DIGIT (v, 1) < 0 ? A68_TRUE : A68_FALSE); A68_SP = pop_sp; } //! @brief Comparison of "x" and "y". void le_mp (NODE_T * p, A68_BOOL * z, MP_T * x, MP_T * y, int digs) { ADDR_T pop_sp = A68_SP; MP_T *v = nil_mp (p, digs); (void) sub_mp (p, v, x, y, digs); STATUS (z) = INIT_MASK; VALUE (z) = (MP_DIGIT (v, 1) <= 0 ? A68_TRUE : A68_FALSE); A68_SP = pop_sp; } //! @brief Comparison of "x" and "y". void gt_mp (NODE_T * p, A68_BOOL * z, MP_T * x, MP_T * y, int digs) { ADDR_T pop_sp = A68_SP; MP_T *v = nil_mp (p, digs); (void) sub_mp (p, v, x, y, digs); STATUS (z) = INIT_MASK; VALUE (z) = (MP_DIGIT (v, 1) > 0 ? A68_TRUE : A68_FALSE); A68_SP = pop_sp; } //! @brief Comparison of "x" and "y". void ge_mp (NODE_T * p, A68_BOOL * z, MP_T * x, MP_T * y, int digs) { ADDR_T pop_sp = A68_SP; MP_T *v = nil_mp (p, digs); (void) sub_mp (p, v, x, y, digs); STATUS (z) = INIT_MASK; VALUE (z) = (MP_DIGIT (v, 1) >= 0 ? A68_TRUE : A68_FALSE); A68_SP = pop_sp; } //! @brief round (x). MP_T *round_mp (NODE_T * p, MP_T * z, MP_T * x, int digs) { MP_T *y = nil_mp (p, digs); SET_MP_HALF (y, digs); if (MP_DIGIT (x, 1) >= 0) { (void) add_mp (p, z, x, y, digs); (void) trunc_mp (p, z, z, digs); } else { (void) sub_mp (p, z, x, y, digs); (void) trunc_mp (p, z, z, digs); } MP_STATUS (z) = (MP_T) INIT_MASK; return z; } //! @brief Entier (x). MP_T *entier_mp (NODE_T * p, MP_T * z, MP_T * x, int digs) { if (MP_DIGIT (x, 1) >= 0) { (void) trunc_mp (p, z, x, digs); } else { MP_T *y = nil_mp (p, digs); (void) move_mp (y, z, digs); (void) trunc_mp (p, z, x, digs); (void) sub_mp (p, y, y, z, digs); if (MP_DIGIT (y, 1) != 0) { SET_MP_ONE (y, digs); (void) sub_mp (p, z, z, y, digs); } } MP_STATUS (z) = (MP_T) INIT_MASK; return z; } algol68g-3.1.2/src/a68g/single.c0000644000175000017500000010253514361065320013050 00000000000000//! @file single.c //! @author J. Marcel van der Veer // //! @section Copyright // // This file is part of Algol68G - an Algol 68 compiler-interpreter. // Copyright 2001-2023 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" #include "a68g-genie.h" #include "a68g-prelude.h" #include "a68g-double.h" #include "a68g-numbers.h" #include "a68g-stddef.h" // INT operations. // OP - = (INT) INT. A68_MONAD (genie_minus_int, A68_INT, -); // OP ABS = (INT) INT void genie_abs_int (NODE_T * p) { A68_INT *j; POP_OPERAND_ADDRESS (p, j, A68_INT); VALUE (j) = ABS (VALUE (j)); } // OP SIGN = (INT) INT void genie_sign_int (NODE_T * p) { A68_INT *j; POP_OPERAND_ADDRESS (p, j, A68_INT); VALUE (j) = SIGN (VALUE (j)); } // OP ODD = (INT) BOOL void genie_odd_int (NODE_T * p) { A68_INT j; POP_OBJECT (p, &j, A68_INT); PUSH_VALUE (p, (BOOL_T) ((VALUE (&j) >= 0 ? VALUE (&j) : -VALUE (&j)) % 2 == 1), A68_BOOL); } // OP + = (INT, INT) INT void genie_add_int (NODE_T * p) { A68_INT *i, *j; POP_OPERAND_ADDRESSES (p, i, j, A68_INT); errno = 0; VALUE (i) = a68_add_int (VALUE (i), VALUE (j)); MATH_RTE (p, errno != 0, M_INT, "M overflow"); } // OP - = (INT, INT) INT void genie_sub_int (NODE_T * p) { A68_INT *i, *j; POP_OPERAND_ADDRESSES (p, i, j, A68_INT); errno = 0; VALUE (i) = a68_sub_int (VALUE (i), VALUE (j)); MATH_RTE (p, errno != 0, M_INT, "M overflow"); } // OP * = (INT, INT) INT void genie_mul_int (NODE_T * p) { A68_INT *i, *j; POP_OPERAND_ADDRESSES (p, i, j, A68_INT); errno = 0; VALUE (i) = a68_mul_int (VALUE (i), VALUE (j)); MATH_RTE (p, errno != 0, M_INT, "M overflow"); } // OP OVER = (INT, INT) INT void genie_over_int (NODE_T * p) { A68_INT *i, *j; POP_OPERAND_ADDRESSES (p, i, j, A68_INT); errno = 0; VALUE (i) = a68_over_int (VALUE (i), VALUE (j)); MATH_RTE (p, errno != 0, M_INT, ERROR_DIVISION_BY_ZERO); } // OP MOD = (INT, INT) INT void genie_mod_int (NODE_T * p) { A68_INT *i, *j; POP_OPERAND_ADDRESSES (p, i, j, A68_INT); errno = 0; VALUE (i) = a68_mod_int (VALUE (i), VALUE (j)); MATH_RTE (p, errno != 0, M_INT, ERROR_DIVISION_BY_ZERO); } // OP / = (INT, INT) REAL void genie_div_int (NODE_T * p) { A68_INT i, j; POP_OBJECT (p, &j, A68_INT); POP_OBJECT (p, &i, A68_INT); errno = 0; PUSH_VALUE (p, a68_div_int (VALUE (&i), VALUE (&j)), A68_REAL); MATH_RTE (p, errno != 0, M_INT, "M division by zero"); } // OP ** = (INT, INT) INT void genie_pow_int (NODE_T * p) { A68_INT i, j; POP_OBJECT (p, &j, A68_INT); PRELUDE_ERROR (VALUE (&j) < 0, p, ERROR_EXPONENT_INVALID, M_INT); POP_OBJECT (p, &i, A68_INT); errno = 0; PUSH_VALUE (p, a68_m_up_n (VALUE (&i), VALUE (&j)), A68_INT); MATH_RTE (p, errno != 0, M_INT, "M overflow"); } // 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_VALUE (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, >=); // OP +:= = (REF INT, INT) REF INT void genie_plusab_int (NODE_T * p) { genie_f_and_becomes (p, M_REF_INT, genie_add_int); } // OP -:= = (REF INT, INT) REF INT void genie_minusab_int (NODE_T * p) { genie_f_and_becomes (p, M_REF_INT, genie_sub_int); } // OP *:= = (REF INT, INT) REF INT void genie_timesab_int (NODE_T * p) { genie_f_and_becomes (p, M_REF_INT, genie_mul_int); } // OP %:= = (REF INT, INT) REF INT void genie_overab_int (NODE_T * p) { genie_f_and_becomes (p, M_REF_INT, genie_over_int); } // OP %*:= = (REF INT, INT) REF INT void genie_modab_int (NODE_T * p) { genie_f_and_becomes (p, M_REF_INT, genie_mod_int); } // REAL operations. // OP - = (REAL) REAL. A68_MONAD (genie_minus_real, A68_REAL, -); // OP ABS = (REAL) REAL void genie_abs_real (NODE_T * p) { A68_REAL *x; POP_OPERAND_ADDRESS (p, x, A68_REAL); VALUE (x) = ABS (VALUE (x)); } // OP ROUND = (REAL) INT void genie_round_real (NODE_T * p) { A68_REAL x; POP_OBJECT (p, &x, A68_REAL); PRELUDE_ERROR (VALUE (&x) < -(REAL_T) A68_MAX_INT || VALUE (&x) > (REAL_T) A68_MAX_INT, p, ERROR_OUT_OF_BOUNDS, M_INT); PUSH_VALUE (p, a68_round (VALUE (&x)), A68_INT); } // OP ENTIER = (REAL) INT void genie_entier_real (NODE_T * p) { A68_REAL x; POP_OBJECT (p, &x, A68_REAL); PRELUDE_ERROR (VALUE (&x) < -(REAL_T) A68_MAX_INT || VALUE (&x) > (REAL_T) A68_MAX_INT, p, ERROR_OUT_OF_BOUNDS, M_INT); PUSH_VALUE (p, (INT_T) floor (VALUE (&x)), A68_INT); } // OP SIGN = (REAL) INT void genie_sign_real (NODE_T * p) { A68_REAL x; POP_OBJECT (p, &x, A68_REAL); PUSH_VALUE (p, SIGN (VALUE (&x)), A68_INT); } // OP + = (REAL, REAL) REAL 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 (p, VALUE (x)); } // OP - = (REAL, REAL) REAL 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 (p, VALUE (x)); } // OP * = (REAL, REAL) REAL 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 (p, VALUE (x)); } // OP / = (REAL, REAL) REAL 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, M_REAL); VALUE (x) /= VALUE (y); } // OP ** = (REAL, INT) REAL void genie_pow_real_int (NODE_T * p) { A68_INT j; A68_REAL x; REAL_T z; POP_OBJECT (p, &j, A68_INT); POP_OBJECT (p, &x, A68_REAL); z = a68_x_up_n (VALUE (&x), VALUE (&j)); CHECK_REAL (p, z); PUSH_VALUE (p, z, A68_REAL); } // OP ** = (REAL, REAL) REAL void genie_pow_real (NODE_T * p) { A68_REAL x, y; REAL_T z = 0; POP_OBJECT (p, &y, A68_REAL); POP_OBJECT (p, &x, A68_REAL); errno = 0; z = a68_x_up_y (VALUE (&x), VALUE (&y)); MATH_RTE (p, errno != 0, M_REAL, NO_TEXT); PUSH_VALUE (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_VALUE (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, >=); // OP +:= = (REF REAL, REAL) REF REAL void genie_plusab_real (NODE_T * p) { genie_f_and_becomes (p, M_REF_REAL, genie_add_real); } // OP -:= = (REF REAL, REAL) REF REAL void genie_minusab_real (NODE_T * p) { genie_f_and_becomes (p, M_REF_REAL, genie_sub_real); } // OP *:= = (REF REAL, REAL) REF REAL void genie_timesab_real (NODE_T * p) { genie_f_and_becomes (p, M_REF_REAL, genie_mul_real); } // OP /:= = (REF REAL, REAL) REF REAL void genie_divab_real (NODE_T * p) { genie_f_and_becomes (p, M_REF_REAL, genie_div_real); } // @brief PROC (INT) VOID first random void genie_first_random (NODE_T * p) { A68_INT i; POP_OBJECT (p, &i, A68_INT); init_rng ((unt) VALUE (&i)); } // @brief PROC REAL next random void genie_next_random (NODE_T * p) { PUSH_VALUE (p, a68_unif_rand (), A68_REAL); } // @brief PROC REAL rnd void genie_next_rnd (NODE_T * p) { PUSH_VALUE (p, 2 * a68_unif_rand () - 1, A68_REAL); } // BITS operations. // BITS max bits void genie_max_bits (NODE_T * p) { PUSH_VALUE (p, A68_MAX_BITS, A68_BITS); } // OP NOT = (BITS) BITS. A68_MONAD (genie_not_bits, A68_BITS, ~); // OP AND = (BITS, BITS) BITS 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); } // OP OR = (BITS, BITS) BITS 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); } // OP XOR = (BITS, BITS) BITS 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) BITS void genie_add_bits (NODE_T * p) { A68_BITS *i, *j; POP_OPERAND_ADDRESSES (p, i, j, A68_BITS); CHECK_BITS_ADDITION (p, VALUE (i), VALUE (j)); VALUE (i) = VALUE (i) + VALUE (j); } // OP - = (BITS, BITS) BITS void genie_sub_bits (NODE_T * p) { A68_BITS *i, *j; POP_OPERAND_ADDRESSES (p, i, j, A68_BITS); CHECK_BITS_SUBTRACTION (p, VALUE (i), VALUE (j)); VALUE (i) = VALUE (i) - VALUE (j); } // OP * = (BITS, BITS) BITS void genie_times_bits (NODE_T * p) { A68_BITS *i, *j; POP_OPERAND_ADDRESSES (p, i, j, A68_BITS); CHECK_BITS_MULTIPLICATION (p, VALUE (i), VALUE (j)); VALUE (i) = VALUE (i) * VALUE (j); } // OP OVER = (BITS, BITS) BITS void genie_over_bits (NODE_T * p) { A68_BITS *i, *j; POP_OPERAND_ADDRESSES (p, i, j, A68_BITS); PRELUDE_ERROR (VALUE (j) == 0, p, ERROR_DIVISION_BY_ZERO, M_BITS); VALUE (i) = VALUE (i) / VALUE (j); } // OP MOD = (BITS, BITS) BITS void genie_mod_bits (NODE_T * p) { A68_BITS *i, *j; POP_OPERAND_ADDRESSES (p, i, j, A68_BITS); PRELUDE_ERROR (VALUE (j) == 0, p, ERROR_DIVISION_BY_ZERO, M_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_VALUE (p, (BOOL_T) ((UNSIGNED_T) VALUE (&i) OP (UNSIGNED_T) VALUE (&j)), A68_BOOL);\ } A68_CMP_BITS (genie_eq_bits, ==); A68_CMP_BITS (genie_ne_bits, !=); // OP <= = (BITS, BITS) BOOL void genie_le_bits (NODE_T * p) { A68_BITS i, j; POP_OBJECT (p, &j, A68_BITS); POP_OBJECT (p, &i, A68_BITS); PUSH_VALUE (p, (BOOL_T) ((VALUE (&i) | VALUE (&j)) == VALUE (&j)), A68_BOOL); } // OP >= = (BITS, BITS) BOOL void genie_ge_bits (NODE_T * p) { A68_BITS i, j; POP_OBJECT (p, &j, A68_BITS); POP_OBJECT (p, &i, A68_BITS); PUSH_VALUE (p, (BOOL_T) ((VALUE (&i) | VALUE (&j)) == VALUE (&i)), A68_BOOL); } #if (A68_LEVEL >= 3) // OP < = (BITS, BITS) BOOL void genie_lt_bits (NODE_T * p) { A68_BITS i, j; POP_OBJECT (p, &j, A68_BITS); POP_OBJECT (p, &i, A68_BITS); if (VALUE (&i) == VALUE (&j)) { PUSH_VALUE (p, A68_FALSE, A68_BOOL); } else { PUSH_VALUE (p, (BOOL_T) ((VALUE (&i) | VALUE (&j)) == VALUE (&j)), A68_BOOL); } } // OP >= = (BITS, BITS) BOOL void genie_gt_bits (NODE_T * p) { A68_BITS i, j; POP_OBJECT (p, &j, A68_BITS); POP_OBJECT (p, &i, A68_BITS); if (VALUE (&i) == VALUE (&j)) { PUSH_VALUE (p, A68_FALSE, A68_BOOL); } else { PUSH_VALUE (p, (BOOL_T) ((VALUE (&i) | VALUE (&j)) == VALUE (&i)), A68_BOOL); } } #endif // OP SHL = (BITS, INT) BITS 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) { int k; UNSIGNED_T z = VALUE (&i); for (k = 0; k < VALUE (&j); k++) { PRELUDE_ERROR (!MODULAR_MATH (p) && (z & D_SIGN), p, ERROR_MATH, M_BITS); z = z << 1; } PUSH_VALUE (p, z, A68_BITS); } else { PUSH_VALUE (p, VALUE (&i) >> -VALUE (&j), A68_BITS); } } // OP SHR = (BITS, INT) BITS 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 } // OP ROL = (BITS, INT) BITS void genie_rol_bits (NODE_T * p) { A68_BITS i; A68_INT j; int k, n; UNSIGNED_T w; POP_OBJECT (p, &j, A68_INT); POP_OBJECT (p, &i, A68_BITS); CHECK_INT_SHORTEN (p, VALUE (&j)); w = VALUE (&i); n = VALUE (&j); if (n >= 0) { for (k = 0; k < n; k++) { UNSIGNED_T carry = (w & D_SIGN ? 0x1 : 0x0); w = (w << 1) | carry; } } else { n = -n; for (k = 0; k < n; k++) { UNSIGNED_T carry = (w & 0x1 ? D_SIGN : 0x0); w = (w >> 1) | carry; } } PUSH_VALUE (p, w, A68_BITS); } // OP ROR = (BITS, INT) BITS void genie_ror_bits (NODE_T * p) { A68_INT *j; POP_OPERAND_ADDRESS (p, j, A68_INT); VALUE (j) = -VALUE (j); genie_rol_bits (p); } // OP ELEM = (INT, BITS) BOOL void genie_elem_bits (NODE_T * p) { A68_BITS j; A68_INT i; int n; UNSIGNED_T 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, M_INT); for (n = 0; n < (BITS_WIDTH - VALUE (&i)); n++) { mask = mask << 1; } PUSH_VALUE (p, (BOOL_T) ((VALUE (&j) & mask) != 0 ? A68_TRUE : A68_FALSE), A68_BOOL); } // OP SET = (INT, BITS) BITS void genie_set_bits (NODE_T * p) { A68_BITS j; A68_INT i; int n; UNSIGNED_T 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, M_INT); for (n = 0; n < (BITS_WIDTH - VALUE (&i)); n++) { mask = mask << 1; } PUSH_VALUE (p, VALUE (&j) | mask, A68_BITS); } // OP CLEAR = (INT, BITS) BITS void genie_clear_bits (NODE_T * p) { A68_BITS j; A68_INT i; int n; UNSIGNED_T 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, M_INT); for (n = 0; n < (BITS_WIDTH - VALUE (&i)); n++) { mask = mask << 1; } PUSH_VALUE (p, VALUE (&j) & ~mask, A68_BITS); } // OP ABS = (BITS) INT void genie_abs_bits (NODE_T * p) { A68_BITS i; POP_OBJECT (p, &i, A68_BITS); PUSH_VALUE (p, (INT_T) (VALUE (&i)), A68_INT); } // OP BIN = (INT) BITS void genie_bin_int (NODE_T * p) { A68_INT i; POP_OBJECT (p, &i, A68_INT); if (!MODULAR_MATH (p) && VALUE (&i) < 0) { // RR does not convert negative numbers. errno = EDOM; diagnostic (A68_RUNTIME_ERROR, p, ERROR_OUT_OF_BOUNDS, M_BITS); exit_genie (p, A68_RUNTIME_ERROR); } PUSH_VALUE (p, (UNSIGNED_T) (VALUE (&i)), A68_BITS); } // @brief PROC ([] BOOL) BITS bits pack 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_T bit; POP_REF (p, &z); CHECK_REF (p, z, M_ROW_BOOL); GET_DESCRIPTOR (arr, tup, &z); size = ROW_SIZE (tup); PRELUDE_ERROR (size < 0 || size > BITS_WIDTH, p, ERROR_OUT_OF_BOUNDS, M_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), M_BOOL); if (VALUE (boo)) { VALUE (&b) |= bit; } bit <<= 1; } } STATUS (&b) = INIT_MASK; PUSH_OBJECT (p, b, A68_BITS); } // @brief PROC (REAL) REAL sqrt void genie_sqrt_real (NODE_T * p) { C_FUNCTION (p, sqrt); } // @brief PROC (REAL) REAL curt void genie_curt_real (NODE_T * p) { C_FUNCTION (p, cbrt); } // @brief PROC (REAL) REAL exp void genie_exp_real (NODE_T * p) { A68_REAL *x; POP_OPERAND_ADDRESS (p, x, A68_REAL); if (VALUE (x) > LOG_DBL_MAX) { errno = EDOM; } else if (VALUE (x) < LOG_DBL_MIN) { errno = EDOM; } else { errno = 0; VALUE (x) = exp (VALUE (x)); } MATH_RTE (p, errno != 0, M_REAL, NO_TEXT); } // @brief PROC (REAL) REAL ln void genie_ln_real (NODE_T * p) { C_FUNCTION (p, a68_ln); } // @brief PROC (REAL) REAL ln1p void genie_ln1p_real (NODE_T * p) { C_FUNCTION (p, a68_ln1p); } // @brief PROC (REAL) REAL log void genie_log_real (NODE_T * p) { C_FUNCTION (p, log10); } // @brief PROC (REAL) REAL sin void genie_sin_real (NODE_T * p) { C_FUNCTION (p, sin); } // @brief PROC (REAL) REAL arcsin void genie_asin_real (NODE_T * p) { C_FUNCTION (p, asin); } // @brief PROC (REAL) REAL cos void genie_cos_real (NODE_T * p) { C_FUNCTION (p, cos); } // @brief PROC (REAL) REAL arccos void genie_acos_real (NODE_T * p) { C_FUNCTION (p, acos); } // @brief PROC (REAL) REAL tan void genie_tan_real (NODE_T * p) { C_FUNCTION (p, tan); } // @brief PROC (REAL) REAL csc void genie_csc_real (NODE_T * p) { C_FUNCTION (p, a68_csc); } // @brief PROC (REAL) REAL acsc void genie_acsc_real (NODE_T * p) { C_FUNCTION (p, a68_acsc); } // @brief PROC (REAL) REAL sec void genie_sec_real (NODE_T * p) { C_FUNCTION (p, a68_sec); } // @brief PROC (REAL) REAL asec void genie_asec_real (NODE_T * p) { C_FUNCTION (p, a68_asec); } // @brief PROC (REAL) REAL cot void genie_cot_real (NODE_T * p) { C_FUNCTION (p, a68_cot); } // @brief PROC (REAL) REAL acot void genie_acot_real (NODE_T * p) { C_FUNCTION (p, a68_acot); } // @brief PROC (REAL) REAL arctan void genie_atan_real (NODE_T * p) { C_FUNCTION (p, atan); } // @brief PROC (REAL, REAL) REAL arctan2 void genie_atan2_real (NODE_T * p) { A68_REAL *x, *y; POP_OPERAND_ADDRESSES (p, x, y, A68_REAL); errno = 0; PRELUDE_ERROR (VALUE (x) == 0.0 && VALUE (y) == 0.0, p, ERROR_INVALID_ARGUMENT, M_LONG_REAL); VALUE (x) = a68_atan2 (VALUE (y), VALUE (x)); PRELUDE_ERROR (errno != 0, p, ERROR_MATH_EXCEPTION, NO_TEXT); } // @brief PROC (REAL) REAL sindg void genie_sindg_real (NODE_T * p) { C_FUNCTION (p, a68_sindg); } // @brief PROC (REAL) REAL arcsindg void genie_asindg_real (NODE_T * p) { C_FUNCTION (p, a68_asindg); } // @brief PROC (REAL) REAL cosdg void genie_cosdg_real (NODE_T * p) { C_FUNCTION (p, a68_cosdg); } // @brief PROC (REAL) REAL arccosdg void genie_acosdg_real (NODE_T * p) { C_FUNCTION (p, a68_acosdg); } // @brief PROC (REAL) REAL tandg void genie_tandg_real (NODE_T * p) { C_FUNCTION (p, a68_tandg); } // @brief PROC (REAL) REAL arctandg void genie_atandg_real (NODE_T * p) { C_FUNCTION (p, a68_atandg); } // @brief PROC (REAL) REAL cotdg void genie_cotdg_real (NODE_T * p) { C_FUNCTION (p, a68_cotdg); } // @brief PROC (REAL) REAL acotdg void genie_acotdg_real (NODE_T * p) { C_FUNCTION (p, a68_acotdg); } // @brief PROC (REAL, REAL) REAL arctan2dg void genie_atan2dg_real (NODE_T * p) { A68_REAL *x, *y; POP_OPERAND_ADDRESSES (p, x, y, A68_REAL); errno = 0; PRELUDE_ERROR (VALUE (x) == 0.0 && VALUE (y) == 0.0, p, ERROR_INVALID_ARGUMENT, M_LONG_REAL); VALUE (x) = CONST_180_OVER_PI * a68_atan2 (VALUE (y), VALUE (x)); PRELUDE_ERROR (errno != 0, p, ERROR_MATH_EXCEPTION, NO_TEXT); } // @brief PROC (REAL) REAL sinpi void genie_sinpi_real (NODE_T * p) { C_FUNCTION (p, a68_sinpi); } // @brief PROC (REAL) REAL cospi void genie_cospi_real (NODE_T * p) { C_FUNCTION (p, a68_cospi); } // @brief PROC (REAL) REAL tanpi void genie_tanpi_real (NODE_T * p) { C_FUNCTION (p, a68_tanpi); } // @brief PROC (REAL) REAL cotpi void genie_cotpi_real (NODE_T * p) { C_FUNCTION (p, a68_cotpi); } // @brief PROC (REAL) REAL sinh void genie_sinh_real (NODE_T * p) { C_FUNCTION (p, sinh); } // @brief PROC (REAL) REAL cosh void genie_cosh_real (NODE_T * p) { C_FUNCTION (p, cosh); } // @brief PROC (REAL) REAL tanh void genie_tanh_real (NODE_T * p) { C_FUNCTION (p, tanh); } // @brief PROC (REAL) REAL asinh void genie_asinh_real (NODE_T * p) { C_FUNCTION (p, a68_asinh); } // @brief PROC (REAL) REAL acosh void genie_acosh_real (NODE_T * p) { C_FUNCTION (p, a68_acosh); } // @brief PROC (REAL) REAL atanh void genie_atanh_real (NODE_T * p) { C_FUNCTION (p, a68_atanh); } // @brief PROC (REAL) REAL erf void genie_erf_real (NODE_T * p) { C_FUNCTION (p, erf); } // @brief PROC (REAL) REAL inverf void genie_inverf_real (NODE_T * p) { C_FUNCTION (p, a68_inverf); } // @brief PROC (REAL) REAL erfc void genie_erfc_real (NODE_T * p) { C_FUNCTION (p, erfc); } // @brief PROC (REAL) REAL inverfc void genie_inverfc_real (NODE_T * p) { C_FUNCTION (p, a68_inverfc); } // @brief PROC (REAL) REAL gamma void genie_gamma_real (NODE_T * p) { C_FUNCTION (p, tgamma); } // @brief PROC (REAL) REAL ln gamma void genie_ln_gamma_real (NODE_T * p) { C_FUNCTION (p, lgamma); } // @brief PROC (REAL, REAL) REAL beta void genie_beta_real (NODE_T * p) { A68_REAL *x, *y; POP_OPERAND_ADDRESSES (p, x, y, A68_REAL); errno = 0; VALUE (x) = a68_beta (VALUE (x), VALUE (y)); PRELUDE_ERROR (errno != 0, p, ERROR_MATH_EXCEPTION, NO_TEXT); } // @brief PROC (REAL, REAL) REAL ln beta void genie_ln_beta_real (NODE_T * p) { A68_REAL *x, *y; POP_OPERAND_ADDRESSES (p, x, y, A68_REAL); errno = 0; VALUE (x) = a68_ln_beta (VALUE (x), VALUE (y)); PRELUDE_ERROR (errno != 0, p, ERROR_MATH_EXCEPTION, NO_TEXT); } // @brief PROC (REAL, REAL, REAL) REAL cf beta inc void genie_beta_inc_cf_real (NODE_T * p) { A68_REAL *s, *t, *x; POP_3_OPERAND_ADDRESSES (p, s, t, x, A68_REAL); errno = 0; VALUE (s) = a68_beta_inc (VALUE (s), VALUE (t), VALUE (x)); PRELUDE_ERROR (errno != 0, p, ERROR_MATH_EXCEPTION, NO_TEXT); } // @brief PROC (REAL, REAL, REAL) REAL lj e 12 6 void genie_lj_e_12_6 (NODE_T * p) { A68_REAL *e, *s, *r; REAL_T u, u2, u6; POP_3_OPERAND_ADDRESSES (p, e, s, r, A68_REAL); PRELUDE_ERROR (VALUE (r) == 0, p, ERROR_MATH_EXCEPTION, NO_TEXT); u = (VALUE (s) / VALUE (r)); u2 = u * u; u6 = u2 * u2 * u2; VALUE (e) = 4.0 * VALUE (e) * u6 * (u6 - 1.0); } // @brief PROC (REAL, REAL, REAL) REAL lj f 12 6 void genie_lj_f_12_6 (NODE_T * p) { A68_REAL *e, *s, *r; REAL_T u, u2, u6; POP_3_OPERAND_ADDRESSES (p, e, s, r, A68_REAL); PRELUDE_ERROR (VALUE (r) == 0, p, ERROR_MATH_EXCEPTION, NO_TEXT); 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); } // 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. // OP +* = (REAL, REAL) COMPLEX void genie_i_complex (NODE_T * p) { // This function must exist so the code generator recognises it! (void) p; } // OP +* = (INT, INT) COMPLEX void genie_i_int_complex (NODE_T * p) { A68_INT re, im; POP_OBJECT (p, &im, A68_INT); POP_OBJECT (p, &re, A68_INT); PUSH_VALUE (p, (REAL_T) VALUE (&re), A68_REAL); PUSH_VALUE (p, (REAL_T) VALUE (&im), A68_REAL); } // OP RE = (COMPLEX) REAL void genie_re_complex (NODE_T * p) { DECREMENT_STACK_POINTER (p, SIZE (M_REAL)); } // OP IM = (COMPLEX) REAL void genie_im_complex (NODE_T * p) { A68_REAL im; POP_OBJECT (p, &im, A68_REAL); *(A68_REAL *) (STACK_OFFSET (-SIZE (M_REAL))) = im; } // OP - = (COMPLEX) COMPLEX void genie_minus_complex (NODE_T * p) { A68_REAL *re_x, *im_x; im_x = (A68_REAL *) (STACK_OFFSET (-SIZE (M_REAL))); re_x = (A68_REAL *) (STACK_OFFSET (-2 * SIZE (M_REAL))); VALUE (im_x) = -VALUE (im_x); VALUE (re_x) = -VALUE (re_x); (void) p; } // ABS = (COMPLEX) REAL void genie_abs_complex (NODE_T * p) { A68_REAL re_x, im_x; POP_COMPLEX (p, &re_x, &im_x); PUSH_VALUE (p, a68_hypot (VALUE (&re_x), VALUE (&im_x)), A68_REAL); } // OP ARG = (COMPLEX) REAL 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, M_COMPLEX); PUSH_VALUE (p, atan2 (VALUE (&im_x), VALUE (&re_x)), A68_REAL); } // OP CONJ = (COMPLEX) COMPLEX void genie_conj_complex (NODE_T * p) { A68_REAL *im; POP_OPERAND_ADDRESS (p, im, A68_REAL); VALUE (im) = -VALUE (im); } // OP + = (COMPLEX, COMPLEX) COMPLEX 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 (M_REAL))); re_x = (A68_REAL *) (STACK_OFFSET (-2 * SIZE (M_REAL))); VALUE (im_x) += VALUE (&im_y); VALUE (re_x) += VALUE (&re_y); CHECK_COMPLEX (p, VALUE (re_x), VALUE (im_x)); } // OP - = (COMPLEX, COMPLEX) COMPLEX 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 (M_REAL))); re_x = (A68_REAL *) (STACK_OFFSET (-2 * SIZE (M_REAL))); VALUE (im_x) -= VALUE (&im_y); VALUE (re_x) -= VALUE (&re_y); CHECK_COMPLEX (p, VALUE (re_x), VALUE (im_x)); } // OP * = (COMPLEX, COMPLEX) COMPLEX void genie_mul_complex (NODE_T * p) { A68_REAL re_x, im_x, re_y, im_y; REAL_T 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 (p, re, im); PUSH_COMPLEX (p, re, im); } // OP / = (COMPLEX, COMPLEX) COMPLEX void genie_div_complex (NODE_T * p) { A68_REAL re_x, im_x, re_y, im_y; REAL_T 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, M_COMPLEX); #endif if (ABS (VALUE (&re_y)) >= ABS (VALUE (&im_y))) { REAL_T 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 { REAL_T 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 (p, re, im); PUSH_COMPLEX (p, re, im); } // OP ** = (COMPLEX, INT) COMPLEX void genie_pow_complex_int (NODE_T * p) { A68_REAL re_x, im_x; REAL_T re_y, im_y, re_z, im_z, rea; A68_INT j; INT_T 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_T) expo <= (UNSIGNED_T) (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 (p, re_z, im_z); if (negative) { PUSH_VALUE (p, 1.0, A68_REAL); PUSH_VALUE (p, 0.0, A68_REAL); PUSH_VALUE (p, re_z, A68_REAL); PUSH_VALUE (p, im_z, A68_REAL); genie_div_complex (p); } else { PUSH_VALUE (p, re_z, A68_REAL); PUSH_VALUE (p, im_z, A68_REAL); } } // OP = = (COMPLEX, COMPLEX) BOOL 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_VALUE (p, (BOOL_T) ((VALUE (&re_x) == VALUE (&re_y)) && (VALUE (&im_x) == VALUE (&im_y))), A68_BOOL); } // OP /= = (COMPLEX, COMPLEX) BOOL 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_VALUE (p, (BOOL_T) ! ((VALUE (&re_x) == VALUE (&re_y)) && (VALUE (&im_x) == VALUE (&im_y))), A68_BOOL); } // OP +:= = (REF COMPLEX, COMPLEX) REF COMPLEX void genie_plusab_complex (NODE_T * p) { genie_f_and_becomes (p, M_REF_COMPLEX, genie_add_complex); } // OP -:= = (REF COMPLEX, COMPLEX) REF COMPLEX void genie_minusab_complex (NODE_T * p) { genie_f_and_becomes (p, M_REF_COMPLEX, genie_sub_complex); } // OP *:= = (REF COMPLEX, COMPLEX) REF COMPLEX void genie_timesab_complex (NODE_T * p) { genie_f_and_becomes (p, M_REF_COMPLEX, genie_mul_complex); } // OP /:= = (REF COMPLEX, COMPLEX) REF COMPLEX void genie_divab_complex (NODE_T * p) { genie_f_and_becomes (p, M_REF_COMPLEX, genie_div_complex); } #define C_C_FUNCTION(p, f)\ A68_REAL re, im;\ COMPLEX_T z;\ POP_OBJECT (p, &im, A68_REAL);\ POP_OBJECT (p, &re, A68_REAL);\ errno = 0;\ z = VALUE (&re) + VALUE (&im) * _Complex_I;\ z = f (z);\ PUSH_VALUE (p, (REAL_T) creal (z), A68_REAL);\ PUSH_VALUE (p, (REAL_T) cimag (z), A68_REAL);\ MATH_RTE (p, errno != 0, M_COMPLEX, NO_TEXT); // @brief PROC (COMPLEX) COMPLEX csqrt void genie_sqrt_complex (NODE_T * p) { C_C_FUNCTION (p, csqrt); } // @brief PROC (COMPLEX) COMPLEX cexp void genie_exp_complex (NODE_T * p) { C_C_FUNCTION (p, cexp); } // @brief PROC (COMPLEX) COMPLEX cln void genie_ln_complex (NODE_T * p) { C_C_FUNCTION (p, clog); } // @brief PROC (COMPLEX) COMPLEX csin void genie_sin_complex (NODE_T * p) { C_C_FUNCTION (p, csin); } // @brief PROC (COMPLEX) COMPLEX ccos void genie_cos_complex (NODE_T * p) { C_C_FUNCTION (p, ccos); } // @brief PROC (COMPLEX) COMPLEX ctan void genie_tan_complex (NODE_T * p) { C_C_FUNCTION (p, ctan); } // @brief PROC carcsin= (COMPLEX) COMPLEX void genie_asin_complex (NODE_T * p) { C_C_FUNCTION (p, casin); } // @brief PROC (COMPLEX) COMPLEX carccos void genie_acos_complex (NODE_T * p) { C_C_FUNCTION (p, cacos); } // @brief PROC (COMPLEX) COMPLEX carctan void genie_atan_complex (NODE_T * p) { C_C_FUNCTION (p, catan); } // @brief PROC (COMPLEX) COMPLEX csinh void genie_sinh_complex (NODE_T * p) { C_C_FUNCTION (p, csinh); } // @brief PROC (COMPLEX) COMPLEX ccosh void genie_cosh_complex (NODE_T * p) { C_C_FUNCTION (p, ccosh); } // @brief PROC (COMPLEX) COMPLEX ctanh void genie_tanh_complex (NODE_T * p) { C_C_FUNCTION (p, ctanh); } // @brief PROC (COMPLEX) COMPLEX carcsinh void genie_asinh_complex (NODE_T * p) { C_C_FUNCTION (p, casinh); } // @brief PROC (COMPLEX) COMPLEX carccosh void genie_acosh_complex (NODE_T * p) { C_C_FUNCTION (p, cacosh); } // @brief PROC (COMPLEX) COMPLEX carctanh void genie_atanh_complex (NODE_T * p) { C_C_FUNCTION (p, catanh); } #define C_C_INLINE(z, x, f)\ COMPLEX_T u = RE (x) + IM (x) * _Complex_I;\ COMPLEX_T v = f (u);\ STATUS_RE (z) = INIT_MASK;\ STATUS_IM (z) = INIT_MASK;\ RE (z) = creal (v);\ IM (z) = cimag (v);\ //! @brief PROC (COMPLEX) COMPLEX csqrt void a68_sqrt_complex (A68_REAL * z, A68_REAL * x) { C_C_INLINE (z, x, csqrt); } //! @brief PROC (COMPLEX) COMPLEX cexp void a68_exp_complex (A68_REAL * z, A68_REAL * x) { C_C_INLINE (z, x, cexp); } //! @brief PROC (COMPLEX) COMPLEX cln void a68_ln_complex (A68_REAL * z, A68_REAL * x) { C_C_INLINE (z, x, clog); } //! @brief PROC (COMPLEX) COMPLEX csin void a68_sin_complex (A68_REAL * z, A68_REAL * x) { C_C_INLINE (z, x, csin); } //! @brief PROC (COMPLEX) COMPLEX ccos void a68_cos_complex (A68_REAL * z, A68_REAL * x) { C_C_INLINE (z, x, ccos); } //! @brief PROC (COMPLEX) COMPLEX ctan void a68_tan_complex (A68_REAL * z, A68_REAL * x) { C_C_INLINE (z, x, ctan); } //! @brief PROC (COMPLEX) COMPLEX casin void a68_asin_complex (A68_REAL * z, A68_REAL * x) { C_C_INLINE (z, x, casin); } //! @brief PROC (COMPLEX) COMPLEX cacos void a68_acos_complex (A68_REAL * z, A68_REAL * x) { C_C_INLINE (z, x, cacos); } //! @brief PROC (COMPLEX) COMPLEX catan void a68_atan_complex (A68_REAL * z, A68_REAL * x) { C_C_INLINE (z, x, catan); } //! @brief PROC (COMPLEX) COMPLEX csinh void a68_sinh_complex (A68_REAL * z, A68_REAL * x) { C_C_INLINE (z, x, csinh); } //! @brief PROC (COMPLEX) COMPLEX ccosh void a68_cosh_complex (A68_REAL * z, A68_REAL * x) { C_C_INLINE (z, x, ccosh); } //! @brief PROC (COMPLEX) COMPLEX ctanh void a68_tanh_complex (A68_REAL * z, A68_REAL * x) { C_C_INLINE (z, x, ctanh); } //! @brief PROC (COMPLEX) COMPLEX casinh void a68_asinh_complex (A68_REAL * z, A68_REAL * x) { C_C_INLINE (z, x, casinh); } //! @brief PROC (COMPLEX) COMPLEX cacosh void a68_acosh_complex (A68_REAL * z, A68_REAL * x) { C_C_INLINE (z, x, cacosh); } //! @brief PROC (COMPLEX) COMPLEX catanh void a68_atanh_complex (A68_REAL * z, A68_REAL * x) { C_C_INLINE (z, x, catanh); } //! @brief PROC (INT, INT) REAL choose void genie_fact_real (NODE_T * p) { A68_INT n; POP_OBJECT (p, &n, A68_INT); errno = 0; PUSH_VALUE (p, a68_fact (VALUE (&n)), A68_REAL); MATH_RTE (p, errno != 0, M_INT, NO_TEXT); } //! @brief PROC (INT, INT) REAL ln fact void genie_ln_fact_real (NODE_T * p) { A68_INT n; POP_OBJECT (p, &n, A68_INT); errno = 0; PUSH_VALUE (p, a68_ln_fact (VALUE (&n)), A68_REAL); MATH_RTE (p, errno != 0, M_INT, NO_TEXT); } void genie_choose_real (NODE_T * p) { A68_INT n, m; POP_OBJECT (p, &m, A68_INT); POP_OBJECT (p, &n, A68_INT); errno = 0; PUSH_VALUE (p, a68_choose (VALUE (&n), VALUE (&m)), A68_REAL); MATH_RTE (p, errno != 0, M_INT, NO_TEXT); } //! @brief PROC (INT, INT) REAL ln choose void genie_ln_choose_real (NODE_T * p) { A68_INT n, m; POP_OBJECT (p, &m, A68_INT); POP_OBJECT (p, &n, A68_INT); errno = 0; PUSH_VALUE (p, a68_ln_choose (VALUE (&n), VALUE (&m)), A68_REAL); MATH_RTE (p, errno != 0, M_INT, NO_TEXT); } // OP / = (COMPLEX, COMPLEX) COMPLEX void a68_div_complex (A68_REAL * z, A68_REAL * x, A68_REAL * y) { if (RE (y) == 0 && IM (y) == 0) { STATUS_RE (z) = INIT_MASK; STATUS_IM (z) = INIT_MASK; RE (z) = 0.0; IM (z) = 0.0; errno = EDOM; } else if (fabs (RE (y)) >= fabs (IM (y))) { REAL_T r = IM (y) / RE (y), den = RE (y) + r * IM (y); RE (z) = (RE (x) + r * IM (x)) / den; IM (z) = (IM (x) - r * RE (x)) / den; } else { REAL_T 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; } } algol68g-3.1.2/src/a68g/compiler-folder.c0000644000175000017500000003215014361065320014645 00000000000000//! @file compiler.c //! @author J. Marcel van der Veer // //! @section Copyright // // This file is part of Algol68G - an Algol 68 compiler-interpreter. // Copyright 2001-2023 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" #include "a68g-prelude.h" #include "a68g-genie.h" #include "a68g-listing.h" #include "a68g-mp.h" #include "a68g-optimiser.h" #include "a68g-compiler.h" #include "a68g-parser.h" #include "a68g-transput.h" // Constant folder . // Uses interpreter routines to calculate compile-time expressions. //! @brief Whether mode is handled by the constant folder. BOOL_T folder_mode (MOID_T * m) { if (primitive_mode (m)) { return A68_TRUE; } else if (m == M_COMPLEX) { return A68_TRUE; } else { return A68_FALSE; } } // Constant unit check. //! @brief Whether constant collateral clause. 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. 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. 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. 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. BOOL_T constant_call (NODE_T * p) { if (IS (p, CALL)) { NODE_T *prim = SUB (p); NODE_T *idf = stems_from (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. 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. 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. 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, REAL, COMPLEX)) { return constant_unit (SUB (p)); } else { return A68_FALSE; } } else if (IS (p, IDENTIFIER)) { if (A68_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 (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 primitive_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. 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 (A68_SYNTAX_ERROR, p, ERROR_IN_DENOTATION, MODE (mode));\ }\ PUSH_VALUE (p, VALUE (&z), decl);} if (MOID (p) == M_INT) { PUSH_DENOTATION (INT, A68_INT); } else if (MOID (p) == M_REAL) { PUSH_DENOTATION (REAL, A68_REAL); } else if (MOID (p) == M_BOOL) { PUSH_DENOTATION (BOOL, A68_BOOL); } else if (MOID (p) == M_CHAR) { if ((NSYMBOL (p))[0] == NULL_CHAR) { PUSH_VALUE (p, NULL_CHAR, A68_CHAR); } else { PUSH_VALUE (p, (NSYMBOL (p))[0], A68_CHAR); } } else if (MOID (p) == M_BITS) { PUSH_DENOTATION (BITS, A68_BITS); } #undef PUSH_DENOTATION } //! @brief Push widening. 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_VALUE (p, (REAL_T) VALUE (&k), A68_REAL); } else if (WIDEN_TO (p, REAL, COMPLEX)) { PUSH_VALUE (p, 0.0, A68_REAL); } } //! @brief Code collateral units. 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. 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. 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 (A68_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 = stems_from (prim, IDENTIFIER); push_argument (args); (void) (*(PROCEDURE (TAX (idf)))) (p); } else if (IS (p, CAST)) { push_unit (NEXT_SUB (p)); } } //! @brief Code constant folding. void constant_folder (NODE_T * p, FILE_T out, int phase) { if (phase == L_DECLARE) { if (MOID (p) == M_COMPLEX) { char acc[NAME_SIZE]; A68_REAL re, im; (void) make_name (acc, CON, "", NUMBER (p)); A68_SP = 0; push_unit (p); POP_OBJECT (p, &im, A68_REAL); POP_OBJECT (p, &re, A68_REAL); indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "A68_COMPLEX %s = {", acc)); undentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "{INIT_MASK, %.*g}", REAL_WIDTH + 2, VALUE (&re))); undentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, ", {INIT_MASK, %.*g}", REAL_WIDTH + 2, VALUE (&im))); undent (out, "};\n"); ABEND (A68_SP > 0, ERROR_INTERNAL_CONSISTENCY, __func__); } } else if (phase == L_EXECUTE) { if (MOID (p) == M_COMPLEX) { // Done at declaration stage } } else if (phase == L_YIELD) { if (MOID (p) == M_INT) { A68_INT k; A68_SP = 0; push_unit (p); POP_OBJECT (p, &k, A68_INT); ASSERT (snprintf (A68 (edit_line), SNPRINTF_SIZE, A68_LD, VALUE (&k)) >= 0); undent (out, A68 (edit_line)); ABEND (A68_SP > 0, ERROR_INTERNAL_CONSISTENCY, __func__); } else if (MOID (p) == M_REAL) { A68_REAL x; A68_SP = 0; push_unit (p); POP_OBJECT (p, &x, A68_REAL); // Mind overflowing or underflowing values. if (!finite (VALUE (&x))) { A68_OPT (code_errors)++; VALUE (&x) = 0.0; } if (VALUE (&x) == REAL_MAX) { undent (out, "REAL_MAX"); } else if (VALUE (&x) == -REAL_MAX) { undent (out, "(-REAL_MAX)"); } else { ASSERT (snprintf (A68 (edit_line), SNPRINTF_SIZE, "%.*g", REAL_WIDTH + 2, VALUE (&x)) >= 0); undent (out, A68 (edit_line)); } ABEND (A68_SP > 0, ERROR_INTERNAL_CONSISTENCY, __func__); } else if (MOID (p) == M_BOOL) { A68_BOOL b; A68_SP = 0; push_unit (p); POP_OBJECT (p, &b, A68_BOOL); ASSERT (snprintf (A68 (edit_line), SNPRINTF_SIZE, "%s", (VALUE (&b) ? "A68_TRUE" : "A68_FALSE")) >= 0); undent (out, A68 (edit_line)); ABEND (A68_SP > 0, ERROR_INTERNAL_CONSISTENCY, __func__); } else if (MOID (p) == M_CHAR) { A68_CHAR c; A68_SP = 0; push_unit (p); POP_OBJECT (p, &c, A68_CHAR); if (VALUE (&c) == '\'') { undentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "'\\\''")); } else if (VALUE (&c) == '\\') { undentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "'\\\\'")); } else if (VALUE (&c) == NULL_CHAR) { undentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "NULL_CHAR")); } else if (IS_PRINT (VALUE (&c))) { undentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "'%c'", (CHAR_T) VALUE (&c))); } else { undentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "(CHAR_T) %d", VALUE (&c))); } ABEND (A68_SP > 0, ERROR_INTERNAL_CONSISTENCY, __func__); } else if (MOID (p) == M_BITS) { A68_BITS b; A68_SP = 0; push_unit (p); POP_OBJECT (p, &b, A68_BITS); ASSERT (snprintf (A68 (edit_line), SNPRINTF_SIZE, "(UNSIGNED_T) 0x" A68_LX, VALUE (&b)) >= 0); undent (out, A68 (edit_line)); ABEND (A68_SP > 0, ERROR_INTERNAL_CONSISTENCY, __func__); } else if (MOID (p) == M_COMPLEX) { char acc[NAME_SIZE]; (void) make_name (acc, CON, "", NUMBER (p)); undentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "(A68_REAL *) %s", acc)); } } } algol68g-3.1.2/src/a68g/diagnostics.c0000644000175000017500000006310114361065320014071 00000000000000//! @file diagnostics.c //! @author J. Marcel van der Veer // //! @section Copyright // // This file is part of Algol68G - an Algol 68 compiler-interpreter. // Copyright 2001-2023 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" #include "a68g-prelude.h" #include "a68g-mp.h" #include "a68g-genie.h" #include "a68g-transput.h" #include "a68g-parser.h" // Error handling routines. #define TABULATE(n) (8 * (n / 8 + 1) - n) //! @brief Return error test from errno. 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 Whether unprintable control character. BOOL_T unprintable (char ch) { return (BOOL_T) (!IS_PRINT (ch) && ch != TAB_CHAR); } //! @brief Format for printing control 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", (unt) ch) >= 0); } return loc_str; } //! @brief Widen single char to string. 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 . void pretty_diag (FILE_T f, char *p) { int pos = 1, line_width = (f == STDOUT_FILENO ? A68 (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. void abend (char *reason, char *info, char *file, int line) { ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "%s: exiting: %s: %d: %s", A68 (a68_cmd_name), file, line, reason) >= 0); if (info != NO_TEXT) { bufcat (A68 (output_line), ", ", BUFFER_SIZE); bufcat (A68 (output_line), info, BUFFER_SIZE); } if (errno != 0) { bufcat (A68 (output_line), " (", BUFFER_SIZE); bufcat (A68 (output_line), error_specification (), BUFFER_SIZE); bufcat (A68 (output_line), ")", BUFFER_SIZE); } bufcat (A68 (output_line), "\n", BUFFER_SIZE); io_close_tty_line (); pretty_diag (STDOUT_FILENO, A68 (output_line)); a68_exit (EXIT_FAILURE); } //! @brief Position in line . 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. 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. void write_source_line (FILE_T f, LINE_T * p, NODE_T * nwhere, int mask) { char *c, *c0; int continuations = 0; int pos = 5, col; int line_width = (f == STDOUT_FILENO ? A68 (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 (A68 (output_line), SNPRINTF_SIZE, " ") >= 0); } else { ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "%-5d ", NUMBER (p) % 100000) >= 0); } WRITE (f, A68 (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 (A68 (output_line), "", BUFFER_SIZE); line_ended = A68_TRUE; } else { if (IS_GRAPH (c[0])) { char *c1; bufcpy (A68 (output_line), "", BUFFER_SIZE); for (c1 = c; IS_GRAPH (c1[0]) && len <= line_width - 5; c1++, len++) { bufcat (A68 (output_line), char_to_str (c1[0]), BUFFER_SIZE); } if (len > line_width - 5) { bufcpy (A68 (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 (A68 (output_line), "", BUFFER_SIZE); while (n--) { bufcat (A68 (output_line), " ", BUFFER_SIZE); } new_pos = &c[1]; } else if (unprintable (c[0])) { bufcpy (A68 (output_line), ctrl_char ((int) c[0]), BUFFER_SIZE); len = (int) strlen (A68 (output_line)); new_pos = &c[1]; col++; } else { bufcpy (A68 (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, A68 (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 (mask != 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 (A68 (output_line), "-", BUFFER_SIZE); } else if (diags_at_this_pos != 0) { if (mask == A68_NO_DIAGNOSTICS) { bufcpy (A68 (output_line), " ", BUFFER_SIZE); } else if (diags_at_this_pos == 1) { ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "%c", digchar (k)) >= 0); } else { bufcpy (A68 (output_line), "*", BUFFER_SIZE); } } else { if (unprintable (c1[0])) { int n = (int) strlen (ctrl_char (c1[0])); col_2 += 1; bufcpy (A68 (output_line), "", BUFFER_SIZE); while (n--) { bufcat (A68 (output_line), " ", BUFFER_SIZE); } } else if (c1[0] == TAB_CHAR) { int n = TABULATE (col_2); col_2 += n; bufcpy (A68 (output_line), "", BUFFER_SIZE); while (n--) { bufcat (A68 (output_line), " ", BUFFER_SIZE); } } else { bufcpy (A68 (output_line), " ", BUFFER_SIZE); col_2++; } } WRITE (f, A68 (output_line)); } } // Resume pretty printing of line. if (!line_ended) { continuations++; ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "\n.%1d ", continuations) >= 0); WRITE (f, A68 (output_line)); if (continuations >= 9) { WRITE (f, "..."); line_ended = A68_TRUE; } else { c0 = c; pos = 5; col = 1; } } } } // Print the diagnostics. if (mask) { if (DIAGNOSTICS (p) != NO_DIAGNOSTIC) { DIAGNOSTIC_T *d; for (d = DIAGNOSTICS (p); d != NO_DIAGNOSTIC; FORWARD (d)) { if (mask == A68_RUNTIME_ERROR) { if (IS (d, A68_RUNTIME_ERROR) || IS (d, A68_MATH_ERROR) || (IS (d, A68_MATH_WARNING))) { WRITE (f, NEWLINE_STRING); pretty_diag (f, TEXT (d)); } } else { WRITE (f, NEWLINE_STRING); pretty_diag (f, TEXT (d)); } } } } } //! @brief Write diagnostics to STDOUT. 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) || (IS (d, A68_MATH_ERROR)))); } } if (z) { write_source_line (STDOUT_FILENO, p, NO_NODE, what); } } } } //! @brief Give an intelligible error and exit. void scan_error (LINE_T * u, char *v, char *txt) { if (errno != 0) { diagnostic (A68_SUPPRESS_SEVERITY, NO_NODE, txt, u, v, error_specification ()); } else { diagnostic (A68_SUPPRESS_SEVERITY, NO_NODE, txt, u, v, ERROR_UNSPECIFIED); } longjmp (RENDEZ_VOUS (&A68_JOB), 1); } //! @brief Give an intelligible warning. void scan_warning (LINE_T * u, char *v, char *txt) { if (errno != 0) { diagnostic (A68_SUPPRESS_SEVERITY, NO_NODE, txt, u, v, error_specification ()); } else { diagnostic (A68_SUPPRESS_SEVERITY, NO_NODE, txt, u, v, ERROR_UNSPECIFIED); } } //! @brief Get severity text. 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_MATH_WARNING: { return "math warning"; } case A68_WARNING: { return "warning"; } case A68_SUPPRESS_SEVERITY: { return NO_TEXT; } default: { return NO_TEXT; } } } //! @brief Print diagnostic. void write_diagnostic (int sev, char *b) { char st[SMALL_BUFFER_SIZE]; char *severity = get_severity (sev); if (severity == NO_TEXT) { ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "%s: %s.", A68 (a68_cmd_name), b) >= 0); } else { bufcpy (st, get_severity (sev), SMALL_BUFFER_SIZE); ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "%s: %s: %s.", A68 (a68_cmd_name), st, b) >= 0); } io_close_tty_line (); pretty_diag (STDOUT_FILENO, A68 (output_line)); } //! @brief Add diagnostic to source line. 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_ALIGNED (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 (A68 (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 (A68 (edit_line), ATTRIBUTE (n)); if (nt != NO_TEXT) { if (LINE_NUMBER (n) == 0) { ASSERT (snprintf (nst, SNPRINTF_SIZE, ", in %s", nt) >= 0); } else { if (MOID (n) != NO_MOID) { if (LINE_NUMBER (n) == NUMBER (line)) { ASSERT (snprintf (nst, SNPRINTF_SIZE, ", 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, ", 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, ", in %s starting at \"%.64s\" in this line", nt, NSYMBOL (n)) >= 0); } else { ASSERT (snprintf (nst, SNPRINTF_SIZE, ", 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 (&A68_JOB), FILENAME (line)) == 0) { ASSERT (snprintf (a, SNPRINTF_SIZE, "%s: %x: %s", A68 (a68_cmd_name), (unt) k, b) >= 0); } else if (FILENAME (line) != NO_TEXT) { ASSERT (snprintf (a, SNPRINTF_SIZE, "%s: %s: %x: %s", A68 (a68_cmd_name), FILENAME (line), (unt) k, b) >= 0); } else { ASSERT (snprintf (a, SNPRINTF_SIZE, "%s: %x: %s", A68 (a68_cmd_name), (unt) k, b) >= 0); } } else { bufcpy (st, get_severity (sev), SMALL_BUFFER_SIZE); if (FILENAME (line) != NO_TEXT && strcmp (FILE_SOURCE_NAME (&A68_JOB), FILENAME (line)) == 0) { ASSERT (snprintf (a, SNPRINTF_SIZE, "%s: %s: %x: %s", A68 (a68_cmd_name), st, (unt) k, b) >= 0); } else if (FILENAME (line) != NO_TEXT) { ASSERT (snprintf (a, SNPRINTF_SIZE, "%s: %s: %s: %x: %s", A68 (a68_cmd_name), FILENAME (line), st, (unt) k, b) >= 0); } else { ASSERT (snprintf (a, SNPRINTF_SIZE, "%s: %s: %x: %s", A68 (a68_cmd_name), st, (unt) k, b) >= 0); } } // cppcheck might complain here but this memory is not returned, for obvious reasons. *ref_msg = msg; ATTRIBUTE (msg) = sev; if (nst[0] != NULL_CHAR) { bufcat (a, nst, 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; } //! @brief Give a diagnostic message. void diagnostic (STATUS_MASK_T 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, compose = A68_TRUE, issue = A68_TRUE; va_start (args, loc_str); (void) extra_syntax; b[0] = NULL_CHAR; force = (BOOL_T) ((sev & A68_FORCE_DIAGNOSTICS) != 0); sev &= ~A68_FORCE_DIAGNOSTICS; // Node or line? LINE_T *line = NO_LINE; char *pos = NO_TEXT; if (p == NO_NODE) { line = va_arg (args, LINE_T *); pos = va_arg (args, char *); } // No warnings? if (!force && sev == A68_WARNING && OPTION_NO_WARNINGS (&A68_JOB)) { va_end (args); return; } if (!force && sev == A68_MATH_WARNING && OPTION_NO_WARNINGS (&A68_JOB)) { va_end (args); return; } if (sev == A68_WARNING && OPTION_QUIET (&A68_JOB)) { va_end (args); return; } if (sev == A68_MATH_WARNING && OPTION_QUIET (&A68_JOB)) { va_end (args); return; } // Suppressed?. if (sev == A68_ERROR || sev == A68_SYNTAX_ERROR) { if (ERROR_COUNT (&A68_JOB) == MAX_ERRORS) { bufcpy (b, "further diagnostics suppressed", BUFFER_SIZE); compose = A68_FALSE; sev = A68_ERROR; } else if (ERROR_COUNT (&A68_JOB) > MAX_ERRORS) { ERROR_COUNT (&A68_JOB)++; compose = issue = A68_FALSE; } } else if (sev == A68_WARNING || sev == A68_MATH_WARNING) { if (WARNING_COUNT (&A68_JOB) == MAX_ERRORS) { bufcpy (b, "further diagnostics suppressed", BUFFER_SIZE); compose = A68_FALSE; } else if (WARNING_COUNT (&A68_JOB) > MAX_ERRORS) { WARNING_COUNT (&A68_JOB)++; compose = issue = A68_FALSE; } } if (compose) { // Synthesize diagnostic message. if ((sev & A68_NO_SYNTHESIS) != NULL_MASK) { sev &= ~A68_NO_SYNTHESIS; bufcat (b, t, BUFFER_SIZE); } else { // 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 'LONG' // L line number // M moid - if error mode return without giving a message // N mode - M_NIL // O moid - operand // S quoted symbol, when possible with typographical display features // X expected attribute // Y string literal. // Z quoted string literal. 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 (A68 (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 (A68 (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 (A68 (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] == 'K') { bufcat (b, "LONG", BUFFER_SIZE); } else if (t[0] == 'L') { LINE_T *a = va_arg (args, LINE_T *); char d[SMALL_BUFFER_SIZE]; ABEND (a == NO_LINE, ERROR_INTERNAL_CONSISTENCY, __func__); 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 == M_ERROR) { moid = M_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 == M_ERROR) { moid = M_UNDEFINED; } if (moid == M_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] == 'V') { bufcat (b, PACKAGE_STRING, BUFFER_SIZE); } else if (t[0] == 'X') { int att = va_arg (args, int); char z[BUFFER_SIZE]; (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++; } // Add information from errno, if any. if (errno != 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); } } } } // Construct a diagnostic message. if (issue) { if (sev == A68_WARNING) { WARNING_COUNT (&A68_JOB)++; } else { ERROR_COUNT (&A68_JOB)++; } if (p == NO_NODE) { if (line == NO_LINE) { write_diagnostic (sev, b); } else { add_diagnostic (line, pos, NO_NODE, sev, b); } } else { add_diagnostic (NO_LINE, NO_TEXT, p, sev, b); if (sev == A68_MATH_WARNING && p != NO_NODE && LINE (INFO (p)) != NO_LINE) { write_source_line (STDOUT_FILENO, LINE (INFO (p)), p, A68_TRUE); WRITE (STDOUT_FILENO, NEWLINE_STRING); } } } va_end (args); } algol68g-3.1.2/src/a68g/a68glib.c0000644000175000017500000000342214361065320013016 00000000000000//! @file a68glib.c //! @author J. Marcel van der Veer // //! @section Copyright // // This file is part of Algol68G - an Algol 68 compiler-interpreter. // Copyright 2001-2023 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 . // This file consists in part of code licensed under LGPL. // LGPL allows relicensing under GPL (see section 3 of the LGPL version 2.1, // or section 2 option b of the LGPL version 3). // This allows for reuse of LGPL code in A68G which is GPL code. #include "a68g.h" #include "a68g-genie.h" #include "a68g-prelude.h" #include "a68g-double.h" #include "a68g-numbers.h" // Implement the snprintf function. // Copyright (C) 2003-2020 Free Software Foundation, Inc. // Written by Kaveh R. Ghazi . // Based on code from the GCC libiberty library which is covered by // the GNU GPL. // @brief own memmove void *a68_memmove (void *dest, void *src, size_t len) { char *d = dest, *s = src; if (d < s) { while (len--) { *d++ = *s++; } } else { char *lasts = s + (len - 1), *lastd = d + (len - 1); while (len--) { *lastd-- = *lasts--; } } return dest; } algol68g-3.1.2/src/a68g/double-math.c0000644000175000017500000001376014361065320013771 00000000000000//! @file double-math.c //! @author J. Marcel van der Veer // //! @section Copyright // // This file is part of Algol68G - an Algol 68 compiler-interpreter. // Copyright 2001-2023 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 . // // References: // // Milton Abramowitz and Irene Stegun, Handbook of Mathematical Functions, // Dover Publications, New York [1970] // https://en.wikipedia.org/wiki/Abramowitz_and_Stegun #include "a68g.h" #include "a68g-genie.h" #include "a68g-prelude.h" #include "a68g-double.h" #include "a68g-numbers.h" #include "a68g-math.h" #if (A68_LEVEL >= 3) DOUBLE_T a68_beta_inc_16 (DOUBLE_T s, DOUBLE_T t, DOUBLE_T x) { // Incomplete beta function I{x}(s, t). // Continued fraction, see dlmf.nist.gov/8.17; Lentz's algorithm. if (x < 0.0q || x > 1.0q) { errno = ERANGE; return -1.0q; } else { const INT_T lim = 16 * sizeof (DOUBLE_T); BOOL_T cont = A68_TRUE; // Rapid convergence when x <= (s+1)/(s+t+2) or else recursion. if (x > (s + 1.0q) / (s + t + 2.0q)) { // B{x}(s, t) = 1 - B{1-x}(t, s) return 1.0q - a68_beta_inc_16 (s, t, 1.0q - x); } // Lentz's algorithm for continued fraction. DOUBLE_T W = 1.0q, F = 1.0q, c = 1.0q, d = 0.0q; INT_T N, m; for (N = 0, m = 0; cont && N < lim; N++) { DOUBLE_T T; if (N == 0) { T = 1.0q; } else if (N % 2 == 0) { // d{2m} := x m(t-m)/((s+2m-1)(s+2m)) T = x * m * (t - m) / (s + 2.0q * m - 1.0q) / (s + 2.0q * m); } else { // d{2m+1} := -x (s+m)(s+t+m)/((s+2m+1)(s+2m)) T = -x * (s + m) * (s + t + m) / (s + 2.0q * m + 1.0q) / (s + 2.0q * m); m++; } d = 1.0q / (T * d + 1.0q); c = T / c + 1.0q; F *= c * d; if (F == W) { cont = A68_FALSE; } else { W = F; } } // I{x}(s,t)=x^s(1-x)^t / s / B(s,t) F DOUBLE_T beta = expq (lgammaq (s) + lgammaq (t) - lgammaq (s + t)); return powq (x, s) * powq (1.0q - x, t) / s / beta * (F - 1.0q); } } //! @brief PROC (LONG REAL) LONG REAL csc DOUBLE_T a68_csc_16 (DOUBLE_T x) { DOUBLE_T z = sinq (x); A68_OVERFLOW (z == 0.0q); return 1.0q / z; } //! @brief PROC (LONG REAL) LONG REAL acsc DOUBLE_T a68_acsc_16 (DOUBLE_T x) { A68_OVERFLOW (x == 0.0q); return asinq (1.0q / x); } //! @brief PROC (LONG REAL) LONG REAL sec DOUBLE_T a68_sec_16 (DOUBLE_T x) { DOUBLE_T z = cosq (x); A68_OVERFLOW (z == 0.0q); return 1.0q / z; } //! @brief PROC (LONG REAL) LONG REAL asec DOUBLE_T a68_asec_16 (DOUBLE_T x) { A68_OVERFLOW (x == 0.0q); return acosq (1.0q / x); } //! @brief PROC (LONG REAL) LONG REAL cot DOUBLE_T a68_cot_16 (DOUBLE_T x) { DOUBLE_T z = sinq (x); A68_OVERFLOW (z == 0.0q); return cosq (x) / z; } //! @brief PROC (LONG REAL) LONG REAL acot DOUBLE_T a68_acot_16 (DOUBLE_T x) { A68_OVERFLOW (x == 0.0q); return atanq (1 / x); } //! brief PROC (LONG REAL) LONG REAL sindg DOUBLE_T a68_sindg_16 (DOUBLE_T x) { return sin (x * CONST_PI_OVER_180_Q); } //! brief PROC (LONG REAL) LONG REAL cosdg DOUBLE_T a68_cosdg_16 (DOUBLE_T x) { return cos (x * CONST_PI_OVER_180_Q); } //! brief PROC (LONG REAL) LONG REAL tandg DOUBLE_T a68_tandg_16 (DOUBLE_T x) { return tan (x * CONST_PI_OVER_180_Q); } //! brief PROC (LONG REAL) LONG REAL asindg DOUBLE_T a68_asindg_16 (DOUBLE_T x) { return asin (x) * CONST_180_OVER_PI_Q; } //! brief PROC (LONG REAL) LONG REAL acosdg DOUBLE_T a68_acosdg_16 (DOUBLE_T x) { return acos (x) * CONST_180_OVER_PI_Q; } //! brief PROC (LONG REAL) LONG REAL atandg DOUBLE_T a68_atandg_16 (DOUBLE_T x) { return atan (x) * CONST_180_OVER_PI_Q; } // PROC (LONG REAL) LONG REAL cotdg DOUBLE_T a68_cotdg_16 (DOUBLE_T x) { DOUBLE_T z = a68_sindg (x); A68_OVERFLOW (z == 0); return a68_cosdg (x) / z; } // PROC (LONG REAL) LONG REAL acotdg DOUBLE_T a68_acotdg_16 (DOUBLE_T z) { A68_OVERFLOW (z == 0); return a68_atandg (1 / z); } // @brief PROC (LONG REAL) LONG REAL sinpi DOUBLE_T a68_sinpi_16 (DOUBLE_T x) { x = fmodq (x, 2.0q); if (x <= -1.0q) { x += 2.0q; } else if (x > 1.0q) { x -= 2.0q; } // x in <-1, 1]. if (x == 0.0q || x == 1.0q) { return 0.0q; } else if (x == 0.5q) { return 1.0q; } if (x == -0.5q) { return -1.0q; } else { return sinq (CONST_PI_Q * x); } } // @brief PROC (LONG REAL) LONG REAL cospi DOUBLE_T a68_cospi_16 (DOUBLE_T x) { x = fmodq (fabsq (x), 2.0q); // x in [0, 2>. if (x == 0.5q || x == 1.5q) { return 0.0q; } else if (x == 0.0q) { return 1.0q; } else if (x == 1.0q) { return -1.0q; } else { return cosq (CONST_PI_Q * x); } } // @brief PROC (LONG REAL) LONG REAL tanpi DOUBLE_T a68_tanpi_16 (DOUBLE_T x) { x = fmodq (x, 1.0q); if (x <= -0.5q) { x += 1.0q; } else if (x > 0.5q) { x -= 1.0q; } // x in <-1/2, 1/2]. A68_OVERFLOW (x == 0.5q); if (x == -0.25q) { return -1.0q; } else if (x == 0) { return 0.0q; } else if (x == 0.25q) { return 1.0q; } else { return a68_sinpi_16 (x) / a68_cospi_16 (x); } } // @brief PROC (LONG REAL) LONG REAL cotpi DOUBLE_T a68_cotpi_16 (DOUBLE_T x) { x = fmodq (x, 1.0q); if (x <= -0.5q) { x += 1.0q; } else if (x > 0.5q) { x -= 1.0q; } // x in <-1/2, 1/2]. A68_OVERFLOW (x == 0.0q); if (x == -0.25q) { return -1.0q; } else if (x == 0.25q) { return 1.0q; } else if (x == 0.5q) { return 0.0q; } else { return a68_cospi_16 (x) / a68_sinpi_16 (x); } } #endif algol68g-3.1.2/src/a68g/compiler.c0000644000175000017500000007341614361065320013406 00000000000000//! @file compiler.c //! @author J. Marcel van der Veer // //! @section Copyright // // This file is part of Algol68G - an Algol 68 compiler-interpreter. // Copyright 2001-2023 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 . // The compiler 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 // // We don't do stuff that is easily recognised by a back end compiler, // for instance symbolic simplification. #include "a68g.h" #include "a68g-prelude.h" #include "a68g-genie.h" #include "a68g-listing.h" #include "a68g-mp.h" #include "a68g-optimiser.h" #include "a68g-compiler.h" #include "a68g-parser.h" #include "a68g-transput.h" //! @brief Compiler optimisation option string char *optimisation_option (void) { switch (OPTION_OPT_LEVEL (&A68_JOB)) { case OPTIMISE_0:{ return "-Og"; } case OPTIMISE_1:{ return "-O1"; } case OPTIMISE_2:{ return "-O2"; } case OPTIMISE_3:{ return "-O3"; } case OPTIMISE_FAST:{ return "-Ofast"; } default:{ return "-Og"; } } } //! @brief Compiler driver. void compiler (FILE_T out) { ADDR_T pop_temp_heap_pointer = A68 (temp_heap_pointer); if (OPTION_OPT_LEVEL (&A68_JOB) == NO_OPTIMISE) { return; } A68_OPT (indentation) = 0; A68_OPT (code_errors) = 0; A68_OPT (procedures) = 0; A68_OPT (cse_pointer) = 0; A68_OPT (unic_pointer) = 0; A68_OPT (root_idf) = NO_DEC; A68 (global_level) = INT_MAX; A68_GLOBALS = 0; get_global_level (SUB (TOP_NODE (&A68_JOB))); A68 (max_lex_lvl) = 0; genie_preprocess (TOP_NODE (&A68_JOB), &A68 (max_lex_lvl), NULL); get_global_level (TOP_NODE (&A68_JOB)); A68_SP = A68 (stack_start); A68 (expr_stack_limit) = A68 (stack_end) - A68 (storage_overhead); if (OPTION_COMPILE_CHECK (&A68_JOB)) { monadics = monadics_check; dyadics = dyadics_check; functions = functions_check; } else { monadics = monadics_nocheck; dyadics = dyadics_nocheck; functions = functions_nocheck; } if (OPTION_OPT_LEVEL (&A68_JOB) == OPTIMISE_0) { // Allow basic optimisation only. A68_OPT (OPTION_CODE_LEVEL) = 1; write_prelude (out); gen_basics (TOP_NODE (&A68_JOB), out); } else { // Allow all optimisations. A68_OPT (OPTION_CODE_LEVEL) = 9; write_prelude (out); gen_units (TOP_NODE (&A68_JOB), out); } ABEND (A68_OPT (indentation) != 0, ERROR_INTERNAL_CONSISTENCY, __func__); // At the end we discard temporary declarations. A68 (temp_heap_pointer) = pop_temp_heap_pointer; if (OPTION_VERBOSE (&A68_JOB)) { ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "%s: A68_OPT (procedures)=%d unique-names=%d", A68 (a68_cmd_name), A68_OPT (procedures), A68_OPT (unic_pointer)) >= 0); io_close_tty_line (); WRITE (STDOUT_FILENO, A68 (output_line)); } // int k; for (k = 0; k < A68_OPT (unic_pointer); k++) { a68_free (UNIC_NAME (k)); } } // Pretty printing stuff. //! @brief Name formatting char *moid_with_name (char *pre, MOID_T * m, char *post) { static char buf[NAME_SIZE]; char *mode = "MODE", *ref = NO_TEXT; if (m != NO_MOID && IS (m, REF_SYMBOL)) { ref = "REF"; m = SUB (m); } if (m == M_INT) { mode = "INT"; } else if (m == M_REAL) { mode = "REAL"; } else if (m == M_BOOL) { mode = "BOOL"; } else if (m == M_CHAR) { mode = "CHAR"; } else if (m == M_BITS) { mode = "BITS"; } else if (m == M_VOID) { mode = "VOID"; } if (ref == NO_TEXT) { snprintf (buf, NAME_SIZE, "%s%s%s", pre, mode, post); } else { snprintf (buf, NAME_SIZE, "%sREF_%s%s", pre, mode, post); } return buf; } //! @brief Write indented text. void indent (FILE_T out, char *str) { int j = A68_OPT (indentation); if (out == 0) { return; } while (j-- > 0) { WRITE (out, " "); } WRITE (out, str); } //! @brief Write unindented text. void undent (FILE_T out, char *str) { if (out == 0) { return; } WRITE (out, str); } //! @brief Write indent text. void indentf (FILE_T out, int ret) { if (out == 0) { return; } if (ret >= 0) { indent (out, A68 (edit_line)); } else { ABEND (A68_TRUE, ERROR_INTERNAL_CONSISTENCY, error_specification ()); } } //! @brief Write unindent text. void undentf (FILE_T out, int ret) { if (out == 0) { return; } if (ret >= 0) { WRITE (out, A68 (edit_line)); } else { ABEND (A68_TRUE, ERROR_INTERNAL_CONSISTENCY, error_specification ()); } } // Administration of C declarations . // Pretty printing of C declarations. //! @brief Add declaration to a tree. 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, ERROR_INTERNAL_CONSISTENCY, z); return *p; } } *p = (DEC_T *) get_temp_heap_space ((size_t) SIZE_ALIGNED (DEC_T)); TEXT (*p) = z; LEVEL (*p) = level; SUB (*p) = LESS (*p) = MORE (*p) = NO_DEC; return *p; } //! @brief Add declaration to a tree. 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_ALIGNED (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; } //! @brief Print identifiers (following mode). void print_identifiers (FILE_T out, DEC_T * p) { if (p != NO_DEC) { print_identifiers (out, LESS (p)); if (A68_OPT (put_idf_comma)) { WRITE (out, ", "); } else { A68_OPT (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. void print_declarations (FILE_T out, DEC_T * p) { if (p != NO_DEC) { print_declarations (out, LESS (p)); indent (out, TEXT (p)); WRITE (out, " "); A68_OPT (put_idf_comma) = A68_FALSE; print_identifiers (out, SUB (p)); WRITE (out, ";\n"); print_declarations (out, MORE (p)); } } // Administration for common functions. // Otherwise we generate many routines that push 0 or 1 or TRUE etc. //! @brief Make name. char *make_unic_name (char *buf, char *name, char *tag, char *ext) { if (strlen (tag) > 0) { ASSERT (snprintf (buf, NAME_SIZE, "genie_%s_%s_%s", name, tag, ext) >= 0); } else { ASSERT (snprintf (buf, NAME_SIZE, "genie_%s_%s", name, ext) >= 0); } ABEND (strlen (buf) >= NAME_SIZE, ERROR_ACTION, __func__); return buf; } //! @brief Look up a name in the list. char *signed_in_name (char *name) { int k; for (k = 0; k < A68_OPT (unic_pointer); k++) { if (strcmp (UNIC_NAME (k), name) == 0) { return UNIC_NAME (k); } } return NO_TEXT; } //! @brief Enter new name in list, if there is space. void sign_in_name (char *name, int *action) { if (signed_in_name (name)) { *action = UNIC_EXISTS; } else if (A68_OPT (unic_pointer) < MAX_UNIC) { UNIC_NAME (A68_OPT (unic_pointer)) = new_string (name, NO_TEXT); A68_OPT (unic_pointer)++; *action = UNIC_MAKE_NEW; } else { *action = UNIC_MAKE_ALT; } } //! @brief Book identifier to keep track of it for CSE. void sign_in (int action, int phase, char *idf, void *info, int number) { if (A68_OPT (cse_pointer) < MAX_BOOK) { ACTION (&A68_OPT (cse_book)[A68_OPT (cse_pointer)]) = action; PHASE (&A68_OPT (cse_book)[A68_OPT (cse_pointer)]) = phase; IDF (&A68_OPT (cse_book)[A68_OPT (cse_pointer)]) = idf; INFO (&A68_OPT (cse_book)[A68_OPT (cse_pointer)]) = info; NUMBER (&A68_OPT (cse_book)[A68_OPT (cse_pointer)]) = number; A68_OPT (cse_pointer)++; } } //! @brief Whether identifier is signed_in. BOOK_T *signed_in (int action, int phase, char *idf) { int k; for (k = 0; k < A68_OPT (cse_pointer); k++) { if (IDF (&A68_OPT (cse_book)[k]) == idf && ACTION (&A68_OPT (cse_book)[k]) == action && PHASE (&A68_OPT (cse_book)[k]) >= phase) { return &(A68_OPT (cse_book)[k]); } } return NO_BOOK; } //! @brief Make name. char *make_name (char *buf, char *name, char *tag, int n) { if (strlen (tag) > 0) { ASSERT (snprintf (buf, NAME_SIZE, "genie_%s_%s_%d", name, tag, n) >= 0); } else { ASSERT (snprintf (buf, NAME_SIZE, "genie_%s_%d", name, n) >= 0); } ABEND (strlen (buf) >= NAME_SIZE, ERROR_ACTION, __func__); return buf; } //! @brief Whether two sub-trees are the same Algol 68 construct. 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 stems from certain attribute. NODE_T *stems_from (NODE_T * p, int att) { if (IS (p, VOIDING)) { return stems_from (SUB (p), att); } else if (IS (p, UNIT)) { return stems_from (SUB (p), att); } else if (IS (p, TERTIARY)) { return stems_from (SUB (p), att); } else if (IS (p, SECONDARY)) { return stems_from (SUB (p), att); } else if (IS (p, PRIMARY)) { return stems_from (SUB (p), att); } else if (IS (p, att)) { return p; } else { return NO_NODE; } } // Auxilliary routines for emitting C code. //! @brief Whether frame needs initialisation. 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. 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. void comment_source (NODE_T * p, FILE_T out) { int want_space = 0, max_print = 16, ld = -1; undentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "\n// %s: %d: ", FILENAME (LINE (INFO (p))), LINE_NUMBER (p))); comment_tree (p, out, &want_space, &max_print); tree_listing (out, p, 1, LINE (INFO (p)), &ld, A68_TRUE); undent (out, "\n"); } //! @brief Inline comment source line. 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. void write_prelude (FILE_T out) { indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "// \"%s\" %s\n", FILE_OBJECT_NAME (&A68_JOB), PACKAGE_STRING)); indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "// optimiser_level=%d code_level=%d\n", OPTION_OPT_LEVEL (&A68_JOB), A68_OPT (OPTION_CODE_LEVEL))); indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "// %s %s\n", __DATE__, __TIME__)); indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "\n#include <%s/a68g-config.h>\n", PACKAGE)); indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "#include <%s/a68g.h>\n", PACKAGE)); indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "#include <%s/a68g-genie.h>\n", PACKAGE)); indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "#include <%s/a68g-prelude.h>\n", PACKAGE)); indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "#include <%s/a68g-environ.h>\n", PACKAGE)); indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "#include <%s/a68g-lib.h>\n", PACKAGE)); indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "#include <%s/a68g-optimiser.h>\n", PACKAGE)); indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "#include <%s/a68g-frames.h>\n", PACKAGE)); indent (out, "\n#define _NODE_(n) (A68 (node_register)[n])\n"); indent (out, "#define _STATUS_(z) (STATUS (z))\n"); indent (out, "#define _VALUE_(z) (VALUE (z))\n"); } //! @brief Write initialisation of frame. void init_static_frame (FILE_T out, NODE_T * p) { if (AP_INCREMENT (TABLE (p)) > 0) { indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "FRAME_CLEAR (" A68_LU ");\n", AP_INCREMENT (TABLE (p)))); } if (LEX_LEVEL (p) == A68 (global_level)) { indent (out, "A68_GLOBALS = A68_FP;\n"); } if (need_initialise_frame (p)) { indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "initialise_frame (_NODE_ (%d));\n", NUMBER (p))); } } // COMPILATION OF PARTIAL UNITS. void gen_check_init (NODE_T * p, FILE_T out, char *idf) { if (OPTION_COMPILE_CHECK (&A68_JOB) && folder_mode (MOID (p))) { if (MOID (p) == M_COMPLEX) { indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "if (!(INITIALISED (&(*%s)[0]) && INITIALISED (&(*%s)[1]))) {\n", idf, idf)); A68_OPT (indentation)++; indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "diagnostic (A68_RUNTIME_ERROR, p, ERROR_EMPTY_VALUE_FROM, M_COMPLEX);\n")); indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "exit_genie ((p), A68_RUNTIME_ERROR);\n")); A68_OPT (indentation)--; indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "}\n")); } else { char *M = "M_ERROR"; if (MOID (p) == M_INT) { M = "M_INT"; } else if (MOID (p) == M_REAL) { M = "M_REAL"; } else if (MOID (p) == M_BOOL) { M = "M_BOOL"; } else if (MOID (p) == M_CHAR) { M = "M_CHAR"; } indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "if (!INITIALISED(%s)) {\n", idf)); A68_OPT (indentation)++; indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "diagnostic (A68_RUNTIME_ERROR, p, ERROR_EMPTY_VALUE_FROM, %s);\n", M)); indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "exit_genie ((p), A68_RUNTIME_ERROR);\n")); A68_OPT (indentation)--; indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "}\n")); } } } //! @brief Code getting objects from the stack. void get_stack (NODE_T * p, FILE_T out, char *dst, char *cast) { if (A68_OPT (OPTION_CODE_LEVEL) >= 4) { if (LEVEL (GINFO (p)) == A68 (global_level)) { indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "GET_GLOBAL (%s, %s, " A68_LU ");\n", dst, cast, OFFSET (TAX (p)))); } else { indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "GET_FRAME (%s, %s, %d, " A68_LU ");\n", dst, cast, LEVEL (GINFO (p)), OFFSET (TAX (p)))); } } else { indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "GET_FRAME (%s, %s, %d, " A68_LU ");\n", dst, cast, LEVEL (GINFO (p)), OFFSET (TAX (p)))); } } //! @brief Code function prelude. void write_fun_prelude (NODE_T * p, FILE_T out, char *fn) { (void) p; indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "\nPROP_T %s (NODE_T *p) {\n", fn)); A68_OPT (indentation)++; indent (out, "PROP_T self;\n"); indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "UNIT (&self) = %s;\n", fn)); indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "SOURCE (&self) = _NODE_ (%d);\n", NUMBER (p))); indent (out, "A68 (f_entry) = p;\n"); A68_OPT (cse_pointer) = 0; } //! @brief Code function postlude. void write_fun_postlude (NODE_T * p, FILE_T out, char *fn) { (void) fn; (void) p; indent (out, "return (self);\n"); A68_OPT (indentation)--; A68_OPT (procedures)++; indent (out, "}\n"); A68_OPT (cse_pointer) = 0; } //! @brief Code internal a68g mode. char *internal_mode (MOID_T * m) { if (m == M_INT) { return "M_INT"; } else if (m == M_REAL) { return "M_REAL"; } else if (m == M_BOOL) { return "M_BOOL"; } else if (m == M_CHAR) { return "M_CHAR"; } else if (m == M_BITS) { return "M_BITS"; } else { return "M_ERROR"; } } //! @brief Compile denotation. char *compile_denotation (NODE_T * p, FILE_T out) { if (primitive_mode (MOID (p))) { static char fn[NAME_SIZE], N[NAME_SIZE]; int action = UNIC_MAKE_ALT; comment_source (p, out); fn[0] = '\0'; if (MOID (p) == M_INT) { char *end; UNSIGNED_T z = (UNSIGNED_T) a68_strtoi (NSYMBOL (p), &end, 10); ASSERT (snprintf (N, NAME_SIZE, A68_LX "_", z) >= 0); (void) make_unic_name (fn, moid_with_name ("", MOID (p), "_denotation"), "", N); } else if (MOID (p) == M_REAL) { char *V; char W[NAME_SIZE]; int k; A68_SP = 0; PUSH_UNION (p, M_REAL); push_unit (p); INCREMENT_STACK_POINTER (p, SIZE (M_NUMBER) - (A68_UNION_SIZE + SIZE (M_REAL))); PUSH_VALUE (p, REAL_WIDTH + EXP_WIDTH + 5, A68_INT); PUSH_VALUE (p, REAL_WIDTH, A68_INT); PUSH_VALUE (p, EXP_WIDTH + 1, A68_INT); PUSH_VALUE (p, 3, A68_INT); V = real (p); for (k = 0; V[0] != '\0'; V++) { if (IS_ALNUM (V[0])) { W[k++] = TO_LOWER (V[0]); W[k] = '\0'; } if (V[0] == '.' || V[0] == '-') { W[k++] = '_'; W[k] = '\0'; } } (void) make_unic_name (fn, moid_with_name ("", MOID (p), "_denotation"), "", W); } else if (MOID (p) == M_BOOL) { (void) make_unic_name (fn, moid_with_name ("", MOID (p), "_denotation"), "", NSYMBOL (SUB (p))); } else if (MOID (p) == M_CHAR) { ASSERT (snprintf (N, NAME_SIZE, "%02x_", NSYMBOL (SUB (p))[0]) >= 0); (void) make_unic_name (fn, moid_with_name ("", MOID (p), "_denotation"), "", N); } if (fn[0] != '\0') { sign_in_name (fn, &action); if (action == UNIC_EXISTS) { return fn; } } if (action == UNIC_MAKE_NEW || action == UNIC_MAKE_ALT) { if (action == UNIC_MAKE_ALT) { (void) make_name (fn, moid_with_name ("", MOID (p), "_denotation_alt"), "", NUMBER (p)); } write_fun_prelude (p, out, fn); indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "PUSH_VALUE (p, ")); inline_unit (p, out, L_YIELD); undentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, ", %s);\n", inline_mode (MOID (p)))); write_fun_postlude (p, out, fn); } return fn; } else { return NO_TEXT; } } char *compile_cast (NODE_T * p, FILE_T out) { if (folder_mode (MOID (p)) && basic_unit (p)) { static char fn[NAME_SIZE]; comment_source (p, out); (void) make_name (fn, moid_with_name ("", MOID (p), "_cast"), "", NUMBER (p)); A68_OPT (root_idf) = NO_DEC; inline_unit (NEXT_SUB (p), out, L_DECLARE); print_declarations (out, A68_OPT (root_idf)); inline_unit (NEXT_SUB (p), out, L_EXECUTE); gen_push (NEXT_SUB (p), out); return fn; } else { return NO_TEXT; } } //! @brief Compile identifier. char *compile_identifier (NODE_T * p, FILE_T out) { if (folder_mode (MOID (p))) { static char fn[NAME_SIZE]; int action = UNIC_MAKE_ALT; char N[NAME_SIZE]; // Some identifiers in standenv cannot be pushed. // Examples are cputime, or clock that are procedures in disguise. if (A68_STANDENV_PROC (TAX (p))) { int k; BOOL_T ok = A68_FALSE; for (k = 0; PROCEDURE (&constants[k]) != NO_GPROC; k++) { if (PROCEDURE (TAX (p)) == PROCEDURE (&constants[k])) { ok = A68_TRUE; } } if (!ok) { return NO_TEXT; } } // Push the identifier. ASSERT (snprintf (N, NAME_SIZE, "%d_%d_" A68_LU, NUM (TABLE (TAX (p))), LEVEL (GINFO (p)), OFFSET (TAX (p))) >= 0); comment_source (p, out); fn[0] = '\0'; (void) make_unic_name (fn, moid_with_name ("", MOID (p), "_identifier"), "", N); sign_in_name (fn, &action); if (action == UNIC_EXISTS) { return fn; } if (action == UNIC_MAKE_NEW || action == UNIC_MAKE_ALT) { if (action == UNIC_MAKE_ALT) { (void) make_name (fn, moid_with_name ("", MOID (p), "_identifier_alt"), "", NUMBER (p)); } write_fun_prelude (p, out, fn); A68_OPT (root_idf) = NO_DEC; inline_unit (p, out, L_DECLARE); print_declarations (out, A68_OPT (root_idf)); inline_unit (p, out, L_EXECUTE); gen_push (p, out); write_fun_postlude (p, out, fn); } return fn; } else { return NO_TEXT; } } //! @brief Compile dereference identifier. char *compile_dereference_identifier (NODE_T * p, FILE_T out) { if (folder_mode (MOID (p))) { static char fn[NAME_SIZE]; int action = UNIC_MAKE_ALT; char N[NAME_SIZE]; NODE_T *q = SUB (p); ASSERT (snprintf (N, NAME_SIZE, "%d_%d_" A68_LU, NUM (TABLE (TAX (q))), LEVEL (GINFO (q)), OFFSET (TAX (q))) >= 0); comment_source (p, out); fn[0] = '\0'; (void) make_unic_name (fn, moid_with_name ("deref_REF_", MOID (p), "_identifier"), "", N); sign_in_name (fn, &action); if (action == UNIC_EXISTS) { return fn; } if (action == UNIC_MAKE_NEW || action == UNIC_MAKE_ALT) { if (action == UNIC_MAKE_ALT) { (void) make_name (fn, moid_with_name ("deref_REF_", MOID (p), "_identifier_alt"), "", NUMBER (p)); } write_fun_prelude (p, out, fn); A68_OPT (root_idf) = NO_DEC; inline_unit (p, out, L_DECLARE); print_declarations (out, A68_OPT (root_idf)); inline_unit (p, out, L_EXECUTE); gen_push (p, out); write_fun_postlude (p, out, fn); } return fn; } else { return NO_TEXT; } } //! @brief Compile formula. char *compile_formula (NODE_T * p, FILE_T out) { if (folder_mode (MOID (p)) && basic_unit (p)) { static char fn[NAME_SIZE]; comment_source (p, out); (void) make_name (fn, moid_with_name ("", MOID (p), "_formula"), "", NUMBER (p)); write_fun_prelude (p, out, fn); if (OPTION_COMPILE_CHECK (&A68_JOB) && !constant_unit (p)) { if (MOID (p) == M_REAL || MOID (p) == M_COMPLEX) { indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "A68_REAL * _st_ = (A68_REAL *) STACK_TOP;\n")); } } A68_OPT (root_idf) = NO_DEC; inline_unit (p, out, L_DECLARE); print_declarations (out, A68_OPT (root_idf)); if (OPTION_COMPILE_CHECK (&A68_JOB) && !constant_unit (p)) { if (folder_mode (MOID (p))) { indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "errno = 0;\n")); } } inline_unit (p, out, L_EXECUTE); gen_push (p, out); if (OPTION_COMPILE_CHECK (&A68_JOB) && !constant_unit (p)) { if (MOID (p) == M_INT) { indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "MATH_RTE (p, errno != 0, M_INT, NO_TEXT);\n")); } if (MOID (p) == M_REAL) { indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "MATH_RTE (p, errno != 0, M_REAL, NO_TEXT);\n")); indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "CHECK_REAL (p, _VALUE_ (_st_));\n")); } if (MOID (p) == M_BITS) { indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "MATH_RTE (p, errno != 0, M_BITS, NO_TEXT);\n")); } if (MOID (p) == M_COMPLEX) { indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "MATH_RTE (p, errno != 0, M_COMPLEX, NO_TEXT);\n")); indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "CHECK_REAL (p, _VALUE_ (&(_st_[0])));\n")); indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "CHECK_REAL (p, _VALUE_ (&(_st_[1])));\n")); } } write_fun_postlude (p, out, fn); return fn; } else { return NO_TEXT; } } //! @brief Compile call. char *compile_call (NODE_T * p, FILE_T out) { NODE_T *proc = SUB (p); NODE_T *args = NEXT (proc); NODE_T *idf = stems_from (proc, IDENTIFIER); if (idf == NO_NODE) { return NO_TEXT; } else if (!(SUB_MOID (proc) == M_VOID || basic_mode (SUB_MOID (proc)))) { return NO_TEXT; } else if (DIM (MOID (proc)) == 0) { return NO_TEXT; } else if (A68_STANDENV_PROC (TAX (idf))) { if (basic_call (p)) { static char fun[NAME_SIZE]; comment_source (p, out); (void) make_name (fun, moid_with_name ("", SUB_MOID (proc), "_call"), "", NUMBER (p)); write_fun_prelude (p, out, fun); A68_OPT (root_idf) = NO_DEC; inline_unit (p, out, L_DECLARE); print_declarations (out, A68_OPT (root_idf)); inline_unit (p, out, L_EXECUTE); gen_push (p, out); write_fun_postlude (p, out, fun); return fun; } 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, moid_with_name ("", SUB_MOID (proc), "_call"), "", NUMBER (p)); write_fun_prelude (p, out, fn); // Compute arguments. size = 0; A68_OPT (root_idf) = NO_DEC; inline_arguments (args, out, L_DECLARE, &size); (void) add_declaration (&A68_OPT (root_idf), "ADDR_T", 0, pop); (void) add_declaration (&A68_OPT (root_idf), "A68_PROCEDURE", 1, fun); (void) add_declaration (&A68_OPT (root_idf), "NODE_T", 1, "body"); print_declarations (out, A68_OPT (root_idf)); // Initialise. indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "%s = A68_SP;\n", pop)); inline_arguments (args, out, L_INITIALISE, &size); get_stack (idf, out, fun, "A68_PROCEDURE"); indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "body = SUB (NODE (&BODY (%s)));\n", fun)); indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "OPEN_PROC_FRAME (body, ENVIRON (%s));\n", fun)); indentf (out, snprintf (A68 (edit_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 (A68 (edit_line), SNPRINTF_SIZE, "A68_SP = %s;\n", pop)); indent (out, "EXECUTE_UNIT_TRACE (NEXT_NEXT_NEXT (body));\n"); indent (out, "if (A68_FP == A68_MON (finish_frame_pointer)) {\n"); A68_OPT (indentation)++; indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "change_masks (TOP_NODE (&A68_JOB), BREAKPOINT_INTERRUPT_MASK, A68_TRUE);\n")); A68_OPT (indentation)--; indent (out, "}\n"); indent (out, "CLOSE_FRAME;\n"); write_fun_postlude (p, out, fn); return fn; } } algol68g-3.1.2/src/a68g/non-terminal.c0000644000175000017500000002032314361065320014164 00000000000000//! @file non-terminal.c //! @author J. Marcel van der Veer // //! @section Copyright // // This file is part of Algol68G - an Algol 68 compiler-interpreter. // Copyright 2001-2023 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" #include "a68g-prelude.h" #include "a68g-mp.h" #include "a68g-genie.h" #include "a68g-postulates.h" #include "a68g-parser.h" #include "a68g-options.h" #include "a68g-optimiser.h" #include "a68g-listing.h" // Translate int attributes to string names. static char *attribute_names[WILDCARD + 1] = { NO_TEXT, "A68_PATTERN", "ACCO_SYMBOL", "ACTUAL_DECLARER_MARK", "ALIF_IF_PART", "ALIF_PART", "ALIF_SYMBOL", "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", "GUARDED_CONDITIONAL_CLAUSE", "GUARDED_LOOP_CLAUSE", "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_LONG_LONG_BITS", "MODE_LONG_LONG_COMPLEX", "MODE_LONG_LONG_INT", "MODE_LONG_LONG_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. 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; } } algol68g-3.1.2/src/a68g/bottom-up.c0000644000175000017500000027575714361065320013536 00000000000000//! @file bottom-up.c //! @author J. Marcel van der Veer // //! @section Copyright // // This file is part of Algol68G - an Algol 68 compiler-interpreter. // Copyright 2001-2023 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 . // This code constitutes an effective "Algol 68 VW parser"; a 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 needed for parsing, and therefore allows for tags to be used // before they are defined, which gives some freedom in top-down programming. // // B. J. Mailloux. On the implementation of Algol 68. // Thesis, Universiteit van Amsterdam (Mathematisch Centrum) [1968]. // // Technically, Mailloux's approach renders the two-level grammar LALR. // // This is the bottom-up parser that resolves the structure of the program. #include "a68g.h" #include "a68g-parser.h" #include "a68g-prelude.h" // Bottom-up parser, reduces all constructs. //! @brief Whether a series is serial or collateral. 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 Insert a node with attribute "a" after "p". 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. void a68_extension (NODE_T * p) { if (OPTION_PORTCHECK (&A68_JOB)) { diagnostic (A68_WARNING | A68_FORCE_DIAGNOSTICS, p, WARNING_EXTENSION); } else { diagnostic (A68_WARNING, p, WARNING_EXTENSION); } } //! @brief Diagnose for clauses not yielding a value. void empty_clause (NODE_T * p) { diagnostic (A68_SYNTAX_ERROR, p, ERROR_CLAUSE_WITHOUT_VALUE); } #if !defined (BUILD_PARALLEL_CLAUSE) //! @brief Diagnose for parallel clause. void par_clause (NODE_T * p) { diagnostic (A68_SYNTAX_ERROR, p, ERROR_NO_PARALLEL_CLAUSE); } #endif //! @brief Diagnose for missing symbol. void strange_tokens (NODE_T * p) { NODE_T *q = ((p != NO_NODE && NEXT (p) != NO_NODE) ? NEXT (p) : p); diagnostic (A68_SYNTAX_ERROR, q, ERROR_SYNTAX_STRANGE_TOKENS); } //! @brief Diagnose for strange separator. void strange_separator (NODE_T * p) { NODE_T *q = ((p != NO_NODE && NEXT (p) != NO_NODE) ? NEXT (p) : p); diagnostic (A68_SYNTAX_ERROR, q, ERROR_SYNTAX_STRANGE_SEPARATOR); } //! @brief If match then reduce a sentence, the core BU parser routine. void reduce (NODE_T * p, void (*a) (NODE_T *), BOOL_T * z, ...) { va_list list; int result, expect; NODE_T *head = p, *tail = NO_NODE; va_start (list, z); result = va_arg (list, int); while ((expect = va_arg (list, int)) != STOP) { BOOL_T keep_matching; if (p == NO_NODE) { keep_matching = A68_FALSE; } else if (expect == WILDCARD) { // WILDCARD matches any Algol68G non terminal, but no keyword. keep_matching = (BOOL_T) (non_terminal_string (A68 (edit_line), ATTRIBUTE (p)) != NO_TEXT); } else { if (expect == SKIP) { // Stray "~" matches expected SKIP. if (IS (p, OPERATOR) && IS_LITERALLY (p, "~")) { ATTRIBUTE (p) = SKIP; } } if (expect >= 0) { keep_matching = (BOOL_T) (expect == ATTRIBUTE (p)); } else { keep_matching = (BOOL_T) (expect != ATTRIBUTE (p)); } } if (keep_matching) { tail = p; FORWARD (p); } else { va_end (list); return; } } // Print parser reductions. if (head != NO_NODE && OPTION_REDUCTIONS (&A68_JOB) && LINE_NUMBER (head) > 0) { NODE_T *q; int count = 0; A68_PARSER (reductions)++; WIS (head); ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "\nReduction %d: %s<-", A68_PARSER (reductions), non_terminal_string (A68 (edit_line), result)) >= 0); WRITE (STDOUT_FILENO, A68 (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 (A68 (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 (A68 (output_line), SNPRINTF_SIZE, " \"%s\"", NSYMBOL (q)) >= 0); WRITE (STDOUT_FILENO, A68 (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. 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 (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 (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. void bottom_up_parser (NODE_T * p) { if (p != NO_NODE) { if (!setjmp (A68_PARSER (bottom_up_crash_exit))) { NODE_T *q; int error_count_0 = ERROR_COUNT (&A68_JOB); ignore_superfluous_semicolons (p); // A program is "label sequence; particular program". extract_labels (p, SERIAL_CLAUSE); // 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 (BUILD_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 (&A68_JOB) - error_count_0) > MAX_ERRORS)); } } } } //! @brief Reduce code clause. 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. void reduce_branch (NODE_T * q, int expect) { // If unsuccessful then the routine will at least copy the resulting attribute // as the parser can repair some faults. This gives less spurious diagnostics. if (q != NO_NODE && SUB (q) != NO_NODE) { NODE_T *p = SUB (q), *u = NO_NODE; int error_count_0 = ERROR_COUNT (&A68_JOB), error_count_02; BOOL_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 (&A68_JOB); elaborate_bold_tags (p); if ((ERROR_COUNT (&A68_JOB) - error_count_02) > 0) { longjmp (A68_PARSER (bottom_up_crash_exit), 1); } // Now we can reduce declarers, knowing which bold tags are indicants. reduce_declarers (p, expect); // Parse the phrase, as appropriate. if (expect == CODE_CLAUSE) { reduce_code_clause (p); } else if (declarer_pack == A68_FALSE) { error_count_02 = ERROR_COUNT (&A68_JOB); extract_declarations (p); if ((ERROR_COUNT (&A68_JOB) - error_count_02) > 0) { longjmp (A68_PARSER (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 (&A68_JOB) - 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. 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 (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 (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 (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 (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. 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. 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 (BUILD_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. 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. 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 (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. 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. 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. 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". 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. 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 (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 (A68_SYNTAX_ERROR, op2, ERROR_NO_PRIORITY); } } } } } } //! @brief Reduce dyadic expressions. 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. 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. 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. 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 (!IS (q, UNIT) && !IS (q, TRIMMER)) { pad_node (q, TRIMMER); } } } } q = NEXT (p); ABEND (q == NO_NODE, ERROR_INTERNAL_CONSISTENCY, __func__); 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. 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. 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. 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. 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. 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 || !IS (NEXT (u), LABELED_UNIT)) { diagnostic (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 (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. 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. 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. 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. 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 (&A68_JOB) == 0) { diagnostic (A68_SYNTAX_ERROR, w, ERROR_SYNTAX_EXPECTED, expect); } } else { diagnostic (A68_SYNTAX_ERROR, w, ERROR_INVALID_SEQUENCE, seq, expect); } if (ERROR_COUNT (&A68_JOB) >= MAX_ERRORS) { longjmp (A68_PARSER (bottom_up_crash_exit), 1); } } // Try to prevent spurious diagnostics by guessing what was expected. while (NEXT (q) != NO_NODE) { FORWARD (q); } if (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 (A68 (edit_line), expect) != NO_TEXT) { make_sub (p, q, expect); } } //! @brief Heuristic aid in pinpointing errors. 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 (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 (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 (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. 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 (A68_SYNTAX_ERROR, p, ERROR_FORMAT_PICTURE_NUMBER, ATTRIBUTE (p)); } } else { bottom_up_error_check (SUB (p)); } } } // Next part rearranges and checks the tree after the symbol tables are finished. //! @brief Transfer IDENTIFIER to JUMP where appropriate. 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)); } } algol68g-3.1.2/src/a68g/parser.c0000644000175000017500000006335714361065320013073 00000000000000//! @file parser.c //! @author J. Marcel van der Veer // //! @section Copyright // // This file is part of Algol68G - an Algol 68 compiler-interpreter. // Copyright 2001-2023 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 . // The Algol 68 grammar is a two level (Van Wijngaarden, "VW") grammar // that incorporates, as syntactical rules, the semantical rules in // other languages. Examples are correct use of symbols, modes and scope. // // This code constitutes an effective "VW Algol 68 parser". A pragmatic // approach was chosen since in the early days of Algol 68, many "ab initio" // implementations failed, probably because techniques to parse a language // like Algol 68 had yet to be invented. // // This is a Mailloux-type parser, in the sense that it scans a "phrase" for // definitions needed for parsing. Algol 68 allows for tags to be used // before they are defined, which gives freedom in top-down programming. // // B. J. Mailloux. On the implementation of Algol 68. // Thesis, Universiteit van Amsterdam (Mathematisch Centrum) [1968]. // // Technically, Mailloux's approach renders the two-level grammar LALR. // // First part of the parser is the scanner. The source file is read, // is tokenised, 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 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" (or "upper") and "quote". // Examples of both: // // bold stropping: BEGIN INT i = 1, j = 1; print (i + j) END // // quote stropping: 'BEGIN' 'INT' I = 1, J = 1; PRINT (I + J) 'END' // // Quote stropping was used frequently in the (excusez-le-mot) punch-card age. // Hence, bold stropping is the default. There also existed point stropping, // but that has not been implemented here. // // Next part of the parser is a recursive-descent type to check parenthesis. // Also a first set-up is made of symbol tables, needed by the bottom-up parser. // Next part is the bottom-up parser, that parses without knowing modes while // parsing and reducing. It can therefore not exchange "[]" with "()" as was // blessed by the Revised Report. This is solved by treating CALL and SLICE as // equivalent for the moment and letting the mode checker sort it out later. // // Parsing progresses in various phases to avoid spurious diagnostics from a // recovering parser. Every phase "tightens" the grammar more. // An error in any phase makes the parser quit when that phase ends. // The parser is forgiving in case of superfluous semicolons. // // These are the parser phases: // // (1) Parenthesis are checked to see whether they match. Then, a top-down // parser determines the basic-block structure of the program // so symbol tables can be set up that the bottom-up parser will consult // as you can define things before they are applied. // // (2) A bottom-up parser resolves the structure of the program. // // (3) After the symbol tables have been finalised, a small rearrangement of the // tree may be required where JUMPs have no GOTO. This leads to the // non-standard situation that JUMPs without GOTO can have the syntactic // position of a PRIMARY, SECONDARY or TERTIARY. The bottom-up parser also // does not check VICTAL correctness of declarers. This is done separately. // 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. #include "a68g.h" #include "a68g-parser.h" #include "a68g-mp.h" #include "a68g-postulates.h" #include "a68g-prelude.h" //! @brief First initialisations. void init_before_tokeniser (void) { // Heap management set-up. errno = 0; init_heap (); A68 (top_keyword) = NO_KEYWORD; A68 (top_token) = NO_TOKEN; TOP_NODE (&A68_JOB) = NO_NODE; TOP_MOID (&A68_JOB) = NO_MOID; TOP_LINE (&A68_JOB) = NO_LINE; STANDENV_MOID (&A68_JOB) = NO_MOID; set_up_tables (); // Various initialisations. ERROR_COUNT (&A68_JOB) = WARNING_COUNT (&A68_JOB) = 0; ABEND (errno != 0, ERROR_ALLOCATION, __func__); errno = 0; } void init_parser (void) { A68_PARSER (stop_scanner) = A68_FALSE; A68_PARSER (read_error) = A68_FALSE; A68_PARSER (no_preprocessing) = A68_FALSE; } //! @brief Is_ref_refety_flex. BOOL_T is_ref_refety_flex (MOID_T * m) { if (IS_REF_FLEX (m)) { return A68_TRUE; } else if (IS_REF (m)) { return is_ref_refety_flex (SUB (m)); } else { return A68_FALSE; } } //! @brief Count number of operands in operator parameter list. 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. 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 pictures. 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 Whether token cannot follow semicolon or EXIT. 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 Whether formal bounds. 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 Whether token terminates a unit. 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. 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 Get good attribute. 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. 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: case SERIAL_CLAUSE: case ENQUIRY_CLAUSE: case INITIALISER_SERIES: case DECLARATION_LIST: { return A68_TRUE; } } return A68_FALSE; } void a68_parser (void) { // Tokeniser. int renum; FILE_SOURCE_OPENED (&A68_JOB) = A68_TRUE; announce_phase ("initialiser"); A68_PARSER (error_tag) = (TAG_T *) new_tag (); init_parser (); if (ERROR_COUNT (&A68_JOB) == 0) { int frame_stack_size_2 = A68 (frame_stack_size); int expr_stack_size_2 = A68 (expr_stack_size); int heap_size_2 = A68 (heap_size); int handle_pool_size_2 = A68 (handle_pool_size); BOOL_T ok; announce_phase ("tokeniser"); ok = lexical_analyser (); if (!ok || errno != 0) { diagnostics_to_terminal (TOP_LINE (&A68_JOB), A68_ALL_DIAGNOSTICS); return; } // Maybe the program asks for more memory through a PRAGMAT. We restart. if (frame_stack_size_2 != A68 (frame_stack_size) || expr_stack_size_2 != A68 (expr_stack_size) || heap_size_2 != A68 (heap_size) || handle_pool_size_2 != A68 (handle_pool_size)) { announce_phase ("tokeniser"); free_syntax_tree (TOP_NODE (&A68_JOB)); discard_heap (); init_before_tokeniser (); SOURCE_SCAN (&A68_JOB)++; ok = lexical_analyser (); verbosity (); } if (!ok || errno != 0) { diagnostics_to_terminal (TOP_LINE (&A68_JOB), A68_ALL_DIAGNOSTICS); return; } ASSERT (close (FILE_SOURCE_FD (&A68_JOB)) == 0); FILE_SOURCE_OPENED (&A68_JOB) = A68_FALSE; prune_echoes (OPTION_LIST (&A68_JOB)); TREE_LISTING_SAFE (&A68_JOB) = A68_TRUE; renum = 0; renumber_nodes (TOP_NODE (&A68_JOB), &renum); } // Now the default precision of LONG LONG modes is fixed. if (long_mp_digits () == 0) { set_long_mp_digits (LONG_LONG_MP_DIGITS); } // Final initialisations. if (ERROR_COUNT (&A68_JOB) == 0) { if (OPTION_REGRESSION_TEST (&A68_JOB)) { bufcpy (A68 (a68_cmd_name), "a68g", BUFFER_SIZE); io_close_tty_line (); WRITE (STDERR_FILENO, "["); WRITE (STDERR_FILENO, FILE_INITIAL_NAME (&A68_JOB)); WRITE (STDERR_FILENO, "]\n"); } A68_STANDENV = NO_TABLE; init_postulates (); A68 (mode_count) = 0; make_special_mode (&M_HIP, A68 (mode_count)++); make_special_mode (&M_UNDEFINED, A68 (mode_count)++); make_special_mode (&M_ERROR, A68 (mode_count)++); make_special_mode (&M_VACUUM, A68 (mode_count)++); make_special_mode (&M_C_STRING, A68 (mode_count)++); make_special_mode (&M_COLLITEM, A68 (mode_count)++); make_special_mode (&M_SOUND_DATA, A68 (mode_count)++); } // Refinement preprocessor. if (ERROR_COUNT (&A68_JOB) == 0) { announce_phase ("preprocessor"); get_refinements (); if (ERROR_COUNT (&A68_JOB) == 0) { put_refinements (); } renum = 0; renumber_nodes (TOP_NODE (&A68_JOB), &renum); verbosity (); } // Top-down parser. if (ERROR_COUNT (&A68_JOB) == 0) { announce_phase ("parser phase 1"); check_parenthesis (TOP_NODE (&A68_JOB)); if (ERROR_COUNT (&A68_JOB) == 0) { if (OPTION_BRACKETS (&A68_JOB)) { substitute_brackets (TOP_NODE (&A68_JOB)); } A68 (symbol_table_count) = 0; A68_STANDENV = new_symbol_table (NO_TABLE); LEVEL (A68_STANDENV) = 0; top_down_parser (TOP_NODE (&A68_JOB)); } renum = 0; renumber_nodes (TOP_NODE (&A68_JOB), &renum); verbosity (); } // Standard environment builder. if (ERROR_COUNT (&A68_JOB) == 0) { announce_phase ("standard environ builder"); TABLE (TOP_NODE (&A68_JOB)) = new_symbol_table (A68_STANDENV); make_standard_environ (); STANDENV_MOID (&A68_JOB) = TOP_MOID (&A68_JOB); verbosity (); } // Bottom-up parser. if (ERROR_COUNT (&A68_JOB) == 0) { announce_phase ("parser phase 2"); preliminary_symbol_table_setup (TOP_NODE (&A68_JOB)); bottom_up_parser (TOP_NODE (&A68_JOB)); renum = 0; renumber_nodes (TOP_NODE (&A68_JOB), &renum); verbosity (); } if (ERROR_COUNT (&A68_JOB) == 0) { announce_phase ("parser phase 3"); bottom_up_error_check (TOP_NODE (&A68_JOB)); victal_checker (TOP_NODE (&A68_JOB)); if (ERROR_COUNT (&A68_JOB) == 0) { finalise_symbol_table_setup (TOP_NODE (&A68_JOB), 2); NEST (TABLE (TOP_NODE (&A68_JOB))) = A68 (symbol_table_count) = 3; reset_symbol_table_nest_count (TOP_NODE (&A68_JOB)); fill_symbol_table_outer (TOP_NODE (&A68_JOB), TABLE (TOP_NODE (&A68_JOB))); set_nest (TOP_NODE (&A68_JOB), NO_NODE); set_proc_level (TOP_NODE (&A68_JOB), 1); } renum = 0; renumber_nodes (TOP_NODE (&A68_JOB), &renum); verbosity (); } // Mode table builder. if (ERROR_COUNT (&A68_JOB) == 0) { announce_phase ("mode table builder"); make_moid_list (&A68_JOB); verbosity (); } CROSS_REFERENCE_SAFE (&A68_JOB) = A68_TRUE; // Symbol table builder. if (ERROR_COUNT (&A68_JOB) == 0) { announce_phase ("symbol table builder"); collect_taxes (TOP_NODE (&A68_JOB)); verbosity (); } // Post parser. if (ERROR_COUNT (&A68_JOB) == 0) { announce_phase ("parser phase 4"); rearrange_goto_less_jumps (TOP_NODE (&A68_JOB)); verbosity (); } // Mode checker. if (ERROR_COUNT (&A68_JOB) == 0) { announce_phase ("mode checker"); mode_checker (TOP_NODE (&A68_JOB)); verbosity (); } // Coercion inserter. if (ERROR_COUNT (&A68_JOB) == 0) { announce_phase ("coercion enforcer"); coercion_inserter (TOP_NODE (&A68_JOB)); widen_denotation (TOP_NODE (&A68_JOB)); get_max_simplout_size (TOP_NODE (&A68_JOB)); set_moid_sizes (TOP_MOID (&A68_JOB)); assign_offsets_table (A68_STANDENV); assign_offsets (TOP_NODE (&A68_JOB)); assign_offsets_packs (TOP_MOID (&A68_JOB)); renum = 0; renumber_nodes (TOP_NODE (&A68_JOB), &renum); verbosity (); } // Application checker. if (ERROR_COUNT (&A68_JOB) == 0) { announce_phase ("application checker"); mark_moids (TOP_NODE (&A68_JOB)); mark_auxilliary (TOP_NODE (&A68_JOB)); jumps_from_procs (TOP_NODE (&A68_JOB)); warn_for_unused_tags (TOP_NODE (&A68_JOB)); verbosity (); } // Scope checker. if (ERROR_COUNT (&A68_JOB) == 0) { announce_phase ("static scope checker"); tie_label_to_serial (TOP_NODE (&A68_JOB)); tie_label_to_unit (TOP_NODE (&A68_JOB)); bind_routine_tags_to_tree (TOP_NODE (&A68_JOB)); bind_format_tags_to_tree (TOP_NODE (&A68_JOB)); scope_checker (TOP_NODE (&A68_JOB)); verbosity (); } } //! @brief Renumber nodes. 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. void register_nodes (NODE_T * p) { for (; p != NO_NODE; FORWARD (p)) { A68 (node_register)[NUMBER (p)] = p; register_nodes (SUB (p)); } } //! @brief New_node_info. NODE_INFO_T *new_node_info (void) { NODE_INFO_T *z = (NODE_INFO_T *) get_fixed_heap_space ((size_t) SIZE_ALIGNED (NODE_INFO_T)); A68 (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. GINFO_T *new_genie_info (void) { GINFO_T *z = (GINFO_T *) get_fixed_heap_space ((size_t) SIZE_ALIGNED (GINFO_T)); A68 (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. NODE_T *new_node (void) { NODE_T *z = (NODE_T *) get_fixed_heap_space ((size_t) SIZE_ALIGNED (NODE_T)); A68 (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. TABLE_T *new_symbol_table (TABLE_T * p) { TABLE_T *z = (TABLE_T *) get_fixed_heap_space ((size_t) SIZE_ALIGNED (TABLE_T)); NUM (z) = A68 (symbol_table_count); LEVEL (z) = A68 (symbol_table_count)++; NEST (z) = A68 (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. MOID_T *new_moid (void) { MOID_T *z = (MOID_T *) get_fixed_heap_space ((size_t) SIZE_ALIGNED (MOID_T)); A68 (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. PACK_T *new_pack (void) { PACK_T *z = (PACK_T *) get_fixed_heap_space ((size_t) SIZE_ALIGNED (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. TAG_T *new_tag (void) { TAG_T *z = (TAG_T *) get_fixed_heap_space ((size_t) SIZE_ALIGNED (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; A68_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) = ++A68_PARSER (tag_number); return z; } //! @brief Make special, internal mode. 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. 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. 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 (A68 (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. 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. 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, __func__); *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'. 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 Whether 'p' is top of lexical level. 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. 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; } algol68g-3.1.2/src/a68g/prelude-mathlib.c0000644000175000017500000001433214361065320014642 00000000000000//! @file prelude-mathlib.c //! @author J. Marcel van der Veer // //! @section Copyright // // This file is part of Algol68G - an Algol 68 compiler-interpreter. // Copyright 2001-2023 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" #include "a68g-optimiser.h" #include "a68g-prelude.h" #include "a68g-prelude-mathlib.h" #include "a68g-transput.h" #include "a68g-mp.h" #include "a68g-parser.h" #include "a68g-physics.h" #include "a68g-double.h" #if defined (HAVE_MATHLIB) void stand_mathlib (void) { MOID_T *m; // R specific special functions a68_idf (A68_EXT, "rdigamma", A68_MCACHE (proc_real_real), genie_R_digamma_real); a68_idf (A68_EXT, "rtrigamma", A68_MCACHE (proc_real_real), genie_R_trigamma_real); a68_idf (A68_EXT, "rtetragamma", A68_MCACHE (proc_real_real), genie_R_tetragamma_real); a68_idf (A68_EXT, "rpentagamma", A68_MCACHE (proc_real_real), genie_R_pentagamma_real); a68_idf (A68_EXT, "rpsigamma", A68_MCACHE (proc_real_real_real), genie_R_psigamma_real); // R distribution related functions m = A68_MCACHE (proc_real_real); a68_idf (A68_EXT, "rrt", m, genie_R_rt_real); a68_idf (A68_EXT, "rrchisq", m, genie_R_rchisq_real); a68_idf (A68_EXT, "rrexp", m, genie_R_rexp_real); a68_idf (A68_EXT, "rrgeom", m, genie_R_rgeom_real); a68_idf (A68_EXT, "rrpois", m, genie_R_rpois_real); a68_idf (A68_EXT, "rrsignrank", m, genie_R_rsignrank_real); m = A68_MCACHE (proc_real_real_real); a68_idf (A68_EXT, "rrbeta", m, genie_R_rbeta_real); a68_idf (A68_EXT, "rrbinom", m, genie_R_rbinom_real); a68_idf (A68_EXT, "rrcauchy", m, genie_R_rcauchy_real); a68_idf (A68_EXT, "rrf", m, genie_R_rf_real); a68_idf (A68_EXT, "rrlogis", m, genie_R_rlogis_real); a68_idf (A68_EXT, "rrlnorm", m, genie_R_rlnorm_real); a68_idf (A68_EXT, "rrnbinom", m, genie_R_rnbinom_real); a68_idf (A68_EXT, "rrnorm", m, genie_R_rnorm_real); a68_idf (A68_EXT, "rrunif", m, genie_R_runif_real); a68_idf (A68_EXT, "rrweibull", m, genie_R_rweibull_real); a68_idf (A68_EXT, "rrwilcox", m, genie_R_rwilcox_real); m = a68_proc (M_REAL, M_REAL, M_REAL, M_BOOL, NO_MOID); a68_idf (A68_EXT, "rdt", m, genie_R_dt_real); a68_idf (A68_EXT, "rdchisq", m, genie_R_dchisq_real); a68_idf (A68_EXT, "rdexp", m, genie_R_dexp_real); a68_idf (A68_EXT, "rdgeom", m, genie_R_dgeom_real); a68_idf (A68_EXT, "rdpois", m, genie_R_dpois_real); m = a68_proc (M_REAL, M_REAL, M_REAL, M_REAL, M_BOOL, NO_MOID); a68_idf (A68_EXT, "rdnorm", m, genie_R_dnorm_real); a68_idf (A68_EXT, "rdbeta", m, genie_R_dbeta_real); a68_idf (A68_EXT, "rdbinom", m, genie_R_dbinom_real); a68_idf (A68_EXT, "rdnchisq", m, genie_R_dnchisq_real); a68_idf (A68_EXT, "rdcauchy", m, genie_R_dcauchy_real); a68_idf (A68_EXT, "rdf", m, genie_R_df_real); a68_idf (A68_EXT, "rdlogis", m, genie_R_dlogis_real); a68_idf (A68_EXT, "rdlnorm", m, genie_R_dlnorm_real); a68_idf (A68_EXT, "rdnbinom", m, genie_R_dnbinom_real); a68_idf (A68_EXT, "rdnt", m, genie_R_dnt_real); a68_idf (A68_EXT, "rdunif", m, genie_R_dunif_real); a68_idf (A68_EXT, "rdweibull", m, genie_R_dweibull_real); m = a68_proc (M_REAL, M_REAL, M_REAL, M_REAL, M_REAL, M_BOOL, NO_MOID); a68_idf (A68_EXT, "rdnf", m, genie_R_dnf_real); a68_idf (A68_EXT, "rdhyper", m, genie_R_dhyper_real); m = a68_proc (M_REAL, M_REAL, M_REAL, M_BOOL, M_BOOL, NO_MOID); a68_idf (A68_EXT, "rpt", m, genie_R_pt_real); a68_idf (A68_EXT, "rqt", m, genie_R_qt_real); a68_idf (A68_EXT, "rpchisq", m, genie_R_pchisq_real); a68_idf (A68_EXT, "rqchisq", m, genie_R_qchisq_real); a68_idf (A68_EXT, "rpexp", m, genie_R_pexp_real); a68_idf (A68_EXT, "rqexp", m, genie_R_qexp_real); a68_idf (A68_EXT, "rpgeom", m, genie_R_pgeom_real); a68_idf (A68_EXT, "rqgeom", m, genie_R_qgeom_real); a68_idf (A68_EXT, "rppois", m, genie_R_ppois_real); a68_idf (A68_EXT, "rqpois", m, genie_R_qpois_real); m = a68_proc (M_REAL, M_REAL, M_REAL, M_REAL, M_BOOL, M_BOOL, NO_MOID); a68_idf (A68_EXT, "rpnorm", m, genie_R_pnorm_real); a68_idf (A68_EXT, "rqnorm", m, genie_R_qnorm_real); a68_idf (A68_EXT, "rpbeta", m, genie_R_pbeta_real); a68_idf (A68_EXT, "rqbeta", m, genie_R_qbeta_real); a68_idf (A68_EXT, "rpbinom", m, genie_R_pbinom_real); a68_idf (A68_EXT, "rqbinom", m, genie_R_qbinom_real); a68_idf (A68_EXT, "rpnchisq", m, genie_R_pnchisq_real); a68_idf (A68_EXT, "rqnchisq", m, genie_R_qnchisq_real); a68_idf (A68_EXT, "rpcauchy", m, genie_R_pcauchy_real); a68_idf (A68_EXT, "rqcauchy", m, genie_R_qcauchy_real); a68_idf (A68_EXT, "rpf", m, genie_R_pf_real); a68_idf (A68_EXT, "rqf", m, genie_R_qf_real); a68_idf (A68_EXT, "rplogis", m, genie_R_plogis_real); a68_idf (A68_EXT, "rqlogis", m, genie_R_qlogis_real); a68_idf (A68_EXT, "rplnorm", m, genie_R_plnorm_real); a68_idf (A68_EXT, "rqlnorm", m, genie_R_qlnorm_real); a68_idf (A68_EXT, "rpnbinom", m, genie_R_pnbinom_real); a68_idf (A68_EXT, "rqnbinom", m, genie_R_qnbinom_real); a68_idf (A68_EXT, "rpnt", m, genie_R_pnt_real); a68_idf (A68_EXT, "rqnt", m, genie_R_qnt_real); a68_idf (A68_EXT, "rpunif", m, genie_R_punif_real); a68_idf (A68_EXT, "rqunif", m, genie_R_qunif_real); a68_idf (A68_EXT, "rpweibull", m, genie_R_pweibull_real); a68_idf (A68_EXT, "rqweibull", m, genie_R_qweibull_real); m = a68_proc (M_REAL, M_REAL, M_REAL, M_REAL, M_REAL, M_BOOL, M_BOOL, NO_MOID); a68_idf (A68_EXT, "rptukey", m, genie_R_ptukey_real); a68_idf (A68_EXT, "rqtukey", m, genie_R_qtukey_real); a68_idf (A68_EXT, "rpnf", m, genie_R_pnf_real); a68_idf (A68_EXT, "rqnf", m, genie_R_qnf_real); a68_idf (A68_EXT, "rphyper", m, genie_R_phyper_real); a68_idf (A68_EXT, "rqhyper", m, genie_R_qhyper_real); } #endif algol68g-3.1.2/src/a68g/unix.c0000644000175000017500000005570514361065320012560 00000000000000//! @file unix.c //! @author J. Marcel van der Veer // //! @section Copyright // // This file is part of Algol68G - an Algol 68 compiler-interpreter. // Copyright 2001-2023 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" #include "a68g-genie.h" #include "a68g-prelude.h" #include "a68g-mp.h" #include "a68g-physics.h" #include "a68g-numbers.h" #include "a68g-optimiser.h" #include "a68g-double.h" #include "a68g-transput.h" #define VECTOR_SIZE 512 #define FD_READ 0 #define FD_WRITE 1 #if defined (HAVE_DIRENT_H) //! @brief PROC (STRING) [] STRING directory void genie_directory (NODE_T * p) { A68_REF name; char *buffer; errno = 0; POP_REF (p, &name); CHECK_INIT (p, INITIALISED (&name), M_STRING); buffer = (char *) a68_alloc ((size_t) (1 + a68_string_size (p, name)), __func__, __LINE__); if (buffer == NO_TEXT) { diagnostic (A68_RUNTIME_ERROR, p, ERROR_OUT_OF_CORE); exit_genie (p, A68_RUNTIME_ERROR); PUSH_VALUE (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 (A68_RUNTIME_ERROR, p, ERROR_FILE_ACCESS); exit_genie (p, A68_RUNTIME_ERROR); } do { entry = readdir (dir); if (errno != 0) { diagnostic (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 (A68_RUNTIME_ERROR, p, ERROR_FILE_ACCESS); exit_genie (p, A68_RUNTIME_ERROR); } NEW_ROW_1D (z, row, arr, tup, M_ROW_STRING, M_STRING, n); base = DEREF (A68_REF, &row); for (k = 0; k < n; k++) { entry = readdir (dir); if (errno != 0) { diagnostic (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 (A68_RUNTIME_ERROR, p, ERROR_FILE_ACCESS); exit_genie (p, A68_RUNTIME_ERROR); } PUSH_REF (p, z); a68_free (buffer); } } #endif //! @brief PROC [] INT utc time void genie_utctime (NODE_T * p) { time_t dt; if (time (&dt) == (time_t) - 1) { (void) empty_row (p, M_ROW_INT); } else { A68_REF row; ADDR_T sp = A68_SP; struct tm *tod = gmtime (&dt); PUSH_VALUE (p, TM_YEAR (tod) + 1900, A68_INT); PUSH_VALUE (p, TM_MON (tod) + 1, A68_INT); PUSH_VALUE (p, TM_MDAY (tod), A68_INT); PUSH_VALUE (p, TM_HOUR (tod), A68_INT); PUSH_VALUE (p, TM_MIN (tod), A68_INT); PUSH_VALUE (p, TM_SEC (tod), A68_INT); PUSH_VALUE (p, TM_WDAY (tod) + 1, A68_INT); PUSH_VALUE (p, TM_ISDST (tod), A68_INT); row = genie_make_row (p, M_INT, 8, sp); A68_SP = sp; PUSH_REF (p, row); } } //! @brief PROC [] INT local time void genie_localtime (NODE_T * p) { time_t dt; if (time (&dt) == (time_t) - 1) { (void) empty_row (p, M_ROW_INT); } else { A68_REF row; ADDR_T sp = A68_SP; struct tm *tod = localtime (&dt); PUSH_VALUE (p, TM_YEAR (tod) + 1900, A68_INT); PUSH_VALUE (p, TM_MON (tod) + 1, A68_INT); PUSH_VALUE (p, TM_MDAY (tod), A68_INT); PUSH_VALUE (p, TM_HOUR (tod), A68_INT); PUSH_VALUE (p, TM_MIN (tod), A68_INT); PUSH_VALUE (p, TM_SEC (tod), A68_INT); PUSH_VALUE (p, TM_WDAY (tod) + 1, A68_INT); PUSH_VALUE (p, TM_ISDST (tod), A68_INT); row = genie_make_row (p, M_INT, 8, sp); A68_SP = sp; PUSH_REF (p, row); } } //! @brief PROC INT rows void genie_rows (NODE_T * p) { errno = 0; PUSH_VALUE (p, A68 (term_heigth), A68_INT); } //! @brief PROC INT columns void genie_columns (NODE_T * p) { errno = 0; PUSH_VALUE (p, A68 (term_width), A68_INT); } //! @brief PROC INT argc void genie_argc (NODE_T * p) { errno = 0; PUSH_VALUE (p, A68 (argc), A68_INT); } //! @brief PROC (INT) STRING argv void genie_argv (NODE_T * p) { A68_INT a68_index; errno = 0; POP_OBJECT (p, &a68_index, A68_INT); if (VALUE (&a68_index) >= 1 && VALUE (&a68_index) <= A68 (argc)) { char *q = A68 (argv)[VALUE (&a68_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 Find good argument int find_good_arg (void) { int i; for (i = 0; i < A68 (argc); i++) { char *q = A68 (argv)[i]; if (strncmp (q, "--script", 8) == 0) { return i + 1; } if (strncmp (q, "--run-script", 12) == 0) { return i + 1; } if (strcmp (q, "--") == 0) { return i; } if (strcmp (q, "--exit") == 0) { return i; } } return 0; } //! @brief PROC INT a68g argc void genie_a68_argc (NODE_T * p) { errno = 0; PUSH_VALUE (p, A68 (argc) - find_good_arg (), A68_INT); } //! @brief PROC (INT) STRING a68_argv void genie_a68_argv (NODE_T * p) { A68_INT a68_index; int k; errno = 0; POP_OBJECT (p, &a68_index, A68_INT); k = VALUE (&a68_index); if (k > 1) { k += find_good_arg (); } if (k >= 1 && k <= A68 (argc)) { char *q = A68 (argv)[k - 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 void genie_pwd (NODE_T * p) { size_t size = BUFFER_SIZE; char *buffer = NO_TEXT; BOOL_T cont = A68_TRUE; errno = 0; while (cont) { buffer = (char *) a68_alloc (size, __func__, __LINE__); if (buffer == NO_TEXT) { diagnostic (A68_RUNTIME_ERROR, p, ERROR_OUT_OF_CORE); exit_genie (p, A68_RUNTIME_ERROR); } if (getcwd (buffer, size) == buffer) { cont = A68_FALSE; } else { a68_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)); a68_free (buffer); } else { PUSH_REF (p, empty_string (p)); } } //! @brief PROC (STRING) INT cd void genie_cd (NODE_T * p) { A68_REF dir; char *buffer; errno = 0; POP_REF (p, &dir); CHECK_INIT (p, INITIALISED (&dir), M_STRING); buffer = (char *) a68_alloc ((size_t) (1 + a68_string_size (p, dir)), __func__, __LINE__); if (buffer == NO_TEXT) { diagnostic (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_VALUE (p, 0, A68_INT); } else { diagnostic (A68_RUNTIME_ERROR, p, ERROR_FILE_ACCESS); exit_genie (p, A68_RUNTIME_ERROR); } a68_free (buffer); } } //! @brief PROC (STRING) BITS void genie_file_mode (NODE_T * p) { A68_REF name; char *buffer; errno = 0; POP_REF (p, &name); CHECK_INIT (p, INITIALISED (&name), M_STRING); buffer = (char *) a68_alloc ((size_t) (1 + a68_string_size (p, name)), __func__, __LINE__); if (buffer == NO_TEXT) { diagnostic (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_VALUE (p, (unt) (ST_MODE (&status)), A68_BITS); } else { PUSH_VALUE (p, 0x0, A68_BITS); } a68_free (buffer); } } //! @brief PROC (STRING) BOOL file is block device void genie_file_is_block_device (NODE_T * p) { A68_REF name; char *buffer; errno = 0; POP_REF (p, &name); CHECK_INIT (p, INITIALISED (&name), M_STRING); buffer = (char *) a68_alloc ((size_t) (1 + a68_string_size (p, name)), __func__, __LINE__); if (buffer == NO_TEXT) { diagnostic (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_VALUE (p, (BOOL_T) (S_ISBLK (ST_MODE (&status)) != 0 ? A68_TRUE : A68_FALSE), A68_BOOL); } else { PUSH_VALUE (p, A68_FALSE, A68_BOOL); } a68_free (buffer); } } //! @brief PROC (STRING) BOOL file is char device void genie_file_is_char_device (NODE_T * p) { A68_REF name; char *buffer; errno = 0; POP_REF (p, &name); CHECK_INIT (p, INITIALISED (&name), M_STRING); buffer = (char *) a68_alloc ((size_t) (1 + a68_string_size (p, name)), __func__, __LINE__); if (buffer == NO_TEXT) { diagnostic (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_VALUE (p, (BOOL_T) (S_ISCHR (ST_MODE (&status)) != 0 ? A68_TRUE : A68_FALSE), A68_BOOL); } else { PUSH_VALUE (p, A68_FALSE, A68_BOOL); } a68_free (buffer); } } //! @brief PROC (STRING) BOOL file is directory void genie_file_is_directory (NODE_T * p) { A68_REF name; char *buffer; errno = 0; POP_REF (p, &name); CHECK_INIT (p, INITIALISED (&name), M_STRING); buffer = (char *) a68_alloc ((size_t) (1 + a68_string_size (p, name)), __func__, __LINE__); if (buffer == NO_TEXT) { diagnostic (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_VALUE (p, (BOOL_T) (S_ISDIR (ST_MODE (&status)) != 0 ? A68_TRUE : A68_FALSE), A68_BOOL); } else { PUSH_VALUE (p, A68_FALSE, A68_BOOL); } a68_free (buffer); } } //! @brief PROC (STRING) BOOL file is regular void genie_file_is_regular (NODE_T * p) { A68_REF name; char *buffer; errno = 0; POP_REF (p, &name); CHECK_INIT (p, INITIALISED (&name), M_STRING); buffer = (char *) a68_alloc ((size_t) (1 + a68_string_size (p, name)), __func__, __LINE__); if (buffer == NO_TEXT) { diagnostic (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_VALUE (p, (BOOL_T) (S_ISREG (ST_MODE (&status)) != 0 ? A68_TRUE : A68_FALSE), A68_BOOL); } else { PUSH_VALUE (p, A68_FALSE, A68_BOOL); } a68_free (buffer); } } #if defined (S_ISFIFO) //! @brief PROC (STRING) BOOL file is fifo void genie_file_is_fifo (NODE_T * p) { A68_REF name; char *buffer; errno = 0; POP_REF (p, &name); CHECK_INIT (p, INITIALISED (&name), M_STRING); buffer = (char *) a68_alloc ((size_t) (1 + a68_string_size (p, name)), __func__, __LINE__); if (buffer == NO_TEXT) { diagnostic (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_VALUE (p, (BOOL_T) (S_ISFIFO (ST_MODE (&status)) != 0 ? A68_TRUE : A68_FALSE), A68_BOOL); } else { PUSH_VALUE (p, A68_FALSE, A68_BOOL); } a68_free (buffer); } } #endif #if defined (S_ISLNK) //! @brief PROC (STRING) BOOL file is link void genie_file_is_link (NODE_T * p) { A68_REF name; char *buffer; errno = 0; POP_REF (p, &name); CHECK_INIT (p, INITIALISED (&name), M_STRING); buffer = (char *) a68_alloc ((size_t) (1 + a68_string_size (p, name)), __func__, __LINE__); if (buffer == NO_TEXT) { diagnostic (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_VALUE (p, (BOOL_T) (S_ISLNK (ST_MODE (&status)) != 0 ? A68_TRUE : A68_FALSE), A68_BOOL); } else { PUSH_VALUE (p, A68_FALSE, A68_BOOL); } a68_free (buffer); } } #endif //! @brief Convert [] STRING row to char *vec[]. 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_ALIGNED (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 a68_index = calculate_internal_index (tup, DIM (arr)); ADDR_T elem_addr = (a68_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), M_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 (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[]. void free_vector (char *vec[]) { int k = 0; while (vec[k] != NO_TEXT) { a68_free (vec[k]); k++; } } //! @brief Reset error number. void genie_reset_errno (NODE_T * p) { (void) *p; errno = 0; } //! @brief Error number. void genie_errno (NODE_T * p) { PUSH_VALUE (p, errno, A68_INT); } //! @brief PROC strerror = (INT) STRING 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. 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, M_REF_FILE, SIZE (M_FILE)); f = FILE_DEREF (z); STATUS (f) = (STATUS_MASK_T) ((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. void genie_mkpipe (NODE_T * p, int fd_r, int fd_w, int pid) { A68_REF r, w; errno = 0; // Set up pipe. set_up_file (p, &r, fd_r, A68 (stand_in_channel), A68_TRUE, A68_FALSE, pid); set_up_file (p, &w, fd_w, A68 (stand_out_channel), A68_FALSE, A68_TRUE, pid); // push pipe. PUSH_REF (p, r); PUSH_REF (p, w); PUSH_VALUE (p, pid, A68_INT); } //! @brief Push an environment string. void genie_getenv (NODE_T * p) { A68_REF a_env; char *val, *z, *z_env; errno = 0; POP_REF (p, &a_env); CHECK_INIT (p, INITIALISED (&a_env), M_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 void genie_fork (NODE_T * p) { #if defined (BUILD_WIN32) PUSH_VALUE (p, -1, A68_INT); #else int pid; errno = 0; pid = (int) fork (); PUSH_VALUE (p, pid, A68_INT); #endif } //! @brief PROC execve = (STRING, [] STRING, [] STRING) INT void genie_exec (NODE_T * p) { int ret; A68_REF a_prog, a_args, a_env; char *prog, *argv[VECTOR_SIZE], *envp[VECTOR_SIZE]; errno = 0; // 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 (A68_RUNTIME_ERROR, p, ERROR_EMPTY_ARGUMENT); exit_genie (p, A68_RUNTIME_ERROR); } ret = execve (prog, argv, envp); // execve only returns if it fails. free_vector (argv); free_vector (envp); a68_free (prog); PUSH_VALUE (p, ret, A68_INT); } //! @brief PROC execve child = (STRING, [] STRING, [] STRING) INT void genie_exec_sub (NODE_T * p) { int pid; A68_REF a_prog, a_args, a_env; errno = 0; // 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 (BUILD_WIN32) pid = -1; (void) pid; PUSH_VALUE (p, -1, A68_INT); return; #else pid = (int) fork (); if (pid == -1) { PUSH_VALUE (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 (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. a68_exit (EXIT_FAILURE); PUSH_VALUE (p, 0, A68_INT); } else { // parent process. PUSH_VALUE (p, pid, A68_INT); } #endif } //! @brief PROC execve child pipe = (STRING, [] STRING, [] STRING) PIPE void genie_exec_sub_pipeline (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; A68_REF a_prog, a_args, a_env; errno = 0; // Pop parameters. POP_REF (p, &a_env); POP_REF (p, &a_args); POP_REF (p, &a_prog); #if !defined (BUILD_UNIX) pid = -1; (void) pid; genie_mkpipe (p, -1, -1, -1); return; #else // Create the pipes and fork. int ptoc_fd[2], ctop_fd[2]; 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 (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. a68_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 } //! @brief PROC execve output = (STRING, [] STRING, [] STRING, REF_STRING) INT void genie_exec_sub_output (NODE_T * p) { // Child redirects STDIN and STDOUT. // // pipe ptoc // ->W...R-> // PARENT CHILD // <-R...W<- // pipe ctop int pid; A68_REF a_prog, a_args, a_env, dest; errno = 0; // Pop parameters. POP_REF (p, &dest); POP_REF (p, &a_env); POP_REF (p, &a_args); POP_REF (p, &a_prog); #if !defined (BUILD_UNIX) pid = -1; (void) pid; PUSH_VALUE (p, -1, A68_INT); return; #else // Create the pipes and fork. int ptoc_fd[2], ctop_fd[2]; if ((pipe (ptoc_fd) == -1) || (pipe (ctop_fd) == -1)) { PUSH_VALUE (p, -1, A68_INT); return; } pid = (int) fork (); if (pid == -1) { // Fork failure. PUSH_VALUE (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 (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. a68_exit (EXIT_FAILURE); PUSH_VALUE (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) { plusab_transput_buffer (p, INPUT_BUFFER, ch); } } while (pipe_read > 0); do { ret = (int) waitpid ((a68_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)); } ASSERT (close (ptoc_fd[FD_WRITE]) == 0); ASSERT (close (ctop_fd[FD_READ]) == 0); PUSH_VALUE (p, ret, A68_INT); } #endif } //! @brief PROC create pipe = PIPE void genie_create_pipe (NODE_T * p) { errno = 0; genie_stand_in (p); genie_stand_out (p); PUSH_VALUE (p, -1, A68_INT); } //! @brief PROC wait pid = (INT) VOID void genie_waitpid (NODE_T * p) { A68_INT k; errno = 0; POP_OBJECT (p, &k, A68_INT); #if defined (BUILD_UNIX) ASSERT (waitpid ((a68_pid_t) VALUE (&k), NULL, 0) != -1); #endif } algol68g-3.1.2/src/a68g/mp-math.c0000644000175000017500000016015614361065320013135 00000000000000//! @file mp-math.c //! @author J. Marcel van der Veer // //! @section Copyright // // This file is part of Algol68G - an Algol 68 compiler-interpreter. // Copyright 2001-2023 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" #include "a68g-genie.h" #include "a68g-prelude.h" #include "a68g-double.h" #include "a68g-mp.h" //! @brief Test on |"z"| > 0.001 for argument reduction in "sin" and "exp". static inline BOOL_T eps_mp (MP_T * z, int digs) { 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 { // More or less optimised for LONG and default LONG LONG precisions. return (BOOL_T) (digs <= 10 ? ABS (MP_DIGIT (z, 1)) > 0.01 * MP_RADIX : ABS (MP_DIGIT (z, 1)) > 0.001 * MP_RADIX); } } //! @brief PROC (LONG REAL) LONG REAL sqrt MP_T *sqrt_mp (NODE_T * p, MP_T * z, MP_T * x, int digs) { ADDR_T pop_sp = A68_SP; if (MP_DIGIT (x, 1) == 0) { A68_SP = pop_sp; SET_MP_ZERO (z, digs); return z; } if (MP_DIGIT (x, 1) < 0) { A68_SP = pop_sp; errno = EDOM; return NaN_MP; } int gdigs = FUN_DIGITS (digs), hdigs; BOOL_T reciprocal = A68_FALSE; MP_T *z_g = nil_mp (p, gdigs); MP_T *x_g = len_mp (p, x, digs, gdigs); MP_T *tmp = nil_mp (p, gdigs); // 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, gdigs); } 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, gdigs); MP_EXPONENT (z_g) += (MP_T) (expo / 2); } else { // Argument is in range. Estimate the root as double. #if (A68_LEVEL >= 3) DOUBLE_T x_d = mp_to_real_16 (p, x_g, gdigs); (void) real_16_to_mp (p, z_g, sqrtq (x_d), gdigs); #else REAL_T x_d = mp_to_real (p, x_g, gdigs); (void) real_to_mp (p, z_g, sqrt (x_d), gdigs); #endif // Newton's method: x = (x + a / x) / 2. int decimals = DOUBLE_ACCURACY; do { decimals <<= 1; hdigs = MINIMUM (1 + decimals / LOG_MP_RADIX, gdigs); (void) div_mp (p, tmp, x_g, z_g, hdigs); (void) add_mp (p, tmp, z_g, tmp, hdigs); (void) half_mp (p, z_g, tmp, hdigs); } while (decimals < 2 * gdigs * LOG_MP_RADIX); } if (reciprocal) { (void) rec_mp (p, z_g, z_g, digs); } (void) shorten_mp (p, z, digs, z_g, gdigs); // Exit. A68_SP = pop_sp; return z; } //! @brief PROC (LONG REAL) LONG REAL curt MP_T *curt_mp (NODE_T * p, MP_T * z, MP_T * x, int digs) { ADDR_T pop_sp = A68_SP; if (MP_DIGIT (x, 1) == 0) { A68_SP = pop_sp; SET_MP_ZERO (z, digs); return z; } BOOL_T change_sign = A68_FALSE; if (MP_DIGIT (x, 1) < 0) { change_sign = A68_TRUE; MP_DIGIT (x, 1) = -MP_DIGIT (x, 1); } int gdigs = FUN_DIGITS (digs), hdigs; BOOL_T reciprocal = A68_FALSE; MP_T *z_g = nil_mp (p, gdigs); MP_T *x_g = len_mp (p, x, digs, gdigs); MP_T *tmp = nil_mp (p, gdigs); // 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, gdigs); } 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, gdigs); MP_EXPONENT (z_g) += (MP_T) (expo / 3); } else { // Argument is in range. Estimate the root as double. int decimals; #if (A68_LEVEL >= 3) DOUBLE_T x_d = mp_to_real_16 (p, x_g, gdigs); (void) real_16_to_mp (p, z_g, cbrtq (x_d), gdigs); #else REAL_T x_d = mp_to_real (p, x_g, gdigs); (void) real_to_mp (p, z_g, cbrt (x_d), gdigs); #endif // Newton's method: x = (2 x + a / x ^ 2) / 3. decimals = DOUBLE_ACCURACY; do { decimals <<= 1; hdigs = MINIMUM (1 + decimals / LOG_MP_RADIX, gdigs); (void) mul_mp (p, tmp, z_g, z_g, hdigs); (void) div_mp (p, tmp, x_g, tmp, hdigs); (void) add_mp (p, tmp, z_g, tmp, hdigs); (void) add_mp (p, tmp, z_g, tmp, hdigs); (void) div_mp_digit (p, z_g, tmp, (MP_T) 3, hdigs); } while (decimals < gdigs * LOG_MP_RADIX); } if (reciprocal) { (void) rec_mp (p, z_g, z_g, digs); } (void) shorten_mp (p, z, digs, z_g, gdigs); // Exit. A68_SP = pop_sp; if (change_sign) { MP_DIGIT (z, 1) = -MP_DIGIT (z, 1); } return z; } //! @brief PROC (LONG REAL) LONG REAL hypot MP_T *hypot_mp (NODE_T * p, MP_T * z, MP_T * x, MP_T * y, int digs) { // sqrt (x^2 + y^2). ADDR_T pop_sp = A68_SP; MP_T *t = nil_mp (p, digs); MP_T *u = nil_mp (p, digs); MP_T *v = nil_mp (p, digs); (void) move_mp (u, x, digs); (void) move_mp (v, y, digs); MP_DIGIT (u, 1) = ABS (MP_DIGIT (u, 1)); MP_DIGIT (v, 1) = ABS (MP_DIGIT (v, 1)); if (IS_ZERO_MP (u)) { (void) move_mp (z, v, digs); } else if (IS_ZERO_MP (v)) { (void) move_mp (z, u, digs); } else { SET_MP_ONE (t, digs); (void) sub_mp (p, z, u, v, digs); if (MP_DIGIT (z, 1) > 0) { (void) div_mp (p, z, v, u, digs); (void) mul_mp (p, z, z, z, digs); (void) add_mp (p, z, t, z, digs); (void) sqrt_mp (p, z, z, digs); (void) mul_mp (p, z, u, z, digs); } else { (void) div_mp (p, z, u, v, digs); (void) mul_mp (p, z, z, z, digs); (void) add_mp (p, z, t, z, digs); (void) sqrt_mp (p, z, z, digs); (void) mul_mp (p, z, v, z, digs); } } A68_SP = pop_sp; return z; } //! @brief PROC (LONG REAL) LONG REAL exp MP_T *exp_mp (NODE_T * p, MP_T * z, MP_T * x, int digs) { // Argument is reduced by using exp (z / (2 ** n)) ** (2 ** n) = exp(z). int m, n, gdigs = FUN_DIGITS (digs); ADDR_T pop_sp = A68_SP; BOOL_T iterate; if (MP_DIGIT (x, 1) == 0) { SET_MP_ONE (z, digs); return z; } MP_T *x_g = len_mp (p, x, digs, gdigs); MP_T *sum = nil_mp (p, gdigs); MP_T *a68_pow = nil_mp (p, gdigs); MP_T *fac = nil_mp (p, gdigs); MP_T *tmp = nil_mp (p, gdigs); m = 0; // Scale x down. while (eps_mp (x_g, gdigs)) { m++; (void) half_mp (p, x_g, x_g, gdigs); } // Calculate Taylor sum exp (z) = 1 + z / 1 ! + z ** 2 / 2 ! + .. SET_MP_ONE (sum, gdigs); (void) add_mp (p, sum, sum, x_g, gdigs); (void) mul_mp (p, a68_pow, x_g, x_g, gdigs); (void) half_mp (p, tmp, a68_pow, gdigs); (void) add_mp (p, sum, sum, tmp, gdigs); (void) mul_mp (p, a68_pow, a68_pow, x_g, gdigs); (void) div_mp_digit (p, tmp, a68_pow, (MP_T) 6, gdigs); (void) add_mp (p, sum, sum, tmp, gdigs); (void) mul_mp (p, a68_pow, a68_pow, x_g, gdigs); (void) div_mp_digit (p, tmp, a68_pow, (MP_T) 24, gdigs); (void) add_mp (p, sum, sum, tmp, gdigs); (void) mul_mp (p, a68_pow, a68_pow, x_g, gdigs); (void) div_mp_digit (p, tmp, a68_pow, (MP_T) 120, gdigs); (void) add_mp (p, sum, sum, tmp, gdigs); (void) mul_mp (p, a68_pow, a68_pow, x_g, gdigs); (void) div_mp_digit (p, tmp, a68_pow, (MP_T) 720, gdigs); (void) add_mp (p, sum, sum, tmp, gdigs); (void) mul_mp (p, a68_pow, a68_pow, x_g, gdigs); (void) div_mp_digit (p, tmp, a68_pow, (MP_T) 5040, gdigs); (void) add_mp (p, sum, sum, tmp, gdigs); (void) mul_mp (p, a68_pow, a68_pow, x_g, gdigs); (void) div_mp_digit (p, tmp, a68_pow, (MP_T) 40320, gdigs); (void) add_mp (p, sum, sum, tmp, gdigs); (void) mul_mp (p, a68_pow, a68_pow, x_g, gdigs); (void) div_mp_digit (p, tmp, a68_pow, (MP_T) 362880, gdigs); (void) add_mp (p, sum, sum, tmp, gdigs); (void) mul_mp (p, a68_pow, a68_pow, x_g, gdigs); (void) set_mp (fac, (MP_T) (MP_T) 3628800, 0, gdigs); n = 10; iterate = (BOOL_T) (MP_DIGIT (a68_pow, 1) != 0); while (iterate) { (void) div_mp (p, tmp, a68_pow, fac, gdigs); if (MP_EXPONENT (tmp) <= (MP_EXPONENT (sum) - gdigs)) { iterate = A68_FALSE; } else { (void) add_mp (p, sum, sum, tmp, gdigs); (void) mul_mp (p, a68_pow, a68_pow, x_g, gdigs); n++; (void) mul_mp_digit (p, fac, fac, (MP_T) n, gdigs); } } // Square exp (x) up. while (m--) { (void) mul_mp (p, sum, sum, sum, gdigs); } (void) shorten_mp (p, z, digs, sum, gdigs); // Exit. A68_SP = pop_sp; return z; } //! @brief PROC (LONG REAL) LONG REAL exp (x) - 1 // assuming "x" to be close to 0. MP_T *expm1_mp (NODE_T * p, MP_T * z, MP_T * x, int digs) { int n, gdigs = FUN_DIGITS (digs); ADDR_T pop_sp = A68_SP; BOOL_T iterate; if (MP_DIGIT (x, 1) == 0) { SET_MP_ONE (z, digs); return z; } MP_T *x_g = len_mp (p, x, digs, gdigs); MP_T *sum = nil_mp (p, gdigs); MP_T *a68_pow = nil_mp (p, gdigs); MP_T *fac = nil_mp (p, gdigs); MP_T *tmp = nil_mp (p, gdigs); // Calculate Taylor sum expm1 (z) = z / 1 ! + z ** 2 / 2 ! + ... (void) add_mp (p, sum, sum, x_g, gdigs); (void) mul_mp (p, a68_pow, x_g, x_g, gdigs); (void) half_mp (p, tmp, a68_pow, gdigs); (void) add_mp (p, sum, sum, tmp, gdigs); (void) mul_mp (p, a68_pow, a68_pow, x_g, gdigs); (void) div_mp_digit (p, tmp, a68_pow, (MP_T) 6, gdigs); (void) add_mp (p, sum, sum, tmp, gdigs); (void) mul_mp (p, a68_pow, a68_pow, x_g, gdigs); (void) div_mp_digit (p, tmp, a68_pow, (MP_T) 24, gdigs); (void) add_mp (p, sum, sum, tmp, gdigs); (void) mul_mp (p, a68_pow, a68_pow, x_g, gdigs); (void) div_mp_digit (p, tmp, a68_pow, (MP_T) 120, gdigs); (void) add_mp (p, sum, sum, tmp, gdigs); (void) mul_mp (p, a68_pow, a68_pow, x_g, gdigs); (void) div_mp_digit (p, tmp, a68_pow, (MP_T) 720, gdigs); (void) add_mp (p, sum, sum, tmp, gdigs); (void) mul_mp (p, a68_pow, a68_pow, x_g, gdigs); (void) div_mp_digit (p, tmp, a68_pow, (MP_T) 5040, gdigs); (void) add_mp (p, sum, sum, tmp, gdigs); (void) mul_mp (p, a68_pow, a68_pow, x_g, gdigs); (void) div_mp_digit (p, tmp, a68_pow, (MP_T) 40320, gdigs); (void) add_mp (p, sum, sum, tmp, gdigs); (void) mul_mp (p, a68_pow, a68_pow, x_g, gdigs); (void) div_mp_digit (p, tmp, a68_pow, (MP_T) 362880, gdigs); (void) add_mp (p, sum, sum, tmp, gdigs); (void) mul_mp (p, a68_pow, a68_pow, x_g, gdigs); (void) set_mp (fac, (MP_T) (MP_T) 3628800, 0, gdigs); n = 10; iterate = (BOOL_T) (MP_DIGIT (a68_pow, 1) != 0); while (iterate) { (void) div_mp (p, tmp, a68_pow, fac, gdigs); if (MP_EXPONENT (tmp) <= (MP_EXPONENT (sum) - gdigs)) { iterate = A68_FALSE; } else { (void) add_mp (p, sum, sum, tmp, gdigs); (void) mul_mp (p, a68_pow, a68_pow, x_g, gdigs); n++; (void) mul_mp_digit (p, fac, fac, (MP_T) n, gdigs); } } (void) shorten_mp (p, z, digs, sum, gdigs); // Exit. A68_SP = pop_sp; return z; } //! @brief ln scale MP_T *mp_ln_scale (NODE_T * p, MP_T * z, int digs) { ADDR_T pop_sp = A68_SP; int gdigs = FUN_DIGITS (digs); MP_T *z_g = nil_mp (p, gdigs); // First see if we can restore a previous calculation. if (gdigs <= A68_MP (mp_ln_scale_size)) { (void) move_mp (z_g, A68_MP (mp_ln_scale), gdigs); } else { // No luck with the kept value, we generate a longer one. (void) set_mp (z_g, (MP_T) 1, 1, gdigs); (void) ln_mp (p, z_g, z_g, gdigs); A68_MP (mp_ln_scale) = (MP_T *) get_heap_space ((unt) SIZE_MP (gdigs)); (void) move_mp (A68_MP (mp_ln_scale), z_g, gdigs); A68_MP (mp_ln_scale_size) = gdigs; } (void) shorten_mp (p, z, digs, z_g, gdigs); A68_SP = pop_sp; return z; } //! @brief ln 10 MP_T *mp_ln_10 (NODE_T * p, MP_T * z, int digs) { ADDR_T pop_sp = A68_SP; int gdigs = FUN_DIGITS (digs); MP_T *z_g = nil_mp (p, gdigs); // First see if we can restore a previous calculation. if (gdigs <= A68_MP (mp_ln_10_size)) { (void) move_mp (z_g, A68_MP (mp_ln_10), gdigs); } else { // No luck with the kept value, we generate a longer one. (void) set_mp (z_g, (MP_T) 10, 0, gdigs); (void) ln_mp (p, z_g, z_g, gdigs); A68_MP (mp_ln_10) = (MP_T *) get_heap_space ((unt) SIZE_MP (gdigs)); (void) move_mp (A68_MP (mp_ln_10), z_g, gdigs); A68_MP (mp_ln_10_size) = gdigs; } (void) shorten_mp (p, z, digs, z_g, gdigs); A68_SP = pop_sp; return z; } //! @brief PROC (LONG REAL) LONG REAL ln MP_T *ln_mp (NODE_T * p, MP_T * z, MP_T * x, int digs) { // Depending on the argument we choose either Taylor or Newton. ADDR_T pop_sp = A68_SP; int gdigs = FUN_DIGITS (digs); BOOL_T negative, scale; MP_T expo = 0; if (MP_DIGIT (x, 1) <= 0) { errno = EDOM; return NaN_MP; } MP_T *x_g = len_mp (p, x, digs, gdigs); MP_T *z_g = nil_mp (p, gdigs); // 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, digs); } // 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. int n = 2; BOOL_T iterate; MP_T *tmp = nil_mp (p, gdigs); MP_T *a68_pow = nil_mp (p, gdigs); (void) minus_one_mp (p, x_g, x_g, gdigs); (void) mul_mp (p, a68_pow, x_g, x_g, gdigs); (void) move_mp (z_g, x_g, gdigs); iterate = (BOOL_T) (MP_DIGIT (a68_pow, 1) != 0); while (iterate) { (void) div_mp_digit (p, tmp, a68_pow, (MP_T) n, gdigs); if (MP_EXPONENT (tmp) <= (MP_EXPONENT (z_g) - gdigs)) { iterate = A68_FALSE; } else { MP_DIGIT (tmp, 1) = (EVEN (n) ? -MP_DIGIT (tmp, 1) : MP_DIGIT (tmp, 1)); (void) add_mp (p, z_g, z_g, tmp, gdigs); (void) mul_mp (p, a68_pow, a68_pow, x_g, gdigs); n++; } } } else { // Newton's method: x = x - 1 + a / exp (x). MP_T *tmp = nil_mp (p, gdigs); // Construct an estimate. #if (A68_LEVEL >= 3) (void) real_16_to_mp (p, z_g, logq (mp_to_real_16 (p, x_g, gdigs)), gdigs); #else (void) real_to_mp (p, z_g, log (mp_to_real (p, x_g, gdigs)), gdigs); #endif int decimals = DOUBLE_ACCURACY; do { int hdigs; decimals <<= 1; hdigs = MINIMUM (1 + decimals / LOG_MP_RADIX, gdigs); (void) exp_mp (p, tmp, z_g, hdigs); (void) div_mp (p, tmp, x_g, tmp, hdigs); (void) minus_one_mp (p, z_g, z_g, hdigs); (void) add_mp (p, z_g, z_g, tmp, hdigs); } while (decimals < gdigs * LOG_MP_RADIX); } // Inverse scaling. if (scale) { // ln (x * MP_RADIX ** n) = ln (x) + n * ln (MP_RADIX). MP_T *ln_base = nil_mp (p, gdigs); (void) mp_ln_scale (p, ln_base, gdigs); (void) mul_mp_digit (p, ln_base, ln_base, (MP_T) expo, gdigs); (void) add_mp (p, z_g, z_g, ln_base, gdigs); } if (negative) { MP_DIGIT (z_g, 1) = -MP_DIGIT (z_g, 1); } (void) shorten_mp (p, z, digs, z_g, gdigs); // Exit. A68_SP = pop_sp; return z; } //! @brief PROC (LONG REAL) LONG REAL log MP_T *log_mp (NODE_T * p, MP_T * z, MP_T * x, int digs) { ADDR_T pop_sp = A68_SP; MP_T *ln_10 = nil_mp (p, digs); if (ln_mp (p, z, x, digs) == NaN_MP) { errno = EDOM; return NaN_MP; } (void) mp_ln_10 (p, ln_10, digs); (void) div_mp (p, z, z, ln_10, digs); A68_SP = pop_sp; return z; } //! @brief sinh ("z") and cosh ("z") MP_T *hyp_mp (NODE_T * p, MP_T * sh, MP_T * ch, MP_T * z, int digs) { ADDR_T pop_sp = A68_SP; MP_T *x_g = nil_mp (p, digs); MP_T *y_g = nil_mp (p, digs); MP_T *z_g = nil_mp (p, digs); (void) move_mp (z_g, z, digs); (void) exp_mp (p, x_g, z_g, digs); (void) rec_mp (p, y_g, x_g, digs); (void) add_mp (p, ch, x_g, y_g, digs); // 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, digs); MP_DIGIT (z_g, 1) = -MP_DIGIT (z_g, 1); (void) expm1_mp (p, y_g, z_g, digs); } (void) sub_mp (p, sh, x_g, y_g, digs); (void) half_mp (p, sh, sh, digs); (void) half_mp (p, ch, ch, digs); A68_SP = pop_sp; return z; } //! @brief PROC (LONG REAL) LONG REAL sinh MP_T *sinh_mp (NODE_T * p, MP_T * z, MP_T * x, int digs) { ADDR_T pop_sp = A68_SP; int gdigs = FUN_DIGITS (digs); MP_T *x_g = len_mp (p, x, digs, gdigs); MP_T *y_g = nil_mp (p, gdigs); MP_T *z_g = nil_mp (p, gdigs); (void) hyp_mp (p, z_g, y_g, x_g, gdigs); (void) shorten_mp (p, z, digs, z_g, gdigs); A68_SP = pop_sp; return z; } //! @brief PROC (LONG REAL) LONG REAL asinh MP_T *asinh_mp (NODE_T * p, MP_T * z, MP_T * x, int digs) { if (IS_ZERO_MP (x)) { SET_MP_ZERO (z, digs); return z; } else { ADDR_T pop_sp = A68_SP; int gdigs; if (MP_EXPONENT (x) >= -1) { gdigs = FUN_DIGITS (digs); } else { // Extra precision when x^2+1 gets close to 1. gdigs = 2 * FUN_DIGITS (digs); } MP_T *x_g = len_mp (p, x, digs, gdigs); MP_T *y_g = nil_mp (p, gdigs); MP_T *z_g = nil_mp (p, gdigs); (void) mul_mp (p, z_g, x_g, x_g, gdigs); SET_MP_ONE (y_g, gdigs); (void) add_mp (p, y_g, z_g, y_g, gdigs); (void) sqrt_mp (p, y_g, y_g, gdigs); (void) add_mp (p, y_g, y_g, x_g, gdigs); (void) ln_mp (p, z_g, y_g, gdigs); if (IS_ZERO_MP (z_g)) { (void) move_mp (z, x, digs); } else { (void) shorten_mp (p, z, digs, z_g, gdigs); } A68_SP = pop_sp; return z; } } //! @brief PROC (LONG REAL) LONG REAL cosh MP_T *cosh_mp (NODE_T * p, MP_T * z, MP_T * x, int digs) { ADDR_T pop_sp = A68_SP; int gdigs = FUN_DIGITS (digs); MP_T *x_g = len_mp (p, x, digs, gdigs); MP_T *y_g = nil_mp (p, gdigs); MP_T *z_g = nil_mp (p, gdigs); (void) hyp_mp (p, y_g, z_g, x_g, gdigs); (void) shorten_mp (p, z, digs, z_g, gdigs); A68_SP = pop_sp; return z; } //! @brief PROC (LONG REAL) LONG REAL acosh MP_T *acosh_mp (NODE_T * p, MP_T * z, MP_T * x, int digs) { ADDR_T pop_sp = A68_SP; int gdigs; if (MP_DIGIT (x, 1) == 1 && MP_DIGIT (x, 2) == 0) { // Extra precision when x^2-1 gets close to 0. gdigs = 2 * FUN_DIGITS (digs); } else { gdigs = FUN_DIGITS (digs); } MP_T *x_g = len_mp (p, x, digs, gdigs); MP_T *y_g = nil_mp (p, gdigs); MP_T *z_g = nil_mp (p, gdigs); (void) mul_mp (p, z_g, x_g, x_g, gdigs); SET_MP_ONE (y_g, gdigs); (void) sub_mp (p, y_g, z_g, y_g, gdigs); (void) sqrt_mp (p, y_g, y_g, gdigs); (void) add_mp (p, y_g, y_g, x_g, gdigs); (void) ln_mp (p, z_g, y_g, gdigs); (void) shorten_mp (p, z, digs, z_g, gdigs); A68_SP = pop_sp; return z; } //! @brief PROC (LONG REAL) LONG REAL tanh MP_T *tanh_mp (NODE_T * p, MP_T * z, MP_T * x, int digs) { ADDR_T pop_sp = A68_SP; int gdigs = FUN_DIGITS (digs); MP_T *x_g = len_mp (p, x, digs, gdigs); MP_T *y_g = nil_mp (p, gdigs); MP_T *z_g = nil_mp (p, gdigs); (void) hyp_mp (p, y_g, z_g, x_g, gdigs); (void) div_mp (p, z_g, y_g, z_g, gdigs); (void) shorten_mp (p, z, digs, z_g, gdigs); A68_SP = pop_sp; return z; } //! @brief PROC (LONG REAL) LONG REAL atanh MP_T *atanh_mp (NODE_T * p, MP_T * z, MP_T * x, int digs) { ADDR_T pop_sp = A68_SP; int gdigs = FUN_DIGITS (digs); MP_T *x_g = len_mp (p, x, digs, gdigs); MP_T *y_g = nil_mp (p, gdigs); MP_T *z_g = nil_mp (p, gdigs); SET_MP_ONE (y_g, gdigs); (void) add_mp (p, z_g, y_g, x_g, gdigs); (void) sub_mp (p, y_g, y_g, x_g, gdigs); (void) div_mp (p, y_g, z_g, y_g, gdigs); (void) ln_mp (p, z_g, y_g, gdigs); (void) half_mp (p, z_g, z_g, gdigs); (void) shorten_mp (p, z, digs, z_g, gdigs); A68_SP = pop_sp; return z; } //! @brief PROC (LONG REAL) LONG REAL sin MP_T *sin_mp (NODE_T * p, MP_T * z, MP_T * x, int digs) { // Use triple-angle relation to reduce argument. ADDR_T pop_sp = A68_SP; int m, n, gdigs = FUN_DIGITS (digs); BOOL_T flip, negative, iterate, even; // We will use "pi". MP_T *pi = nil_mp (p, gdigs); MP_T *tpi = nil_mp (p, gdigs); MP_T *hpi = nil_mp (p, gdigs); (void) mp_pi (p, pi, MP_PI, gdigs); (void) mp_pi (p, tpi, MP_TWO_PI, gdigs); (void) mp_pi (p, hpi, MP_HALF_PI, gdigs); // Argument reduction (1): sin (x) = sin (x mod 2 pi). MP_T *x_g = len_mp (p, x, digs, gdigs); (void) mod_mp (p, x_g, x_g, tpi, gdigs); // 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); } MP_T *tmp = nil_mp (p, gdigs); (void) sub_mp (p, tmp, x_g, pi, gdigs); flip = (BOOL_T) (MP_DIGIT (tmp, 1) > 0); if (flip) { // x > pi (void) sub_mp (p, x_g, x_g, pi, gdigs); } (void) sub_mp (p, tmp, x_g, hpi, gdigs); if (MP_DIGIT (tmp, 1) > 0) { // x > pi / 2 (void) sub_mp (p, x_g, pi, x_g, gdigs); } // 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, gdigs)) { m++; (void) div_mp_digit (p, x_g, x_g, (MP_T) 3, gdigs); } // Taylor sum. MP_T *sqr = nil_mp (p, gdigs); MP_T *a68_pow = nil_mp (p, gdigs); MP_T *fac = nil_mp (p, gdigs); MP_T *z_g = nil_mp (p, gdigs); (void) mul_mp (p, sqr, x_g, x_g, gdigs); (void) mul_mp (p, a68_pow, sqr, x_g, gdigs); (void) move_mp (z_g, x_g, gdigs); (void) div_mp_digit (p, tmp, a68_pow, (MP_T) 6, gdigs); (void) sub_mp (p, z_g, z_g, tmp, gdigs); (void) mul_mp (p, a68_pow, a68_pow, sqr, gdigs); (void) div_mp_digit (p, tmp, a68_pow, (MP_T) 120, gdigs); (void) add_mp (p, z_g, z_g, tmp, gdigs); (void) mul_mp (p, a68_pow, a68_pow, sqr, gdigs); (void) div_mp_digit (p, tmp, a68_pow, (MP_T) 5040, gdigs); (void) sub_mp (p, z_g, z_g, tmp, gdigs); (void) mul_mp (p, a68_pow, a68_pow, sqr, gdigs); (void) set_mp (fac, (MP_T) 362880, 0, gdigs); n = 9; even = A68_TRUE; iterate = (BOOL_T) (MP_DIGIT (a68_pow, 1) != 0); while (iterate) { (void) div_mp (p, tmp, a68_pow, fac, gdigs); if (MP_EXPONENT (tmp) <= (MP_EXPONENT (z_g) - gdigs)) { iterate = A68_FALSE; } else { if (even) { (void) add_mp (p, z_g, z_g, tmp, gdigs); even = A68_FALSE; } else { (void) sub_mp (p, z_g, z_g, tmp, gdigs); even = A68_TRUE; } (void) mul_mp (p, a68_pow, a68_pow, sqr, gdigs); (void) mul_mp_digit (p, fac, fac, (MP_T) (++n), gdigs); (void) mul_mp_digit (p, fac, fac, (MP_T) (++n), gdigs); } } // Inverse scaling using sin (3x) = sin (x) * (3 - 4 sin ** 2 (x)). // Use existing mp's for intermediates. (void) set_mp (fac, (MP_T) 3, 0, gdigs); while (m--) { (void) mul_mp (p, a68_pow, z_g, z_g, gdigs); (void) mul_mp_digit (p, a68_pow, a68_pow, (MP_T) 4, gdigs); (void) sub_mp (p, a68_pow, fac, a68_pow, gdigs); (void) mul_mp (p, z_g, a68_pow, z_g, gdigs); } (void) shorten_mp (p, z, digs, z_g, gdigs); if (negative ^ flip) { MP_DIGIT (z, 1) = -MP_DIGIT (z, 1); } // Exit. A68_SP = pop_sp; return z; } //! @brief PROC (LONG REAL) LONG REAL cos MP_T *cos_mp (NODE_T * p, MP_T * z, MP_T * x, int digs) { // Use cos (x) = sin (pi / 2 - x). // Compute x mod 2 pi before subtracting to avoid cancellation. ADDR_T pop_sp = A68_SP; int gdigs = FUN_DIGITS (digs); MP_T *hpi = nil_mp (p, gdigs); MP_T *tpi = nil_mp (p, gdigs); MP_T *x_g = len_mp (p, x, digs, gdigs); MP_T *y = nil_mp (p, digs); (void) mp_pi (p, hpi, MP_HALF_PI, gdigs); (void) mp_pi (p, tpi, MP_TWO_PI, gdigs); (void) mod_mp (p, x_g, x_g, tpi, gdigs); (void) sub_mp (p, x_g, hpi, x_g, gdigs); (void) shorten_mp (p, y, digs, x_g, gdigs); (void) sin_mp (p, z, y, digs); A68_SP = pop_sp; return z; } //! @brief PROC (LONG REAL) LONG REAL tan MP_T *tan_mp (NODE_T * p, MP_T * z, MP_T * x, int digs) { // Use tan (x) = sin (x) / sqrt (1 - sin ^ 2 (x)). ADDR_T pop_sp = A68_SP; int gdigs = FUN_DIGITS (digs); BOOL_T negate; MP_T *pi = nil_mp (p, gdigs); MP_T *hpi = nil_mp (p, gdigs); (void) mp_pi (p, pi, MP_PI, gdigs); (void) mp_pi (p, hpi, MP_HALF_PI, gdigs); MP_T *x_g = len_mp (p, x, digs, gdigs); MP_T *y_g = nil_mp (p, gdigs); MP_T *sns = nil_mp (p, digs); MP_T *cns = nil_mp (p, digs); // Argument mod pi. (void) mod_mp (p, x_g, x_g, pi, gdigs); if (MP_DIGIT (x_g, 1) >= 0) { (void) sub_mp (p, y_g, x_g, hpi, gdigs); negate = (BOOL_T) (MP_DIGIT (y_g, 1) > 0); } else { (void) add_mp (p, y_g, x_g, hpi, gdigs); negate = (BOOL_T) (MP_DIGIT (y_g, 1) < 0); } (void) shorten_mp (p, x, digs, x_g, gdigs); // tan(x) = sin(x) / sqrt (1 - sin ** 2 (x)). (void) sin_mp (p, sns, x, digs); (void) mul_mp (p, cns, sns, sns, digs); (void) one_minus_mp (p, cns, cns, digs); (void) sqrt_mp (p, cns, cns, digs); if (div_mp (p, z, sns, cns, digs) == NaN_MP) { errno = EDOM; A68_SP = pop_sp; return NaN_MP; } A68_SP = pop_sp; if (negate) { MP_DIGIT (z, 1) = -MP_DIGIT (z, 1); } return z; } //! @brief PROC (LONG REAL) LONG REAL arcsin MP_T *asin_mp (NODE_T * p, MP_T * z, MP_T * x, int digs) { ADDR_T pop_sp = A68_SP; int gdigs = FUN_DIGITS (digs); MP_T *y = nil_mp (p, digs); MP_T *x_g = len_mp (p, x, digs, gdigs); MP_T *z_g = nil_mp (p, gdigs); (void) mul_mp (p, z_g, x_g, x_g, gdigs); (void) one_minus_mp (p, z_g, z_g, gdigs); if (sqrt_mp (p, z_g, z_g, digs) == NaN_MP) { errno = EDOM; A68_SP = pop_sp; return NaN_MP; } if (MP_DIGIT (z_g, 1) == 0) { (void) mp_pi (p, z, MP_HALF_PI, digs); MP_DIGIT (z, 1) = (MP_DIGIT (x_g, 1) >= 0 ? MP_DIGIT (z, 1) : -MP_DIGIT (z, 1)); A68_SP = pop_sp; return z; } if (div_mp (p, x_g, x_g, z_g, gdigs) == NaN_MP) { errno = EDOM; A68_SP = pop_sp; return NaN_MP; } (void) shorten_mp (p, y, digs, x_g, gdigs); (void) atan_mp (p, z, y, digs); A68_SP = pop_sp; return z; } //! @brief PROC (LONG REAL) LONG REAL arccos MP_T *acos_mp (NODE_T * p, MP_T * z, MP_T * x, int digs) { ADDR_T pop_sp = A68_SP; int gdigs = FUN_DIGITS (digs); BOOL_T negative = (BOOL_T) (MP_DIGIT (x, 1) < 0); if (MP_DIGIT (x, 1) == 0) { (void) mp_pi (p, z, MP_HALF_PI, digs); A68_SP = pop_sp; return z; } MP_T *y = nil_mp (p, digs); MP_T *x_g = len_mp (p, x, digs, gdigs); MP_T *z_g = nil_mp (p, gdigs); (void) mul_mp (p, z_g, x_g, x_g, gdigs); (void) one_minus_mp (p, z_g, z_g, gdigs); if (sqrt_mp (p, z_g, z_g, digs) == NaN_MP) { errno = EDOM; A68_SP = pop_sp; return NaN_MP; } if (div_mp (p, x_g, z_g, x_g, gdigs) == NaN_MP) { errno = EDOM; A68_SP = pop_sp; return NaN_MP; } (void) shorten_mp (p, y, digs, x_g, gdigs); (void) atan_mp (p, z, y, digs); if (negative) { (void) mp_pi (p, y, MP_PI, digs); (void) add_mp (p, z, z, y, digs); } A68_SP = pop_sp; return z; } //! @brief PROC (LONG REAL) LONG REAL arctan MP_T *atan_mp (NODE_T * p, MP_T * z, MP_T * x, int digs) { // Depending on the argument we choose either Taylor or Newton. ADDR_T pop_sp = A68_SP; if (MP_DIGIT (x, 1) == 0) { A68_SP = pop_sp; SET_MP_ZERO (z, digs); return z; } int gdigs = FUN_DIGITS (digs); MP_T *x_g = len_mp (p, x, digs, gdigs); MP_T *z_g = nil_mp (p, gdigs); BOOL_T 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). BOOL_T 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, gdigs); } 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 int n = 3; BOOL_T iterate, even; MP_T *tmp = nil_mp (p, gdigs); MP_T *a68_pow = nil_mp (p, gdigs); MP_T *sqr = nil_mp (p, gdigs); (void) mul_mp (p, sqr, x_g, x_g, gdigs); (void) mul_mp (p, a68_pow, sqr, x_g, gdigs); (void) move_mp (z_g, x_g, gdigs); even = A68_FALSE; iterate = (BOOL_T) (MP_DIGIT (a68_pow, 1) != 0); while (iterate) { (void) div_mp_digit (p, tmp, a68_pow, (MP_T) n, gdigs); if (MP_EXPONENT (tmp) <= (MP_EXPONENT (z_g) - gdigs)) { iterate = A68_FALSE; } else { if (even) { (void) add_mp (p, z_g, z_g, tmp, gdigs); even = A68_FALSE; } else { (void) sub_mp (p, z_g, z_g, tmp, gdigs); even = A68_TRUE; } (void) mul_mp (p, a68_pow, a68_pow, sqr, gdigs); n += 2; } } } else { // Newton's method: x = x - cos (x) * (sin (x) - a cos (x)). int decimals, hdigs; MP_T *tmp = nil_mp (p, gdigs); MP_T *sns = nil_mp (p, gdigs); MP_T *cns = nil_mp (p, gdigs); // Construct an estimate. #if (A68_LEVEL >= 3) (void) real_16_to_mp (p, z_g, atanq (mp_to_real_16 (p, x_g, gdigs)), gdigs); #else (void) real_to_mp (p, z_g, atan (mp_to_real (p, x_g, gdigs)), gdigs); #endif decimals = DOUBLE_ACCURACY; do { decimals <<= 1; hdigs = MINIMUM (1 + decimals / LOG_MP_RADIX, gdigs); (void) sin_mp (p, sns, z_g, hdigs); (void) mul_mp (p, tmp, sns, sns, hdigs); (void) one_minus_mp (p, tmp, tmp, hdigs); (void) sqrt_mp (p, cns, tmp, hdigs); (void) mul_mp (p, tmp, x_g, cns, hdigs); (void) sub_mp (p, tmp, sns, tmp, hdigs); (void) mul_mp (p, tmp, tmp, cns, hdigs); (void) sub_mp (p, z_g, z_g, tmp, hdigs); } while (decimals < gdigs * LOG_MP_RADIX); } if (flip) { MP_T *hpi = nil_mp (p, gdigs); (void) sub_mp (p, z_g, mp_pi (p, hpi, MP_HALF_PI, gdigs), z_g, gdigs); } (void) shorten_mp (p, z, digs, z_g, gdigs); MP_DIGIT (z, 1) = (negative ? -MP_DIGIT (z, 1) : MP_DIGIT (z, 1)); // Exit. A68_SP = pop_sp; return z; } //! @brief PROC (LONG REAL, LONG REAL) LONG REAL atan2 MP_T *atan2_mp (NODE_T * p, MP_T * z, MP_T * x, MP_T * y, int digs) { ADDR_T pop_sp = A68_SP; MP_T *t = nil_mp (p, digs); if (MP_DIGIT (x, 1) == 0 && MP_DIGIT (y, 1) == 0) { errno = EDOM; A68_SP = pop_sp; return NaN_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, digs); } 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, digs); (void) atan_mp (p, z, z, digs); if (flop) { (void) mp_pi (p, t, MP_PI, digs); (void) sub_mp (p, z, t, z, digs); } } if (flip) { MP_DIGIT (z, 1) = -MP_DIGIT (z, 1); } } A68_SP = pop_sp; return z; } //! @brief PROC (LONG REAL) LONG REAL csc MP_T *csc_mp (NODE_T * p, MP_T * z, MP_T * x, int digs) { sin_mp (p, z, x, digs); if (rec_mp (p, z, z, digs) == NaN_MP) { return NaN_MP; } return z; } //! @brief PROC (LONG REAL) LONG REAL acsc MP_T *acsc_mp (NODE_T * p, MP_T * z, MP_T * x, int digs) { if (rec_mp (p, z, x, digs) == NaN_MP) { return NaN_MP; } return asin_mp (p, z, z, digs); } //! @brief PROC (LONG REAL) LONG REAL sec MP_T *sec_mp (NODE_T * p, MP_T * z, MP_T * x, int digs) { cos_mp (p, z, x, digs); if (rec_mp (p, z, z, digs) == NaN_MP) { return NaN_MP; } return z; } //! @brief PROC (LONG REAL) LONG REAL asec MP_T *asec_mp (NODE_T * p, MP_T * z, MP_T * x, int digs) { if (rec_mp (p, z, x, digs) == NaN_MP) { return NaN_MP; } return acos_mp (p, z, z, digs); } //! @brief PROC (LONG REAL) LONG REAL cot MP_T *cot_mp (NODE_T * p, MP_T * z, MP_T * x, int digs) { // Use tan (x) = sin (x) / sqrt (1 - sin ^ 2 (x)). ADDR_T pop_sp = A68_SP; int gdigs = FUN_DIGITS (digs); BOOL_T negate; MP_T *pi = nil_mp (p, gdigs); MP_T *hpi = nil_mp (p, gdigs); (void) mp_pi (p, pi, MP_PI, gdigs); (void) mp_pi (p, hpi, MP_HALF_PI, gdigs); MP_T *x_g = len_mp (p, x, digs, gdigs); MP_T *y_g = nil_mp (p, gdigs); MP_T *sns = nil_mp (p, digs); MP_T *cns = nil_mp (p, digs); // Argument mod pi. (void) mod_mp (p, x_g, x_g, pi, gdigs); if (MP_DIGIT (x_g, 1) >= 0) { (void) sub_mp (p, y_g, x_g, hpi, gdigs); negate = (BOOL_T) (MP_DIGIT (y_g, 1) > 0); } else { (void) add_mp (p, y_g, x_g, hpi, gdigs); negate = (BOOL_T) (MP_DIGIT (y_g, 1) < 0); } (void) shorten_mp (p, x, digs, x_g, gdigs); // tan(x) = sin(x) / sqrt (1 - sin ** 2 (x)). (void) sin_mp (p, sns, x, digs); (void) mul_mp (p, cns, sns, sns, digs); (void) one_minus_mp (p, cns, cns, digs); (void) sqrt_mp (p, cns, cns, digs); if (div_mp (p, z, cns, sns, digs) == NaN_MP) { errno = EDOM; A68_SP = pop_sp; return NaN_MP; } A68_SP = pop_sp; if (negate) { MP_DIGIT (z, 1) = -MP_DIGIT (z, 1); } return z; } //! @brief PROC (LONG REAL) LONG REAL arccot MP_T *acot_mp (NODE_T * p, MP_T * z, MP_T * x, int digs) { ADDR_T pop_sp = A68_SP; MP_T *f = nil_mp (p, digs); if (rec_mp (p, f, x, digs) == NaN_MP) { errno = EDOM; A68_SP = pop_sp; return NaN_MP; } else { (void) atan_mp (p, z, f, digs); A68_SP = pop_sp; return z; } } //! @brief PROC (LONG REAL) LONG REAL sindg MP_T *sindg_mp (NODE_T * p, MP_T * z, MP_T * x, int digs) { ADDR_T pop_sp = A68_SP; MP_T *f = nil_mp (p, digs); MP_T *g = nil_mp (p, digs); (void) mp_pi (p, f, MP_PI_OVER_180, digs); (void) mul_mp (p, g, x, f, digs); (void) sin_mp (p, z, g, digs); A68_SP = pop_sp; return z; } //! @brief PROC (LONG REAL) LONG REAL cosdg MP_T *cosdg_mp (NODE_T * p, MP_T * z, MP_T * x, int digs) { ADDR_T pop_sp = A68_SP; MP_T *f = nil_mp (p, digs); MP_T *g = nil_mp (p, digs); (void) mp_pi (p, f, MP_PI_OVER_180, digs); (void) mul_mp (p, g, x, f, digs); (void) cos_mp (p, z, g, digs); A68_SP = pop_sp; return z; } //! @brief PROC (LONG REAL) LONG REAL tandg MP_T *tandg_mp (NODE_T * p, MP_T * z, MP_T * x, int digs) { ADDR_T pop_sp = A68_SP; MP_T *f = nil_mp (p, digs); MP_T *g = nil_mp (p, digs); (void) mp_pi (p, f, MP_PI_OVER_180, digs); (void) mul_mp (p, g, x, f, digs); if (tan_mp (p, z, g, digs) == NaN_MP) { errno = EDOM; A68_SP = pop_sp; return NaN_MP; } else { A68_SP = pop_sp; return z; } } //! @brief PROC (LONG REAL) LONG REAL cotdg MP_T *cotdg_mp (NODE_T * p, MP_T * z, MP_T * x, int digs) { ADDR_T pop_sp = A68_SP; MP_T *f = nil_mp (p, digs); MP_T *g = nil_mp (p, digs); (void) mp_pi (p, f, MP_PI_OVER_180, digs); (void) mul_mp (p, g, x, f, digs); if (cot_mp (p, z, g, digs) == NaN_MP) { errno = EDOM; A68_SP = pop_sp; return NaN_MP; } else { A68_SP = pop_sp; return z; } } //! @brief PROC (LONG REAL) LONG REAL arcsindg MP_T *asindg_mp (NODE_T * p, MP_T * z, MP_T * x, int digs) { ADDR_T pop_sp = A68_SP; MP_T *f = nil_mp (p, digs); MP_T *g = nil_mp (p, digs); (void) asin_mp (p, f, x, digs); (void) mp_pi (p, g, MP_180_OVER_PI, digs); (void) mul_mp (p, z, f, g, digs); A68_SP = pop_sp; return z; } //! @brief PROC (LONG REAL) LONG REAL arccosdg MP_T *acosdg_mp (NODE_T * p, MP_T * z, MP_T * x, int digs) { ADDR_T pop_sp = A68_SP; MP_T *f = nil_mp (p, digs); MP_T *g = nil_mp (p, digs); (void) acos_mp (p, f, x, digs); (void) mp_pi (p, g, MP_180_OVER_PI, digs); (void) mul_mp (p, z, f, g, digs); A68_SP = pop_sp; return z; } //! @brief PROC (LONG REAL) LONG REAL arctandg MP_T *atandg_mp (NODE_T * p, MP_T * z, MP_T * x, int digs) { ADDR_T pop_sp = A68_SP; MP_T *f = nil_mp (p, digs); MP_T *g = nil_mp (p, digs); (void) atan_mp (p, f, x, digs); (void) mp_pi (p, g, MP_180_OVER_PI, digs); (void) mul_mp (p, z, f, g, digs); A68_SP = pop_sp; return z; } //! @brief PROC (LONG REAL) LONG REAL arccotdg MP_T *acotdg_mp (NODE_T * p, MP_T * z, MP_T * x, int digs) { ADDR_T pop_sp = A68_SP; MP_T *f = nil_mp (p, digs); MP_T *g = nil_mp (p, digs); if (acot_mp (p, f, x, digs) == NaN_MP) { errno = EDOM; A68_SP = pop_sp; return NaN_MP; } else { (void) mp_pi (p, g, MP_180_OVER_PI, digs); (void) mul_mp (p, z, f, g, digs); A68_SP = pop_sp; return z; } } //! @brief PROC (LONG REAL, LONG REAL) LONG REAL atan2dg MP_T *atan2dg_mp (NODE_T * p, MP_T * z, MP_T * x, MP_T * y, int digs) { ADDR_T pop_sp = A68_SP; MP_T *f = nil_mp (p, digs); MP_T *g = nil_mp (p, digs); if (atan2_mp (p, f, x, y, digs) == NaN_MP) { errno = EDOM; A68_SP = pop_sp; return NaN_MP; } else { (void) mp_pi (p, g, MP_180_OVER_PI, digs); (void) mul_mp (p, z, f, g, digs); A68_SP = pop_sp; return z; } } //! @brief PROC (LONG REAL) LONG REAL sinpi MP_T *sinpi_mp (NODE_T * p, MP_T * z, MP_T * x, int digs) { ADDR_T pop_sp = A68_SP; MP_T *f = nil_mp (p, digs); MP_T *g = lit_mp (p, 1, 0, digs); (void) mod_mp (p, f, x, g, digs); if (IS_ZERO_MP (f)) { SET_MP_ZERO (z, digs); A68_SP = pop_sp; return z; } (void) mp_pi (p, f, MP_PI, digs); (void) mul_mp (p, g, x, f, digs); (void) sin_mp (p, z, g, digs); A68_SP = pop_sp; return z; } //! @brief PROC (LONG REAL) LONG REAL acospi MP_T *cospi_mp (NODE_T * p, MP_T * z, MP_T * x, int digs) { ADDR_T pop_sp = A68_SP; MP_T *f = nil_mp (p, digs); MP_T *g = lit_mp (p, 1, 0, digs); (void) mod_mp (p, f, x, g, digs); abs_mp (p, f, f, digs); SET_MP_HALF (g, digs); (void) sub_mp (p, g, f, g, digs); if (IS_ZERO_MP (g)) { SET_MP_ZERO (z, digs); A68_SP = pop_sp; return z; } (void) mp_pi (p, f, MP_PI, digs); (void) mul_mp (p, g, x, f, digs); (void) cos_mp (p, z, g, digs); A68_SP = pop_sp; return z; } //! @brief PROC (LONG REAL) LONG REAL tanpi MP_T *tanpi_mp (NODE_T * p, MP_T * z, MP_T * x, int digs) { ADDR_T pop_sp = A68_SP; MP_T *f = nil_mp (p, digs); MP_T *g = lit_mp (p, 1, 0, digs); MP_T *h = nil_mp (p, digs); MP_T *half = nil_mp (p, digs); SET_MP_ONE (g, digs); (void) mod_mp (p, f, x, g, digs); if (IS_ZERO_MP (f)) { SET_MP_ZERO (z, digs); A68_SP = pop_sp; return z; } SET_MP_MINUS_HALF (half, digs); (void) sub_mp (p, h, f, half, digs); if (MP_DIGIT (h, 1) < 0) { (void) plus_one_mp (p, f, f, digs); } else { SET_MP_HALF (half, digs); (void) sub_mp (p, h, f, half, digs); if (MP_DIGIT (h, 1) < 0) { (void) minus_one_mp (p, f, f, digs); } } BOOL_T neg = MP_DIGIT (f, 1) < 0; (void) abs_mp (p, f, f, digs); SET_MP_QUART (g, digs); (void) sub_mp (p, g, f, g, digs); if (IS_ZERO_MP (g)) { if (neg) { SET_MP_MINUS_ONE (z, digs); } else { SET_MP_ONE (z, digs); } A68_SP = pop_sp; return z; } (void) mp_pi (p, f, MP_PI, digs); (void) mul_mp (p, g, x, f, digs); if (tan_mp (p, z, g, digs) == NaN_MP) { errno = EDOM; A68_SP = pop_sp; return NaN_MP; } else { A68_SP = pop_sp; return z; } } //! @brief PROC (LONG REAL) LONG REAL cotpi MP_T *cotpi_mp (NODE_T * p, MP_T * z, MP_T * x, int digs) { ADDR_T pop_sp = A68_SP; MP_T *f = nil_mp (p, digs); MP_T *g = lit_mp (p, 1, 0, digs); MP_T *h = nil_mp (p, digs); MP_T *half = nil_mp (p, digs); (void) mod_mp (p, f, x, g, digs); if (IS_ZERO_MP (f)) { errno = EDOM; A68_SP = pop_sp; return NaN_MP; } SET_MP_MINUS_HALF (half, digs); (void) sub_mp (p, h, f, half, digs); if (MP_DIGIT (h, 1) < 0) { (void) plus_one_mp (p, f, f, digs); } else { SET_MP_HALF (half, digs); (void) sub_mp (p, h, f, half, digs); if (MP_DIGIT (h, 1) < 0) { (void) minus_one_mp (p, f, f, digs); } } BOOL_T neg = MP_DIGIT (f, 1) < 0; (void) abs_mp (p, f, f, digs); SET_MP_QUART (g, digs); (void) sub_mp (p, g, f, g, digs); if (IS_ZERO_MP (g)) { if (neg) { SET_MP_MINUS_ONE (z, digs); } else { SET_MP_ONE (z, digs); } A68_SP = pop_sp; return z; } (void) mp_pi (p, f, MP_PI, digs); (void) mul_mp (p, g, x, f, digs); if (cot_mp (p, z, g, digs) == NaN_MP) { errno = EDOM; A68_SP = pop_sp; return NaN_MP; } else { A68_SP = pop_sp; return z; } } //! @brief LONG COMPLEX multiplication MP_T *cmul_mp (NODE_T * p, MP_T * a, MP_T * b, MP_T * c, MP_T * d, int digs) { ADDR_T pop_sp = A68_SP; int gdigs = FUN_DIGITS (digs); MP_T *la = len_mp (p, a, digs, gdigs); MP_T *lb = len_mp (p, b, digs, gdigs); MP_T *lc = len_mp (p, c, digs, gdigs); MP_T *ld = len_mp (p, d, digs, gdigs); MP_T *ac = nil_mp (p, gdigs); MP_T *bd = nil_mp (p, gdigs); MP_T *ad = nil_mp (p, gdigs); MP_T *bc = nil_mp (p, gdigs); (void) mul_mp (p, ac, la, lc, gdigs); (void) mul_mp (p, bd, lb, ld, gdigs); (void) mul_mp (p, ad, la, ld, gdigs); (void) mul_mp (p, bc, lb, lc, gdigs); (void) sub_mp (p, la, ac, bd, gdigs); (void) add_mp (p, lb, ad, bc, gdigs); (void) shorten_mp (p, a, digs, la, gdigs); (void) shorten_mp (p, b, digs, lb, gdigs); A68_SP = pop_sp; return a; } //! @brief LONG COMPLEX division MP_T *cdiv_mp (NODE_T * p, MP_T * a, MP_T * b, MP_T * c, MP_T * d, int digs) { ADDR_T pop_sp = A68_SP; if (MP_DIGIT (c, 1) == (MP_T) 0 && MP_DIGIT (d, 1) == (MP_T) 0) { errno = ERANGE; return NaN_MP; } MP_T *q = nil_mp (p, digs); MP_T *r = nil_mp (p, digs); (void) move_mp (q, c, digs); (void) move_mp (r, d, digs); 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, digs); if (MP_DIGIT (q, 1) >= 0) { if (div_mp (p, q, d, c, digs) == NaN_MP) { errno = ERANGE; return NaN_MP; } (void) mul_mp (p, r, d, q, digs); (void) add_mp (p, r, r, c, digs); (void) mul_mp (p, c, b, q, digs); (void) add_mp (p, c, c, a, digs); (void) div_mp (p, c, c, r, digs); (void) mul_mp (p, d, a, q, digs); (void) sub_mp (p, d, b, d, digs); (void) div_mp (p, d, d, r, digs); } else { if (div_mp (p, q, c, d, digs) == NaN_MP) { errno = ERANGE; return NaN_MP; } (void) mul_mp (p, r, c, q, digs); (void) add_mp (p, r, r, d, digs); (void) mul_mp (p, c, a, q, digs); (void) add_mp (p, c, c, b, digs); (void) div_mp (p, c, c, r, digs); (void) mul_mp (p, d, b, q, digs); (void) sub_mp (p, d, d, a, digs); (void) div_mp (p, d, d, r, digs); } (void) move_mp (a, c, digs); (void) move_mp (b, d, digs); A68_SP = pop_sp; return a; } //! @brief PROC (LONG COMPLEX) LONG COMPLEX csqrt MP_T *csqrt_mp (NODE_T * p, MP_T * r, MP_T * i, int digs) { ADDR_T pop_sp = A68_SP; int gdigs = FUN_DIGITS (digs); MP_T *re = len_mp (p, r, digs, gdigs); MP_T *im = len_mp (p, i, digs, gdigs); if (IS_ZERO_MP (re) && IS_ZERO_MP (im)) { SET_MP_ZERO (re, gdigs); SET_MP_ZERO (im, gdigs); } else { MP_T *c1 = lit_mp (p, 1, 0, gdigs); MP_T *t = nil_mp (p, gdigs); MP_T *x = nil_mp (p, gdigs); MP_T *y = nil_mp (p, gdigs); MP_T *u = nil_mp (p, gdigs); MP_T *v = nil_mp (p, gdigs); MP_T *w = nil_mp (p, gdigs); SET_MP_ONE (c1, gdigs); (void) move_mp (x, re, gdigs); (void) move_mp (y, im, gdigs); 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, gdigs); if (MP_DIGIT (w, 1) >= 0) { (void) div_mp (p, t, y, x, gdigs); (void) mul_mp (p, v, t, t, gdigs); (void) add_mp (p, u, c1, v, gdigs); (void) sqrt_mp (p, v, u, gdigs); (void) add_mp (p, u, c1, v, gdigs); (void) half_mp (p, v, u, gdigs); (void) sqrt_mp (p, u, v, gdigs); (void) sqrt_mp (p, v, x, gdigs); (void) mul_mp (p, w, u, v, gdigs); } else { (void) div_mp (p, t, x, y, gdigs); (void) mul_mp (p, v, t, t, gdigs); (void) add_mp (p, u, c1, v, gdigs); (void) sqrt_mp (p, v, u, gdigs); (void) add_mp (p, u, t, v, gdigs); (void) half_mp (p, v, u, gdigs); (void) sqrt_mp (p, u, v, gdigs); (void) sqrt_mp (p, v, y, gdigs); (void) mul_mp (p, w, u, v, gdigs); } if (MP_DIGIT (re, 1) >= 0) { (void) move_mp (re, w, gdigs); (void) add_mp (p, u, w, w, gdigs); (void) div_mp (p, im, im, u, gdigs); } else { if (MP_DIGIT (im, 1) < 0) { MP_DIGIT (w, 1) = -MP_DIGIT (w, 1); } (void) add_mp (p, v, w, w, gdigs); (void) div_mp (p, re, im, v, gdigs); (void) move_mp (im, w, gdigs); } } (void) shorten_mp (p, r, digs, re, gdigs); (void) shorten_mp (p, i, digs, im, gdigs); A68_SP = pop_sp; return r; } //! @brief PROC (LONG COMPLEX) LONG COMPLEX cexp MP_T *cexp_mp (NODE_T * p, MP_T * r, MP_T * i, int digs) { ADDR_T pop_sp = A68_SP; int gdigs = FUN_DIGITS (digs); MP_T *re = len_mp (p, r, digs, gdigs); MP_T *im = len_mp (p, i, digs, gdigs); MP_T *u = nil_mp (p, gdigs); (void) exp_mp (p, u, re, gdigs); (void) cos_mp (p, re, im, gdigs); (void) sin_mp (p, im, im, gdigs); (void) mul_mp (p, re, re, u, gdigs); (void) mul_mp (p, im, im, u, gdigs); (void) shorten_mp (p, r, digs, re, gdigs); (void) shorten_mp (p, i, digs, im, gdigs); A68_SP = pop_sp; return r; } //! @brief PROC (LONG COMPLEX) LONG COMPLEX cln MP_T *cln_mp (NODE_T * p, MP_T * r, MP_T * i, int digs) { ADDR_T pop_sp = A68_SP; int gdigs = FUN_DIGITS (digs); MP_T *re = len_mp (p, r, digs, gdigs); MP_T *im = len_mp (p, i, digs, gdigs); MP_T *s = nil_mp (p, gdigs); MP_T *t = nil_mp (p, gdigs); MP_T *u = nil_mp (p, gdigs); MP_T *v = nil_mp (p, gdigs); (void) move_mp (u, re, gdigs); (void) move_mp (v, im, gdigs); (void) hypot_mp (p, s, u, v, gdigs); (void) move_mp (u, re, gdigs); (void) move_mp (v, im, gdigs); (void) atan2_mp (p, t, u, v, gdigs); (void) ln_mp (p, re, s, gdigs); (void) move_mp (im, t, gdigs); (void) shorten_mp (p, r, digs, re, gdigs); (void) shorten_mp (p, i, digs, im, gdigs); A68_SP = pop_sp; return r; } //! @brief PROC (LONG COMPLEX) LONG COMPLEX csin MP_T *csin_mp (NODE_T * p, MP_T * r, MP_T * i, int digs) { ADDR_T pop_sp = A68_SP; int gdigs = FUN_DIGITS (digs); MP_T *re = len_mp (p, r, digs, gdigs); MP_T *im = len_mp (p, i, digs, gdigs); MP_T *s = nil_mp (p, gdigs); MP_T *c = nil_mp (p, gdigs); MP_T *sh = nil_mp (p, gdigs); MP_T *ch = nil_mp (p, gdigs); if (IS_ZERO_MP (im)) { (void) sin_mp (p, re, re, gdigs); SET_MP_ZERO (im, gdigs); } else { (void) sin_mp (p, s, re, gdigs); (void) cos_mp (p, c, re, gdigs); (void) hyp_mp (p, sh, ch, im, gdigs); (void) mul_mp (p, re, s, ch, gdigs); (void) mul_mp (p, im, c, sh, gdigs); } (void) shorten_mp (p, r, digs, re, gdigs); (void) shorten_mp (p, i, digs, im, gdigs); A68_SP = pop_sp; return r; } //! @brief PROC (LONG COMPLEX) LONG COMPLEX ccos MP_T *ccos_mp (NODE_T * p, MP_T * r, MP_T * i, int digs) { ADDR_T pop_sp = A68_SP; int gdigs = FUN_DIGITS (digs); MP_T *re = len_mp (p, r, digs, gdigs); MP_T *im = len_mp (p, i, digs, gdigs); MP_T *s = nil_mp (p, gdigs); MP_T *c = nil_mp (p, gdigs); MP_T *sh = nil_mp (p, gdigs); MP_T *ch = nil_mp (p, gdigs); if (IS_ZERO_MP (im)) { (void) cos_mp (p, re, re, gdigs); SET_MP_ZERO (im, gdigs); } else { (void) sin_mp (p, s, re, gdigs); (void) cos_mp (p, c, re, gdigs); (void) hyp_mp (p, sh, ch, im, gdigs); MP_DIGIT (sh, 1) = -MP_DIGIT (sh, 1); (void) mul_mp (p, re, c, ch, gdigs); (void) mul_mp (p, im, s, sh, gdigs); } (void) shorten_mp (p, r, digs, re, gdigs); (void) shorten_mp (p, i, digs, im, gdigs); A68_SP = pop_sp; return r; } //! @brief PROC (LONG COMPLEX) LONG COMPLEX ctan MP_T *ctan_mp (NODE_T * p, MP_T * r, MP_T * i, int digs) { ADDR_T pop_sp = A68_SP; errno = 0; MP_T *s = nil_mp (p, digs); MP_T *t = nil_mp (p, digs); MP_T *u = nil_mp (p, digs); MP_T *v = nil_mp (p, digs); (void) move_mp (u, r, digs); (void) move_mp (v, i, digs); (void) csin_mp (p, u, v, digs); (void) move_mp (s, u, digs); (void) move_mp (t, v, digs); (void) move_mp (u, r, digs); (void) move_mp (v, i, digs); (void) ccos_mp (p, u, v, digs); (void) cdiv_mp (p, s, t, u, v, digs); (void) move_mp (r, s, digs); (void) move_mp (i, t, digs); A68_SP = pop_sp; return r; } //! @brief PROC (LONG COMPLEX) LONG COMPLEX casin MP_T *casin_mp (NODE_T * p, MP_T * r, MP_T * i, int digs) { ADDR_T pop_sp = A68_SP; int gdigs = FUN_DIGITS (digs); MP_T *re = len_mp (p, r, digs, gdigs); MP_T *im = len_mp (p, i, digs, gdigs); if (IS_ZERO_MP (im)) { BOOL_T neg = MP_DIGIT (re, 1) < 0; if (acos_mp (p, im, re, gdigs) == NaN_MP) { errno = 0; // Ignore the acos error MP_DIGIT (re, 1) = ABS (MP_DIGIT (re, 1)); (void) acosh_mp (p, im, re, gdigs); } (void) mp_pi (p, re, MP_HALF_PI, gdigs); if (neg) { MP_DIGIT (re, 1) = -MP_DIGIT (re, 1); } } else { MP_T *c1 = lit_mp (p, 1, 0, gdigs); MP_T *u = nil_mp (p, gdigs); MP_T *v = nil_mp (p, gdigs); MP_T *a = nil_mp (p, gdigs); MP_T *b = nil_mp (p, gdigs); // u=sqrt((r+1)^2+i^2), v=sqrt((r-1)^2+i^2). (void) add_mp (p, a, re, c1, gdigs); (void) sub_mp (p, b, re, c1, gdigs); (void) hypot_mp (p, u, a, im, gdigs); (void) hypot_mp (p, v, b, im, gdigs); // a=(u+v)/2, b=(u-v)/2. (void) add_mp (p, a, u, v, gdigs); (void) half_mp (p, a, a, gdigs); (void) sub_mp (p, b, u, v, gdigs); (void) half_mp (p, b, b, gdigs); // r=asin(b), i=ln(a+sqrt(a^2-1)). (void) mul_mp (p, u, a, a, gdigs); (void) sub_mp (p, u, u, c1, gdigs); (void) sqrt_mp (p, u, u, gdigs); (void) add_mp (p, u, a, u, gdigs); (void) ln_mp (p, im, u, gdigs); (void) asin_mp (p, re, b, gdigs); } (void) shorten_mp (p, r, digs, re, gdigs); (void) shorten_mp (p, i, digs, im, gdigs); A68_SP = pop_sp; return re; } //! @brief PROC (LONG COMPLEX) LONG COMPLEX cacos MP_T *cacos_mp (NODE_T * p, MP_T * r, MP_T * i, int digs) { ADDR_T pop_sp = A68_SP; int gdigs = FUN_DIGITS (digs); MP_T *re = len_mp (p, r, digs, gdigs); MP_T *im = len_mp (p, i, digs, gdigs); if (IS_ZERO_MP (im)) { BOOL_T neg = MP_DIGIT (re, 1) < 0; if (acos_mp (p, im, re, gdigs) == NaN_MP) { errno = 0; // Ignore the acos error MP_DIGIT (re, 1) = ABS (MP_DIGIT (re, 1)); (void) acosh_mp (p, im, re, gdigs); MP_DIGIT (im, 1) = -MP_DIGIT (im, 1); } if (neg) { (void) mp_pi (p, re, MP_PI, gdigs); } else { SET_MP_ZERO (re, gdigs); } } else { MP_T *c1 = lit_mp (p, 1, 0, gdigs); MP_T *u = nil_mp (p, gdigs); MP_T *v = nil_mp (p, gdigs); MP_T *a = nil_mp (p, gdigs); MP_T *b = nil_mp (p, gdigs); // u=sqrt((r+1)^2+i^2), v=sqrt((r-1)^2+i^2). (void) add_mp (p, a, re, c1, gdigs); (void) sub_mp (p, b, re, c1, gdigs); (void) hypot_mp (p, u, a, im, gdigs); (void) hypot_mp (p, v, b, im, gdigs); // a=(u+v)/2, b=(u-v)/2. (void) add_mp (p, a, u, v, gdigs); (void) half_mp (p, a, a, gdigs); (void) sub_mp (p, b, u, v, gdigs); (void) half_mp (p, b, b, gdigs); // r=acos(b), i=-ln(a+sqrt(a^2-1)). (void) mul_mp (p, u, a, a, gdigs); (void) sub_mp (p, u, u, c1, gdigs); (void) sqrt_mp (p, u, u, gdigs); (void) add_mp (p, u, a, u, gdigs); (void) ln_mp (p, im, u, gdigs); MP_DIGIT (im, 1) = -MP_DIGIT (im, 1); (void) acos_mp (p, re, b, gdigs); } (void) shorten_mp (p, r, digs, re, gdigs); (void) shorten_mp (p, i, digs, im, gdigs); A68_SP = pop_sp; return re; } //! @brief PROC (LONG COMPLEX) LONG COMPLEX catan MP_T *catan_mp (NODE_T * p, MP_T * r, MP_T * i, int digs) { ADDR_T pop_sp = A68_SP; int gdigs = FUN_DIGITS (digs); MP_T *re = len_mp (p, r, digs, gdigs); MP_T *im = len_mp (p, i, digs, gdigs); MP_T *u = nil_mp (p, gdigs); MP_T *v = nil_mp (p, gdigs); if (IS_ZERO_MP (im)) { (void) atan_mp (p, u, re, gdigs); SET_MP_ZERO (v, gdigs); } else { MP_T *c1 = lit_mp (p, 1, 0, gdigs); MP_T *a = nil_mp (p, gdigs); MP_T *b = nil_mp (p, gdigs); // a=sqrt(r^2+(i+1)^2), b=sqrt(r^2+(i-1)^2). (void) add_mp (p, a, im, c1, gdigs); (void) sub_mp (p, b, im, c1, gdigs); (void) hypot_mp (p, u, re, a, gdigs); (void) hypot_mp (p, v, re, b, gdigs); // im=ln(a/b)/4. (void) div_mp (p, u, u, v, gdigs); (void) ln_mp (p, u, u, gdigs); (void) half_mp (p, v, u, gdigs); // re=atan(2r/(1-r^2-i^2)). (void) mul_mp (p, a, re, re, gdigs); (void) mul_mp (p, b, im, im, gdigs); (void) sub_mp (p, u, c1, a, gdigs); (void) sub_mp (p, b, u, b, gdigs); (void) add_mp (p, a, re, re, gdigs); (void) div_mp (p, a, a, b, gdigs); (void) atan_mp (p, u, a, gdigs); (void) half_mp (p, u, u, gdigs); } (void) shorten_mp (p, r, digs, u, gdigs); (void) shorten_mp (p, i, digs, v, gdigs); A68_SP = pop_sp; return re; } //! @brief PROC (LONG COMPLEX) LONG COMPLEX csinh MP_T *csinh_mp (NODE_T * p, MP_T * r, MP_T * i, int digs) { ADDR_T pop_sp = A68_SP; int gdigs = FUN_DIGITS (digs); MP_T *u = len_mp (p, r, digs, gdigs); MP_T *v = len_mp (p, i, digs, gdigs); MP_T *s = nil_mp (p, gdigs); MP_T *t = nil_mp (p, gdigs); // sinh (z) = -i sin (iz) SET_MP_ONE (t, gdigs); (void) cmul_mp (p, u, v, s, t, gdigs); (void) csin_mp (p, u, v, gdigs); SET_MP_ZERO (s, gdigs); SET_MP_MINUS_ONE (t, gdigs); (void) cmul_mp (p, u, v, s, t, gdigs); // (void) shorten_mp (p, r, digs, u, gdigs); (void) shorten_mp (p, i, digs, v, gdigs); A68_SP = pop_sp; return r; } //! @brief PROC (LONG COMPLEX) LONG COMPLEX ccosh MP_T *ccosh_mp (NODE_T * p, MP_T * r, MP_T * i, int digs) { ADDR_T pop_sp = A68_SP; int gdigs = FUN_DIGITS (digs); MP_T *u = len_mp (p, r, digs, gdigs); MP_T *v = len_mp (p, i, digs, gdigs); MP_T *s = nil_mp (p, gdigs); MP_T *t = nil_mp (p, gdigs); // cosh (z) = cos (iz) SET_MP_ZERO (s, digs); SET_MP_ONE (t, gdigs); (void) cmul_mp (p, u, v, s, t, gdigs); (void) ccos_mp (p, u, v, gdigs); // (void) shorten_mp (p, r, digs, u, gdigs); (void) shorten_mp (p, i, digs, v, gdigs); A68_SP = pop_sp; return r; } //! @brief PROC (LONG COMPLEX) LONG COMPLEX ctanh MP_T *ctanh_mp (NODE_T * p, MP_T * r, MP_T * i, int digs) { ADDR_T pop_sp = A68_SP; int gdigs = FUN_DIGITS (digs); MP_T *u = len_mp (p, r, digs, gdigs); MP_T *v = len_mp (p, i, digs, gdigs); MP_T *s = nil_mp (p, gdigs); MP_T *t = nil_mp (p, gdigs); // tanh (z) = -i tan (iz) SET_MP_ONE (t, gdigs); (void) cmul_mp (p, u, v, s, t, gdigs); (void) ctan_mp (p, u, v, gdigs); SET_MP_ZERO (u, gdigs); SET_MP_MINUS_ONE (v, gdigs); (void) cmul_mp (p, u, v, s, t, gdigs); // (void) shorten_mp (p, r, digs, u, gdigs); (void) shorten_mp (p, i, digs, v, gdigs); A68_SP = pop_sp; return r; } //! @brief PROC (LONG COMPLEX) LONG COMPLEX casinh MP_T *casinh_mp (NODE_T * p, MP_T * r, MP_T * i, int digs) { ADDR_T pop_sp = A68_SP; int gdigs = FUN_DIGITS (digs); MP_T *u = len_mp (p, r, digs, gdigs); MP_T *v = len_mp (p, i, digs, gdigs); MP_T *s = nil_mp (p, gdigs); MP_T *t = nil_mp (p, gdigs); // asinh (z) = i asin (-iz) SET_MP_MINUS_ONE (t, gdigs); (void) cmul_mp (p, u, v, s, t, gdigs); (void) casin_mp (p, u, v, gdigs); SET_MP_ZERO (s, gdigs); SET_MP_ONE (t, gdigs); (void) cmul_mp (p, u, v, s, t, gdigs); // (void) shorten_mp (p, r, digs, u, gdigs); (void) shorten_mp (p, i, digs, v, gdigs); A68_SP = pop_sp; return r; } //! @brief PROC (LONG COMPLEX) LONG COMPLEX cacosh MP_T *cacosh_mp (NODE_T * p, MP_T * r, MP_T * i, int digs) { ADDR_T pop_sp = A68_SP; int gdigs = FUN_DIGITS (digs); MP_T *u = len_mp (p, r, digs, gdigs); MP_T *v = len_mp (p, i, digs, gdigs); MP_T *s = nil_mp (p, gdigs); MP_T *t = nil_mp (p, gdigs); // acosh (z) = i * acos (z) (void) cacos_mp (p, u, v, gdigs); SET_MP_ONE (t, gdigs); (void) cmul_mp (p, u, v, s, t, gdigs); // (void) shorten_mp (p, r, digs, u, gdigs); (void) shorten_mp (p, i, digs, v, gdigs); A68_SP = pop_sp; return r; } //! @brief PROC (LONG COMPLEX) LONG COMPLEX catanh MP_T *catanh_mp (NODE_T * p, MP_T * r, MP_T * i, int digs) { ADDR_T pop_sp = A68_SP; int gdigs = FUN_DIGITS (digs); MP_T *u = len_mp (p, r, digs, gdigs); MP_T *v = len_mp (p, i, digs, gdigs); MP_T *s = nil_mp (p, gdigs); MP_T *t = nil_mp (p, gdigs); // atanh (z) = i * atan (-iz) SET_MP_MINUS_ONE (t, gdigs); (void) cmul_mp (p, u, v, s, t, gdigs); (void) catan_mp (p, u, v, gdigs); SET_MP_ZERO (s, gdigs); SET_MP_ONE (t, gdigs); (void) cmul_mp (p, u, v, s, t, gdigs); // (void) shorten_mp (p, r, digs, u, gdigs); (void) shorten_mp (p, i, digs, v, gdigs); A68_SP = pop_sp; return r; } algol68g-3.1.2/src/a68g/postgresql.c0000644000175000017500000005604314361065320013774 00000000000000//! @file postgresql.c //! @author J. Marcel van der Veer // //! @section Copyright // // This file is part of Algol68G - an Algol 68 compiler-interpreter. // Copyright 2001-2023 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 . // 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 #include "a68g.h" #include "a68g-prelude.h" #include "a68g-genie.h" #include "a68g-transput.h" #if defined (HAVE_POSTGRESQL) #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 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, M_REF_STRING); POP_REF (p, &conninfo); POP_REF (p, &ref_file); CHECK_REF (p, ref_file, M_REF_FILE); if (IS_IN_HEAP (&ref_file) && !IS_IN_HEAP (&ref_string)) { diagnostic (A68_RUNTIME_ERROR, p, ERROR_SCOPE_DYNAMIC_1, M_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 (A68_RUNTIME_ERROR, p, ERROR_SCOPE_DYNAMIC_1, M_REF_STRING); exit_genie (p, A68_RUNTIME_ERROR); } } // Initialise the file. file = FILE_DEREF (&ref_file); if (OPENED (file)) { diagnostic (A68_RUNTIME_ERROR, p, ERROR_FILE_ALREADY_OPEN); exit_genie (p, A68_RUNTIME_ERROR); } STATUS (file) = INIT_MASK; CHANNEL (file) = A68 (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, M_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 void genie_pq_finish (NODE_T * p) { A68_REF ref_file; A68_FILE *file; POP_REF (p, &ref_file); CHECK_REF (p, ref_file, M_REF_FILE); file = FILE_DEREF (&ref_file); CHECK_INIT (p, INITIALISED (file), M_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 void genie_pq_reset (NODE_T * p) { A68_REF ref_file; A68_FILE *file; POP_REF (p, &ref_file); CHECK_REF (p, ref_file, M_REF_FILE); file = FILE_DEREF (&ref_file); CHECK_INIT (p, INITIALISED (file), M_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 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, M_REF_FILE); file = FILE_DEREF (&ref_file); CHECK_INIT (p, INITIALISED (file), M_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, M_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 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, M_REF_FILE); file = FILE_DEREF (&ref_file); CHECK_INIT (p, INITIALISED (file), M_FILE); if (CONNECTION (file) == NO_PGCONN) { PUSH_PRIMAL (p, -1, INT); return; } ref_z = heap_generator (p, M_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 void genie_pq_cmdstatus (NODE_T * p) { A68_REF ref_file; A68_FILE *file; POP_REF (p, &ref_file); CHECK_REF (p, ref_file, M_REF_FILE); file = FILE_DEREF (&ref_file); CHECK_INIT (p, INITIALISED (file), M_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 void genie_pq_cmdtuples (NODE_T * p) { A68_REF ref_file; A68_FILE *file; POP_REF (p, &ref_file); CHECK_REF (p, ref_file, M_REF_FILE); file = FILE_DEREF (&ref_file); CHECK_INIT (p, INITIALISED (file), M_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 void genie_pq_ntuples (NODE_T * p) { A68_REF ref_file; A68_FILE *file; POP_REF (p, &ref_file); CHECK_REF (p, ref_file, M_REF_FILE); file = FILE_DEREF (&ref_file); CHECK_INIT (p, INITIALISED (file), M_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 void genie_pq_nfields (NODE_T * p) { A68_REF ref_file; A68_FILE *file; POP_REF (p, &ref_file); CHECK_REF (p, ref_file, M_REF_FILE); file = FILE_DEREF (&ref_file); CHECK_INIT (p, INITIALISED (file), M_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 void genie_pq_fname (NODE_T * p) { A68_INT a68_index; int upb; A68_REF ref_file; A68_FILE *file; POP_OBJECT (p, &a68_index, A68_INT); CHECK_INIT (p, INITIALISED (&a68_index), M_INT); POP_REF (p, &ref_file); CHECK_REF (p, ref_file, M_REF_FILE); file = FILE_DEREF (&ref_file); CHECK_INIT (p, INITIALISED (file), M_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 (&a68_index) < 1 || VALUE (&a68_index) > upb) { diagnostic (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 (&a68_index) - 1), DEFAULT_WIDTH); STRPOS (file) = 0; } PUSH_PRIMAL (p, 0, INT); } //! @brief PROC pq fnumber = (REF FILE, STRING) INT 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, M_REF_FILE); file = FILE_DEREF (&ref_file); CHECK_INIT (p, INITIALISED (file), M_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, M_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 void genie_pq_fformat (NODE_T * p) { A68_INT a68_index; int upb; A68_REF ref_file; A68_FILE *file; POP_OBJECT (p, &a68_index, A68_INT); CHECK_INIT (p, INITIALISED (&a68_index), M_INT); POP_REF (p, &ref_file); CHECK_REF (p, ref_file, M_REF_FILE); file = FILE_DEREF (&ref_file); CHECK_INIT (p, INITIALISED (file), M_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 (&a68_index) < 1 || VALUE (&a68_index) > upb) { diagnostic (A68_RUNTIME_ERROR, p, ERROR_INDEX_OUT_OF_BOUNDS); exit_genie (p, A68_RUNTIME_ERROR); } PUSH_PRIMAL (p, PQfformat (RESULT (file), VALUE (&a68_index) - 1), INT); } //! @brief PROC pq getvalue (REF FILE, INT, INT) INT 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), M_INT); POP_OBJECT (p, &row, A68_INT); CHECK_INIT (p, INITIALISED (&row), M_INT); POP_REF (p, &ref_file); CHECK_REF (p, ref_file, M_REF_FILE); file = FILE_DEREF (&ref_file); CHECK_INIT (p, INITIALISED (file), M_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 (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 (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 (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 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), M_INT); POP_OBJECT (p, &row, A68_INT); CHECK_INIT (p, INITIALISED (&row), M_INT); POP_REF (p, &ref_file); CHECK_REF (p, ref_file, M_REF_FILE); file = FILE_DEREF (&ref_file); CHECK_INIT (p, INITIALISED (file), M_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 (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 (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. 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 void genie_pq_errormessage (NODE_T * p) { A68_REF ref_file; A68_FILE *file; POP_REF (p, &ref_file); CHECK_REF (p, ref_file, M_REF_FILE); file = FILE_DEREF (&ref_file); CHECK_INIT (p, INITIALISED (file), M_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 void genie_pq_resulterrormessage (NODE_T * p) { A68_REF ref_file; A68_FILE *file; POP_REF (p, &ref_file); CHECK_REF (p, ref_file, M_REF_FILE); file = FILE_DEREF (&ref_file); CHECK_INIT (p, INITIALISED (file), M_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 void genie_pq_db (NODE_T * p) { A68_REF ref_file; A68_FILE *file; POP_REF (p, &ref_file); CHECK_REF (p, ref_file, M_REF_FILE); file = FILE_DEREF (&ref_file); CHECK_INIT (p, INITIALISED (file), M_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 void genie_pq_user (NODE_T * p) { A68_REF ref_file; A68_FILE *file; POP_REF (p, &ref_file); CHECK_REF (p, ref_file, M_REF_FILE); file = FILE_DEREF (&ref_file); CHECK_INIT (p, INITIALISED (file), M_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 void genie_pq_pass (NODE_T * p) { A68_REF ref_file; A68_FILE *file; POP_REF (p, &ref_file); CHECK_REF (p, ref_file, M_REF_FILE); file = FILE_DEREF (&ref_file); CHECK_INIT (p, INITIALISED (file), M_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 void genie_pq_host (NODE_T * p) { A68_REF ref_file; A68_FILE *file; POP_REF (p, &ref_file); CHECK_REF (p, ref_file, M_REF_FILE); file = FILE_DEREF (&ref_file); CHECK_INIT (p, INITIALISED (file), M_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 void genie_pq_port (NODE_T * p) { A68_REF ref_file; A68_FILE *file; POP_REF (p, &ref_file); CHECK_REF (p, ref_file, M_REF_FILE); file = FILE_DEREF (&ref_file); CHECK_INIT (p, INITIALISED (file), M_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 void genie_pq_tty (NODE_T * p) { A68_REF ref_file; A68_FILE *file; POP_REF (p, &ref_file); CHECK_REF (p, ref_file, M_REF_FILE); file = FILE_DEREF (&ref_file); CHECK_INIT (p, INITIALISED (file), M_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 void genie_pq_options (NODE_T * p) { A68_REF ref_file; A68_FILE *file; POP_REF (p, &ref_file); CHECK_REF (p, ref_file, M_REF_FILE); file = FILE_DEREF (&ref_file); CHECK_INIT (p, INITIALISED (file), M_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 void genie_pq_protocolversion (NODE_T * p) { A68_REF ref_file; A68_FILE *file; POP_REF (p, &ref_file); CHECK_REF (p, ref_file, M_REF_FILE); file = FILE_DEREF (&ref_file); CHECK_INIT (p, INITIALISED (file), M_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 void genie_pq_serverversion (NODE_T * p) { A68_REF ref_file; A68_FILE *file; POP_REF (p, &ref_file); CHECK_REF (p, ref_file, M_REF_FILE); file = FILE_DEREF (&ref_file); CHECK_INIT (p, INITIALISED (file), M_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 void genie_pq_socket (NODE_T * p) { A68_REF ref_file; A68_FILE *file; POP_REF (p, &ref_file); CHECK_REF (p, ref_file, M_REF_FILE); file = FILE_DEREF (&ref_file); CHECK_INIT (p, INITIALISED (file), M_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 void genie_pq_backendpid (NODE_T * p) { A68_REF ref_file; A68_FILE *file; POP_REF (p, &ref_file); CHECK_REF (p, ref_file, M_REF_FILE); file = FILE_DEREF (&ref_file); CHECK_INIT (p, INITIALISED (file), M_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 algol68g-3.1.2/src/a68g/prelude.c0000644000175000017500000037260314361065320013234 00000000000000//! @file prelude.c //! @author J. Marcel van der Veer // //! @section Copyright // // This file is part of Algol68G - an Algol 68 compiler-interpreter. // Copyright 2001-2023 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" #include "a68g-optimiser.h" #include "a68g-prelude.h" #include "a68g-prelude-mathlib.h" #include "a68g-prelude-gsl.h" #include "a68g-transput.h" #include "a68g-mp.h" #include "a68g-parser.h" #include "a68g-physics.h" #include "a68g-double.h" #define A68_STD A68_TRUE #define A68_EXT A68_FALSE //! @brief Standard_environ_proc_name. char *standard_environ_proc_name (GPROC f) { TAG_T *i = IDENTIFIERS (A68_STANDENV); for (; i != NO_TAG; FORWARD (i)) { if (PROCEDURE (i) == f) { return NSYMBOL (NODE (i)); } } return NO_TEXT; } //! @brief Enter tag in standenv symbol table. void add_a68_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) = A68_STANDENV; NODE (new_one) = n; VALUE (new_one) = (c != NO_TEXT ? TEXT (add_token (&A68 (top_token), c)) : NO_TEXT); PRIO (new_one) = p; PROCEDURE (new_one) = q; A68_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 (A68_STANDENV), new_one); } else if (a == OP_SYMBOL) { INSERT_TAG (&OPERATORS (A68_STANDENV), new_one); } else if (a == PRIO_SYMBOL) { INSERT_TAG (&PRIO (A68_STANDENV), new_one); } else if (a == INDICANT) { INSERT_TAG (&INDICANTS (A68_STANDENV), new_one); } else if (a == LABEL) { INSERT_TAG (&LABELS (A68_STANDENV), new_one); } #undef INSERT_TAG } //! @brief Compose PROC moid from arguments - first result, than arguments. MOID_T *a68_proc (MOID_T * m, ...) { MOID_T *y, **z = &TOP_MOID (&A68_JOB); 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. void a68_idf (BOOL_T portable, char *n, MOID_T * m, GPROC * q) { add_a68_standenv (portable, IDENTIFIER, some_node (TEXT (add_token (&A68 (top_token), n))), NO_TEXT, m, 0, q); } //! @brief Enter a moid in standenv. void a68_mode (int p, char *t, MOID_T ** m) { (*m) = add_mode (&TOP_MOID (&A68_JOB), STANDARD, p, some_node (TEXT (find_keyword (A68 (top_keyword), t))), NO_MOID, NO_PACK); } //! @brief Enter a priority in standenv. void a68_prio (char *p, int b) { add_a68_standenv (A68_TRUE, PRIO_SYMBOL, some_node (TEXT (add_token (&A68 (top_token), p))), NO_TEXT, NO_MOID, b, NO_GPROC); } //! @brief Enter operator in standenv. void a68_op (BOOL_T portable, char *n, MOID_T * m, GPROC * q) { add_a68_standenv (portable, OP_SYMBOL, some_node (TEXT (add_token (&A68 (top_token), n))), NO_TEXT, m, 0, q); } //! @brief Enter standard modes in standenv. void stand_moids (void) { MOID_T *m; PACK_T *z; // Primitive A68 moids. a68_mode (0, "VOID", &M_VOID); // Standard precision. a68_mode (0, "INT", &M_INT); a68_mode (0, "REAL", &M_REAL); a68_mode (0, "COMPLEX", &M_COMPLEX); a68_mode (0, "COMPL", &M_COMPL); a68_mode (0, "BITS", &M_BITS); a68_mode (0, "BYTES", &M_BYTES); // Multiple precision. a68_mode (1, "INT", &M_LONG_INT); a68_mode (1, "REAL", &M_LONG_REAL); a68_mode (1, "COMPLEX", &M_LONG_COMPLEX); a68_mode (1, "COMPL", &M_LONG_COMPL); a68_mode (1, "BITS", &M_LONG_BITS); a68_mode (1, "BYTES", &M_LONG_BYTES); a68_mode (2, "REAL", &M_LONG_LONG_REAL); a68_mode (2, "INT", &M_LONG_LONG_INT); a68_mode (2, "COMPLEX", &M_LONG_LONG_COMPLEX); a68_mode (2, "COMPL", &M_LONG_LONG_COMPL); // Other. a68_mode (0, "BOOL", &M_BOOL); a68_mode (0, "CHAR", &M_CHAR); a68_mode (0, "STRING", &M_STRING); a68_mode (0, "FILE", &M_FILE); a68_mode (0, "CHANNEL", &M_CHANNEL); a68_mode (0, "PIPE", &M_PIPE); a68_mode (0, "FORMAT", &M_FORMAT); a68_mode (0, "SEMA", &M_SEMA); a68_mode (0, "SOUND", &M_SOUND); PORTABLE (M_PIPE) = A68_FALSE; HAS_ROWS (M_SOUND) = A68_TRUE; PORTABLE (M_SOUND) = A68_FALSE; // ROWS. M_ROWS = add_mode (&TOP_MOID (&A68_JOB), ROWS_SYMBOL, 0, NO_NODE, NO_MOID, NO_PACK); // REFs. M_REF_INT = add_mode (&TOP_MOID (&A68_JOB), REF_SYMBOL, 0, NO_NODE, M_INT, NO_PACK); M_REF_REAL = add_mode (&TOP_MOID (&A68_JOB), REF_SYMBOL, 0, NO_NODE, M_REAL, NO_PACK); M_REF_COMPLEX = M_REF_COMPL = add_mode (&TOP_MOID (&A68_JOB), REF_SYMBOL, 0, NO_NODE, M_COMPLEX, NO_PACK); M_REF_BITS = add_mode (&TOP_MOID (&A68_JOB), REF_SYMBOL, 0, NO_NODE, M_BITS, NO_PACK); M_REF_BYTES = add_mode (&TOP_MOID (&A68_JOB), REF_SYMBOL, 0, NO_NODE, M_BYTES, NO_PACK); M_REF_FORMAT = add_mode (&TOP_MOID (&A68_JOB), REF_SYMBOL, 0, NO_NODE, M_FORMAT, NO_PACK); M_REF_PIPE = add_mode (&TOP_MOID (&A68_JOB), REF_SYMBOL, 0, NO_NODE, M_PIPE, NO_PACK); // Multiple precision. M_REF_LONG_INT = add_mode (&TOP_MOID (&A68_JOB), REF_SYMBOL, 0, NO_NODE, M_LONG_INT, NO_PACK); M_REF_LONG_REAL = add_mode (&TOP_MOID (&A68_JOB), REF_SYMBOL, 0, NO_NODE, M_LONG_REAL, NO_PACK); M_REF_LONG_COMPLEX = M_REF_LONG_COMPL = add_mode (&TOP_MOID (&A68_JOB), REF_SYMBOL, 0, NO_NODE, M_LONG_COMPLEX, NO_PACK); M_REF_LONG_LONG_INT = add_mode (&TOP_MOID (&A68_JOB), REF_SYMBOL, 0, NO_NODE, M_LONG_LONG_INT, NO_PACK); M_REF_LONG_LONG_REAL = add_mode (&TOP_MOID (&A68_JOB), REF_SYMBOL, 0, NO_NODE, M_LONG_LONG_REAL, NO_PACK); M_REF_LONG_LONG_COMPLEX = M_REF_LONG_LONG_COMPL = add_mode (&TOP_MOID (&A68_JOB), REF_SYMBOL, 0, NO_NODE, M_LONG_LONG_COMPLEX, NO_PACK); M_REF_LONG_BITS = add_mode (&TOP_MOID (&A68_JOB), REF_SYMBOL, 0, NO_NODE, M_LONG_BITS, NO_PACK); M_REF_LONG_BYTES = add_mode (&TOP_MOID (&A68_JOB), REF_SYMBOL, 0, NO_NODE, M_LONG_BYTES, NO_PACK); // Other. M_REF_BOOL = add_mode (&TOP_MOID (&A68_JOB), REF_SYMBOL, 0, NO_NODE, M_BOOL, NO_PACK); M_REF_CHAR = add_mode (&TOP_MOID (&A68_JOB), REF_SYMBOL, 0, NO_NODE, M_CHAR, NO_PACK); M_REF_FILE = add_mode (&TOP_MOID (&A68_JOB), REF_SYMBOL, 0, NO_NODE, M_FILE, NO_PACK); M_REF_REF_FILE = add_mode (&TOP_MOID (&A68_JOB), REF_SYMBOL, 0, NO_NODE, M_REF_FILE, NO_PACK); M_REF_SOUND = add_mode (&TOP_MOID (&A68_JOB), REF_SYMBOL, 0, NO_NODE, M_SOUND, NO_PACK); // [] INT. M_ROW_INT = add_mode (&TOP_MOID (&A68_JOB), ROW_SYMBOL, 1, NO_NODE, M_INT, NO_PACK); HAS_ROWS (M_ROW_INT) = A68_TRUE; SLICE (M_ROW_INT) = M_INT; M_REF_ROW_INT = add_mode (&TOP_MOID (&A68_JOB), REF_SYMBOL, 0, NO_NODE, M_ROW_INT, NO_PACK); NAME (M_REF_ROW_INT) = M_REF_INT; // [] REAL. M_ROW_REAL = add_mode (&TOP_MOID (&A68_JOB), ROW_SYMBOL, 1, NO_NODE, M_REAL, NO_PACK); HAS_ROWS (M_ROW_REAL) = A68_TRUE; SLICE (M_ROW_REAL) = M_REAL; M_REF_ROW_REAL = add_mode (&TOP_MOID (&A68_JOB), REF_SYMBOL, 0, NO_NODE, M_ROW_REAL, NO_PACK); NAME (M_REF_ROW_REAL) = M_REF_REAL; // [,] REAL. M_ROW_ROW_REAL = add_mode (&TOP_MOID (&A68_JOB), ROW_SYMBOL, 2, NO_NODE, M_REAL, NO_PACK); HAS_ROWS (M_ROW_ROW_REAL) = A68_TRUE; SLICE (M_ROW_ROW_REAL) = M_ROW_REAL; M_REF_ROW_ROW_REAL = add_mode (&TOP_MOID (&A68_JOB), REF_SYMBOL, 0, NO_NODE, M_ROW_ROW_REAL, NO_PACK); NAME (M_REF_ROW_ROW_REAL) = M_REF_ROW_REAL; // [] COMPLEX. M_ROW_COMPLEX = add_mode (&TOP_MOID (&A68_JOB), ROW_SYMBOL, 1, NO_NODE, M_COMPLEX, NO_PACK); HAS_ROWS (M_ROW_COMPLEX) = A68_TRUE; SLICE (M_ROW_COMPLEX) = M_COMPLEX; M_REF_ROW_COMPLEX = add_mode (&TOP_MOID (&A68_JOB), REF_SYMBOL, 0, NO_NODE, M_ROW_COMPLEX, NO_PACK); NAME (M_REF_ROW_COMPLEX) = M_REF_COMPLEX; // [,] COMPLEX. M_ROW_ROW_COMPLEX = add_mode (&TOP_MOID (&A68_JOB), ROW_SYMBOL, 2, NO_NODE, M_COMPLEX, NO_PACK); HAS_ROWS (M_ROW_ROW_COMPLEX) = A68_TRUE; SLICE (M_ROW_ROW_COMPLEX) = M_ROW_COMPLEX; M_REF_ROW_ROW_COMPLEX = add_mode (&TOP_MOID (&A68_JOB), REF_SYMBOL, 0, NO_NODE, M_ROW_ROW_COMPLEX, NO_PACK); NAME (M_REF_ROW_ROW_COMPLEX) = M_REF_ROW_COMPLEX; // [] BOOL. M_ROW_BOOL = add_mode (&TOP_MOID (&A68_JOB), ROW_SYMBOL, 1, NO_NODE, M_BOOL, NO_PACK); HAS_ROWS (M_ROW_BOOL) = A68_TRUE; SLICE (M_ROW_BOOL) = M_BOOL; // FLEX [] BOOL. m = add_mode (&TOP_MOID (&A68_JOB), FLEX_SYMBOL, 0, NO_NODE, M_ROW_BOOL, NO_PACK); HAS_ROWS (m) = A68_TRUE; M_FLEX_ROW_BOOL = m; // [] BITS. M_ROW_BITS = add_mode (&TOP_MOID (&A68_JOB), ROW_SYMBOL, 1, NO_NODE, M_BITS, NO_PACK); HAS_ROWS (M_ROW_BITS) = A68_TRUE; SLICE (M_ROW_BITS) = M_BITS; // [] LONG BITS. M_ROW_LONG_BITS = add_mode (&TOP_MOID (&A68_JOB), ROW_SYMBOL, 1, NO_NODE, M_LONG_BITS, NO_PACK); HAS_ROWS (M_ROW_LONG_BITS) = A68_TRUE; SLICE (M_ROW_LONG_BITS) = M_LONG_BITS; // [] CHAR. M_ROW_CHAR = add_mode (&TOP_MOID (&A68_JOB), ROW_SYMBOL, 1, NO_NODE, M_CHAR, NO_PACK); HAS_ROWS (M_ROW_CHAR) = A68_TRUE; SLICE (M_ROW_CHAR) = M_CHAR; // [][] CHAR. M_ROW_ROW_CHAR = add_mode (&TOP_MOID (&A68_JOB), ROW_SYMBOL, 1, NO_NODE, M_ROW_CHAR, NO_PACK); HAS_ROWS (M_ROW_ROW_CHAR) = A68_TRUE; SLICE (M_ROW_ROW_CHAR) = M_ROW_CHAR; // MODE STRING = FLEX [] CHAR. m = add_mode (&TOP_MOID (&A68_JOB), FLEX_SYMBOL, 0, NO_NODE, M_ROW_CHAR, NO_PACK); HAS_ROWS (m) = A68_TRUE; M_FLEX_ROW_CHAR = m; EQUIVALENT (M_STRING) = m; // REF [] CHAR. M_REF_ROW_CHAR = add_mode (&TOP_MOID (&A68_JOB), REF_SYMBOL, 0, NO_NODE, M_ROW_CHAR, NO_PACK); NAME (M_REF_ROW_CHAR) = M_REF_CHAR; // PROC [] CHAR. M_PROC_ROW_CHAR = add_mode (&TOP_MOID (&A68_JOB), PROC_SYMBOL, 0, NO_NODE, M_ROW_CHAR, NO_PACK); // REF STRING = REF FLEX [] CHAR. M_REF_STRING = add_mode (&TOP_MOID (&A68_JOB), REF_SYMBOL, 0, NO_NODE, EQUIVALENT (M_STRING), NO_PACK); NAME (M_REF_STRING) = M_REF_CHAR; DEFLEXED (M_REF_STRING) = M_REF_ROW_CHAR; // [] STRING. M_ROW_STRING = add_mode (&TOP_MOID (&A68_JOB), ROW_SYMBOL, 1, NO_NODE, M_STRING, NO_PACK); HAS_ROWS (M_ROW_STRING) = A68_TRUE; SLICE (M_ROW_STRING) = M_STRING; DEFLEXED (M_ROW_STRING) = M_ROW_ROW_CHAR; // PROC STRING. M_PROC_STRING = add_mode (&TOP_MOID (&A68_JOB), PROC_SYMBOL, 0, NO_NODE, M_STRING, NO_PACK); DEFLEXED (M_PROC_STRING) = M_PROC_ROW_CHAR; // COMPLEX. z = NO_PACK; (void) add_mode_to_pack (&z, M_REAL, TEXT (add_token (&A68 (top_token), "im")), NO_NODE); (void) add_mode_to_pack (&z, M_REAL, TEXT (add_token (&A68 (top_token), "re")), NO_NODE); m = add_mode (&TOP_MOID (&A68_JOB), STRUCT_SYMBOL, count_pack_members (z), NO_NODE, NO_MOID, z); EQUIVALENT (M_COMPLEX) = EQUIVALENT (M_COMPL) = m; z = NO_PACK; (void) add_mode_to_pack (&z, M_REF_REAL, TEXT (add_token (&A68 (top_token), "im")), NO_NODE); (void) add_mode_to_pack (&z, M_REF_REAL, TEXT (add_token (&A68 (top_token), "re")), NO_NODE); m = add_mode (&TOP_MOID (&A68_JOB), STRUCT_SYMBOL, count_pack_members (z), NO_NODE, NO_MOID, z); NAME (M_REF_COMPLEX) = NAME (M_REF_COMPL) = m; // LONG COMPLEX. z = NO_PACK; (void) add_mode_to_pack (&z, M_LONG_REAL, TEXT (add_token (&A68 (top_token), "im")), NO_NODE); (void) add_mode_to_pack (&z, M_LONG_REAL, TEXT (add_token (&A68 (top_token), "re")), NO_NODE); m = add_mode (&TOP_MOID (&A68_JOB), STRUCT_SYMBOL, count_pack_members (z), NO_NODE, NO_MOID, z); EQUIVALENT (M_LONG_COMPLEX) = EQUIVALENT (M_LONG_COMPL) = m; z = NO_PACK; (void) add_mode_to_pack (&z, M_REF_LONG_REAL, TEXT (add_token (&A68 (top_token), "im")), NO_NODE); (void) add_mode_to_pack (&z, M_REF_LONG_REAL, TEXT (add_token (&A68 (top_token), "re")), NO_NODE); m = add_mode (&TOP_MOID (&A68_JOB), STRUCT_SYMBOL, count_pack_members (z), NO_NODE, NO_MOID, z); NAME (M_REF_LONG_COMPLEX) = NAME (M_REF_LONG_COMPL) = m; // LONG_LONG COMPLEX. z = NO_PACK; (void) add_mode_to_pack (&z, M_LONG_LONG_REAL, TEXT (add_token (&A68 (top_token), "im")), NO_NODE); (void) add_mode_to_pack (&z, M_LONG_LONG_REAL, TEXT (add_token (&A68 (top_token), "re")), NO_NODE); m = add_mode (&TOP_MOID (&A68_JOB), STRUCT_SYMBOL, count_pack_members (z), NO_NODE, NO_MOID, z); EQUIVALENT (M_LONG_LONG_COMPLEX) = EQUIVALENT (M_LONG_LONG_COMPL) = m; z = NO_PACK; (void) add_mode_to_pack (&z, M_REF_LONG_LONG_REAL, TEXT (add_token (&A68 (top_token), "im")), NO_NODE); (void) add_mode_to_pack (&z, M_REF_LONG_LONG_REAL, TEXT (add_token (&A68 (top_token), "re")), NO_NODE); m = add_mode (&TOP_MOID (&A68_JOB), STRUCT_SYMBOL, count_pack_members (z), NO_NODE, NO_MOID, z); NAME (M_REF_LONG_LONG_COMPLEX) = NAME (M_REF_LONG_LONG_COMPL) = m; // NUMBER. z = NO_PACK; (void) add_mode_to_pack (&z, M_INT, NO_TEXT, NO_NODE); (void) add_mode_to_pack (&z, M_LONG_INT, NO_TEXT, NO_NODE); (void) add_mode_to_pack (&z, M_LONG_LONG_INT, NO_TEXT, NO_NODE); (void) add_mode_to_pack (&z, M_REAL, NO_TEXT, NO_NODE); (void) add_mode_to_pack (&z, M_LONG_REAL, NO_TEXT, NO_NODE); (void) add_mode_to_pack (&z, M_LONG_LONG_REAL, NO_TEXT, NO_NODE); M_NUMBER = add_mode (&TOP_MOID (&A68_JOB), UNION_SYMBOL, count_pack_members (z), NO_NODE, NO_MOID, z); // HEX_NUMBER. z = NO_PACK; (void) add_mode_to_pack (&z, M_BOOL, NO_TEXT, NO_NODE); (void) add_mode_to_pack (&z, M_CHAR, NO_TEXT, NO_NODE); (void) add_mode_to_pack (&z, M_INT, NO_TEXT, NO_NODE); (void) add_mode_to_pack (&z, M_LONG_INT, NO_TEXT, NO_NODE); (void) add_mode_to_pack (&z, M_REAL, NO_TEXT, NO_NODE); (void) add_mode_to_pack (&z, M_LONG_REAL, NO_TEXT, NO_NODE); (void) add_mode_to_pack (&z, M_BITS, NO_TEXT, NO_NODE); (void) add_mode_to_pack (&z, M_LONG_BITS, NO_TEXT, NO_NODE); M_HEX_NUMBER = add_mode (&TOP_MOID (&A68_JOB), UNION_SYMBOL, count_pack_members (z), NO_NODE, NO_MOID, z); // SEMA. z = NO_PACK; (void) add_mode_to_pack (&z, M_REF_INT, NO_TEXT, NO_NODE); EQUIVALENT (M_SEMA) = add_mode (&TOP_MOID (&A68_JOB), STRUCT_SYMBOL, count_pack_members (z), NO_NODE, NO_MOID, z); // PROC VOID. z = NO_PACK; M_PROC_VOID = add_mode (&TOP_MOID (&A68_JOB), PROC_SYMBOL, count_pack_members (z), NO_NODE, M_VOID, z); // PROC (REAL) REAL. z = NO_PACK; (void) add_mode_to_pack (&z, M_REAL, NO_TEXT, NO_NODE); M_PROC_REAL_REAL = add_mode (&TOP_MOID (&A68_JOB), PROC_SYMBOL, count_pack_members (z), NO_NODE, M_REAL, z); // PROC (LONG_REAL) LONG_REAL. z = NO_PACK; (void) add_mode_to_pack (&z, M_LONG_REAL, NO_TEXT, NO_NODE); M_PROC_LONG_REAL_LONG_REAL = add_mode (&TOP_MOID (&A68_JOB), PROC_SYMBOL, count_pack_members (z), NO_NODE, M_LONG_REAL, z); // IO: PROC (REF FILE) BOOL. z = NO_PACK; (void) add_mode_to_pack (&z, M_REF_FILE, NO_TEXT, NO_NODE); M_PROC_REF_FILE_BOOL = add_mode (&TOP_MOID (&A68_JOB), PROC_SYMBOL, count_pack_members (z), NO_NODE, M_BOOL, z); // IO: PROC (REF FILE) VOID. z = NO_PACK; (void) add_mode_to_pack (&z, M_REF_FILE, NO_TEXT, NO_NODE); M_PROC_REF_FILE_VOID = add_mode (&TOP_MOID (&A68_JOB), PROC_SYMBOL, count_pack_members (z), NO_NODE, M_VOID, z); // IO: SIMPLIN and SIMPLOUT. M_SIMPLIN = add_mode (&TOP_MOID (&A68_JOB), IN_TYPE_MODE, 0, NO_NODE, NO_MOID, NO_PACK); M_ROW_SIMPLIN = add_mode (&TOP_MOID (&A68_JOB), ROW_SYMBOL, 1, NO_NODE, M_SIMPLIN, NO_PACK); SLICE (M_ROW_SIMPLIN) = M_SIMPLIN; M_SIMPLOUT = add_mode (&TOP_MOID (&A68_JOB), OUT_TYPE_MODE, 0, NO_NODE, NO_MOID, NO_PACK); M_ROW_SIMPLOUT = add_mode (&TOP_MOID (&A68_JOB), ROW_SYMBOL, 1, NO_NODE, M_SIMPLOUT, NO_PACK); SLICE (M_ROW_SIMPLOUT) = M_SIMPLOUT; // PIPE. z = NO_PACK; (void) add_mode_to_pack (&z, M_INT, TEXT (add_token (&A68 (top_token), "pid")), NO_NODE); (void) add_mode_to_pack (&z, M_REF_FILE, TEXT (add_token (&A68 (top_token), "write")), NO_NODE); (void) add_mode_to_pack (&z, M_REF_FILE, TEXT (add_token (&A68 (top_token), "read")), NO_NODE); EQUIVALENT (M_PIPE) = add_mode (&TOP_MOID (&A68_JOB), STRUCT_SYMBOL, count_pack_members (z), NO_NODE, NO_MOID, z); z = NO_PACK; (void) add_mode_to_pack (&z, M_REF_INT, TEXT (add_token (&A68 (top_token), "pid")), NO_NODE); (void) add_mode_to_pack (&z, M_REF_REF_FILE, TEXT (add_token (&A68 (top_token), "write")), NO_NODE); (void) add_mode_to_pack (&z, M_REF_REF_FILE, TEXT (add_token (&A68 (top_token), "read")), NO_NODE); NAME (M_REF_PIPE) = add_mode (&TOP_MOID (&A68_JOB), STRUCT_SYMBOL, count_pack_members (z), NO_NODE, NO_MOID, z); } //! @brief Set up standenv - general RR but not transput. void stand_prelude (void) { MOID_T *m; // Identifiers. a68_idf (A68_STD, "intlengths", M_INT, genie_int_lengths); a68_idf (A68_STD, "intshorths", M_INT, genie_int_shorths); a68_idf (A68_STD, "infinity", M_REAL, genie_infinity_real); a68_idf (A68_STD, "minusinfinity", M_REAL, genie_minus_infinity_real); a68_idf (A68_STD, "inf", M_REAL, genie_infinity_real); a68_idf (A68_STD, "mininf", M_REAL, genie_minus_infinity_real); a68_idf (A68_STD, "maxint", M_INT, genie_max_int); a68_idf (A68_STD, "mpradix", M_INT, genie_mp_radix); a68_idf (A68_STD, "maxreal", M_REAL, genie_max_real); a68_idf (A68_STD, "minreal", M_REAL, genie_min_real); a68_idf (A68_STD, "smallreal", M_REAL, genie_small_real); a68_idf (A68_STD, "reallengths", M_INT, genie_real_lengths); a68_idf (A68_STD, "realshorths", M_INT, genie_real_shorths); a68_idf (A68_STD, "compllengths", M_INT, genie_complex_lengths); a68_idf (A68_STD, "complshorths", M_INT, genie_complex_shorths); a68_idf (A68_STD, "bitslengths", M_INT, genie_bits_lengths); a68_idf (A68_STD, "bitsshorths", M_INT, genie_bits_shorths); a68_idf (A68_STD, "bitswidth", M_INT, genie_bits_width); a68_idf (A68_STD, "longbitswidth", M_INT, genie_long_bits_width); a68_idf (A68_STD, "maxbits", M_BITS, genie_max_bits); a68_idf (A68_STD, "byteslengths", M_INT, genie_bytes_lengths); a68_idf (A68_STD, "bytesshorths", M_INT, genie_bytes_shorths); a68_idf (A68_STD, "byteswidth", M_INT, genie_bytes_width); a68_idf (A68_STD, "maxabschar", M_INT, genie_max_abs_char); a68_idf (A68_STD, "pi", M_REAL, genie_pi); a68_idf (A68_STD, "qpi", M_LONG_LONG_REAL, genie_pi_mp); a68_idf (A68_STD, "longlongpi", M_LONG_LONG_REAL, genie_pi_mp); a68_idf (A68_STD, "intwidth", M_INT, genie_int_width); a68_idf (A68_STD, "realwidth", M_INT, genie_real_width); a68_idf (A68_STD, "expwidth", M_INT, genie_exp_width); a68_idf (A68_STD, "longintwidth", M_INT, genie_long_int_width); a68_idf (A68_STD, "longlongintwidth", M_INT, genie_long_mp_int_width); a68_idf (A68_STD, "longrealwidth", M_INT, genie_long_real_width); a68_idf (A68_STD, "longlongrealwidth", M_INT, genie_long_mp_real_width); a68_idf (A68_STD, "longexpwidth", M_INT, genie_long_exp_width); a68_idf (A68_STD, "longlongexpwidth", M_INT, genie_long_mp_exp_width); a68_idf (A68_STD, "longlongmaxint", M_LONG_LONG_INT, genie_long_mp_max_int); a68_idf (A68_STD, "longlongsmallreal", M_LONG_LONG_REAL, genie_long_mp_small_real); a68_idf (A68_STD, "longlongmaxreal", M_LONG_LONG_REAL, genie_long_mp_max_real); a68_idf (A68_STD, "longlongminreal", M_LONG_LONG_REAL, genie_long_mp_min_real); a68_idf (A68_STD, "longlonginfinity", M_LONG_LONG_REAL, genie_infinity_mp); a68_idf (A68_STD, "longlongminusinfinity", M_LONG_LONG_REAL, genie_minus_infinity_mp); a68_idf (A68_STD, "longlonginf", M_LONG_LONG_REAL, genie_infinity_mp); a68_idf (A68_STD, "longlongmininf", M_LONG_LONG_REAL, genie_minus_infinity_mp); a68_idf (A68_STD, "longbyteswidth", M_INT, genie_long_bytes_width); a68_idf (A68_EXT, "seconds", M_REAL, genie_cputime); a68_idf (A68_EXT, "clock", M_REAL, genie_cputime); a68_idf (A68_EXT, "cputime", M_REAL, genie_cputime); m = a68_proc (M_VOID, A68_MCACHE (proc_void), NO_MOID); a68_idf (A68_EXT, "ongcevent", m, genie_on_gc_event); a68_idf (A68_EXT, "collections", A68_MCACHE (proc_int), genie_garbage_collections); a68_idf (A68_EXT, "garbagecollections", A68_MCACHE (proc_int), genie_garbage_collections); a68_idf (A68_EXT, "garbagerefused", A68_MCACHE (proc_int), genie_garbage_refused); a68_idf (A68_EXT, "blocks", A68_MCACHE (proc_int), genie_block); a68_idf (A68_EXT, "garbage", A68_MCACHE (proc_int), genie_garbage_freed); a68_idf (A68_EXT, "garbagefreed", A68_MCACHE (proc_int), genie_garbage_freed); a68_idf (A68_EXT, "collectseconds", A68_MCACHE (proc_real), genie_garbage_seconds); a68_idf (A68_EXT, "garbageseconds", A68_MCACHE (proc_real), genie_garbage_seconds); a68_idf (A68_EXT, "stackpointer", M_INT, genie_stack_pointer); a68_idf (A68_EXT, "systemstackpointer", M_INT, genie_system_stack_pointer); a68_idf (A68_EXT, "systemstacksize", M_INT, genie_system_stack_size); a68_idf (A68_EXT, "actualstacksize", M_INT, genie_stack_pointer); a68_idf (A68_EXT, "heappointer", M_INT, genie_system_heap_pointer); a68_idf (A68_EXT, "systemheappointer", M_INT, genie_system_heap_pointer); a68_idf (A68_EXT, "gcheap", A68_MCACHE (proc_void), genie_gc_heap); a68_idf (A68_EXT, "sweepheap", A68_MCACHE (proc_void), genie_gc_heap); a68_idf (A68_EXT, "preemptivegc", A68_MCACHE (proc_void), genie_preemptive_gc_heap); a68_idf (A68_EXT, "preemptivesweep", A68_MCACHE (proc_void), genie_preemptive_gc_heap); a68_idf (A68_EXT, "preemptivesweepheap", A68_MCACHE (proc_void), genie_preemptive_gc_heap); a68_idf (A68_EXT, "backtrace", A68_MCACHE (proc_void), genie_backtrace); a68_idf (A68_EXT, "break", A68_MCACHE (proc_void), genie_break); a68_idf (A68_EXT, "debug", A68_MCACHE (proc_void), genie_debug); a68_idf (A68_EXT, "monitor", A68_MCACHE (proc_void), genie_debug); m = a68_proc (M_VOID, M_STRING, NO_MOID); a68_idf (A68_EXT, "abend", m, genie_abend); m = a68_proc (M_STRING, M_STRING, NO_MOID); a68_idf (A68_EXT, "evaluate", m, genie_evaluate); m = a68_proc (M_INT, M_STRING, NO_MOID); a68_idf (A68_EXT, "system", m, genie_system); m = a68_proc (M_INT, M_INT, NO_MOID); a68_idf (A68_EXT, "sleep", m, genie_sleep); // BITS procedures. m = a68_proc (M_BITS, M_ROW_BOOL, NO_MOID); a68_idf (A68_STD, "bitspack", m, genie_bits_pack); // RNG procedures. m = a68_proc (M_VOID, M_INT, NO_MOID); a68_idf (A68_STD, "firstrandom", m, genie_first_random); m = A68_MCACHE (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 (M_LONG_LONG_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 ("ROL", 8); a68_prio ("ROR", 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 (M_INT, M_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 (M_BOOL, M_INT, NO_MOID); a68_op (A68_STD, "ODD", m, genie_odd_int); m = a68_proc (M_BOOL, M_INT, M_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 (M_INT, M_INT, M_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 (M_REAL, M_INT, M_INT, NO_MOID); a68_op (A68_STD, "/", m, genie_div_int); m = a68_proc (M_REF_INT, M_REF_INT, M_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); a68_idf (A68_EXT, "fact", A68_MCACHE (proc_int_real), genie_fact_real); a68_idf (A68_EXT, "lnfact", A68_MCACHE (proc_int_real), genie_ln_fact_real); a68_idf (A68_EXT, "choose", A68_MCACHE (proc_int_int_real), genie_choose_real); a68_idf (A68_EXT, "lnchoose", A68_MCACHE (proc_int_int_real), genie_ln_choose_real); // REAL ops. m = A68_MCACHE (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 (M_INT, M_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 (M_BOOL, M_REAL, M_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 = A68_MCACHE (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 (M_REAL, M_REAL, M_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 (M_REF_REAL, M_REF_REAL, M_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); // Procedures a68_idf (A68_EXT, "acos", A68_MCACHE (proc_real_real), genie_acos_real); a68_idf (A68_EXT, "acosdg", A68_MCACHE (proc_real_real), genie_acosdg_real); a68_idf (A68_EXT, "acosh", A68_MCACHE (proc_real_real), genie_acosh_real); a68_idf (A68_EXT, "acot", A68_MCACHE (proc_real_real), genie_acot_real); a68_idf (A68_EXT, "acotdg", A68_MCACHE (proc_real_real), genie_acotdg_real); a68_idf (A68_EXT, "acsc", A68_MCACHE (proc_real_real), genie_acsc_real); a68_idf (A68_EXT, "arccosdg", A68_MCACHE (proc_real_real), genie_acosdg_real); a68_idf (A68_EXT, "arccosh", A68_MCACHE (proc_real_real), genie_acosh_real); a68_idf (A68_EXT, "arccot", A68_MCACHE (proc_real_real), genie_acot_real); a68_idf (A68_EXT, "arccotdg", A68_MCACHE (proc_real_real), genie_acotdg_real); a68_idf (A68_EXT, "arccsc", A68_MCACHE (proc_real_real), genie_acsc_real); a68_idf (A68_EXT, "arcsec", A68_MCACHE (proc_real_real), genie_asec_real); a68_idf (A68_EXT, "arcsindg", A68_MCACHE (proc_real_real), genie_asindg_real); a68_idf (A68_EXT, "arcsinh", A68_MCACHE (proc_real_real), genie_asinh_real); a68_idf (A68_EXT, "arctan2", A68_MCACHE (proc_real_real_real), genie_atan2_real); a68_idf (A68_EXT, "arctan2dg", A68_MCACHE (proc_real_real_real), genie_atan2dg_real); a68_idf (A68_EXT, "arctandg", A68_MCACHE (proc_real_real), genie_atandg_real); a68_idf (A68_EXT, "arctanh", A68_MCACHE (proc_real_real), genie_atanh_real); a68_idf (A68_EXT, "asec", A68_MCACHE (proc_real_real), genie_asec_real); a68_idf (A68_EXT, "asin", A68_MCACHE (proc_real_real), genie_asin_real); a68_idf (A68_EXT, "asindg", A68_MCACHE (proc_real_real), genie_asindg_real); a68_idf (A68_EXT, "asinh", A68_MCACHE (proc_real_real), genie_asinh_real); a68_idf (A68_EXT, "atan", A68_MCACHE (proc_real_real), genie_atan_real); a68_idf (A68_EXT, "atandg", A68_MCACHE (proc_real_real), genie_atandg_real); a68_idf (A68_EXT, "atanh", A68_MCACHE (proc_real_real), genie_atanh_real); a68_idf (A68_EXT, "beta", A68_MCACHE (proc_real_real_real), genie_beta_real); a68_idf (A68_EXT, "betainc", A68_MCACHE (proc_real_real_real_real), genie_beta_inc_cf_real); a68_idf (A68_EXT, "cbrt", A68_MCACHE (proc_real_real), genie_curt_real); a68_idf (A68_EXT, "cosdg", A68_MCACHE (proc_real_real), genie_cosdg_real); a68_idf (A68_EXT, "cosh", A68_MCACHE (proc_real_real), genie_cosh_real); a68_idf (A68_EXT, "cospi", A68_MCACHE (proc_real_real), genie_cospi_real); a68_idf (A68_EXT, "cot", A68_MCACHE (proc_real_real), genie_cot_real); a68_idf (A68_EXT, "cotdg", A68_MCACHE (proc_real_real), genie_cotdg_real); a68_idf (A68_EXT, "cotpi", A68_MCACHE (proc_real_real), genie_cotpi_real); a68_idf (A68_EXT, "csc", A68_MCACHE (proc_real_real), genie_csc_real); a68_idf (A68_EXT, "curt", A68_MCACHE (proc_real_real), genie_curt_real); a68_idf (A68_EXT, "erf", A68_MCACHE (proc_real_real), genie_erf_real); a68_idf (A68_EXT, "erfc", A68_MCACHE (proc_real_real), genie_erfc_real); a68_idf (A68_EXT, "gamma", A68_MCACHE (proc_real_real), genie_gamma_real); a68_idf (A68_EXT, "gammainc", A68_MCACHE (proc_real_real_real), genie_gamma_inc_h_real); a68_idf (A68_EXT, "gammaincf", A68_MCACHE (proc_real_real_real), genie_gamma_inc_f_real); a68_idf (A68_EXT, "gammaincg", A68_MCACHE (proc_real_real_real_real_real), genie_gamma_inc_g_real); a68_idf (A68_EXT, "gammaincgf", A68_MCACHE (proc_real_real_real), genie_gamma_inc_gf_real); a68_idf (A68_EXT, "inverf", A68_MCACHE (proc_real_real), genie_inverf_real); a68_idf (A68_EXT, "inverfc", A68_MCACHE (proc_real_real), genie_inverfc_real); a68_idf (A68_EXT, "inverseerf", A68_MCACHE (proc_real_real), genie_inverf_real); a68_idf (A68_EXT, "inverseerfc", A68_MCACHE (proc_real_real), genie_inverfc_real); a68_idf (A68_EXT, "lje126", A68_MCACHE (proc_real_real_real_real), genie_lj_e_12_6); a68_idf (A68_EXT, "ljf126", A68_MCACHE (proc_real_real_real_real), genie_lj_f_12_6); a68_idf (A68_EXT, "ln1p", A68_MCACHE (proc_real_real), genie_ln1p_real); a68_idf (A68_EXT, "lnbeta", A68_MCACHE (proc_real_real_real), genie_ln_beta_real); a68_idf (A68_EXT, "lngamma", A68_MCACHE (proc_real_real), genie_ln_gamma_real); a68_idf (A68_EXT, "sec", A68_MCACHE (proc_real_real), genie_sec_real); a68_idf (A68_EXT, "sindg", A68_MCACHE (proc_real_real), genie_sindg_real); a68_idf (A68_EXT, "sinh", A68_MCACHE (proc_real_real), genie_sinh_real); a68_idf (A68_EXT, "sinpi", A68_MCACHE (proc_real_real), genie_sinpi_real); a68_idf (A68_EXT, "tandg", A68_MCACHE (proc_real_real), genie_tandg_real); a68_idf (A68_EXT, "tanh", A68_MCACHE (proc_real_real), genie_tanh_real); a68_idf (A68_EXT, "tanpi", A68_MCACHE (proc_real_real), genie_tanpi_real); a68_idf (A68_STD, "arccos", A68_MCACHE (proc_real_real), genie_acos_real); a68_idf (A68_STD, "arcsin", A68_MCACHE (proc_real_real), genie_asin_real); a68_idf (A68_STD, "arctan", A68_MCACHE (proc_real_real), genie_atan_real); a68_idf (A68_STD, "cos", A68_MCACHE (proc_real_real), genie_cos_real); a68_idf (A68_STD, "exp", A68_MCACHE (proc_real_real), genie_exp_real); a68_idf (A68_STD, "ln", A68_MCACHE (proc_real_real), genie_ln_real); a68_idf (A68_STD, "log", A68_MCACHE (proc_real_real), genie_log_real); a68_idf (A68_STD, "sin", A68_MCACHE (proc_real_real), genie_sin_real); a68_idf (A68_STD, "sqrt", A68_MCACHE (proc_real_real), genie_sqrt_real); a68_idf (A68_STD, "tan", A68_MCACHE (proc_real_real), genie_tan_real); // COMPLEX ops. m = a68_proc (M_COMPLEX, M_REAL, M_REAL, NO_MOID); a68_op (A68_STD, "I", m, genie_i_complex); a68_op (A68_STD, "+*", m, genie_i_complex); m = a68_proc (M_COMPLEX, M_INT, M_INT, NO_MOID); a68_op (A68_STD, "I", m, genie_i_int_complex); a68_op (A68_STD, "+*", m, genie_i_int_complex); m = a68_proc (M_REAL, M_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 = A68_MCACHE (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 (M_BOOL, M_COMPLEX, M_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 (M_COMPLEX, M_COMPLEX, M_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 (M_COMPLEX, M_COMPLEX, M_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 (M_REF_COMPLEX, M_REF_COMPLEX, M_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); m = A68_MCACHE (proc_complex_complex); a68_idf (A68_EXT, "cacosh", m, genie_acosh_complex); a68_idf (A68_EXT, "cacos", m, genie_acos_complex); a68_idf (A68_EXT, "carccosh", m, genie_acosh_complex); a68_idf (A68_EXT, "carccos", m, genie_acos_complex); a68_idf (A68_EXT, "carcsinh", m, genie_asinh_complex); a68_idf (A68_EXT, "carcsin", m, genie_asin_complex); a68_idf (A68_EXT, "carctanh", m, genie_atanh_complex); a68_idf (A68_EXT, "carctan", m, genie_atan_complex); a68_idf (A68_EXT, "casinh", m, genie_asinh_complex); a68_idf (A68_EXT, "casin", m, genie_asin_complex); a68_idf (A68_EXT, "catanh", m, genie_atanh_complex); a68_idf (A68_EXT, "catan", m, genie_atan_complex); a68_idf (A68_EXT, "ccosh", m, genie_cosh_complex); a68_idf (A68_EXT, "ccos", m, genie_cos_complex); a68_idf (A68_EXT, "cexp", m, genie_exp_complex); a68_idf (A68_EXT, "cln", m, genie_ln_complex); a68_idf (A68_EXT, "complexacosh", m, genie_acosh_complex); a68_idf (A68_EXT, "complexacos", m, genie_acos_complex); a68_idf (A68_EXT, "complexarccosh", m, genie_acosh_complex); a68_idf (A68_EXT, "complexarccos", m, genie_acos_complex); a68_idf (A68_EXT, "complexarcsinh", m, genie_asinh_complex); a68_idf (A68_EXT, "complexarcsin", m, genie_asin_complex); a68_idf (A68_EXT, "complexarctanh", m, genie_atanh_complex); a68_idf (A68_EXT, "complexarctan", m, genie_atan_complex); a68_idf (A68_EXT, "complexasinh", m, genie_asinh_complex); a68_idf (A68_EXT, "complexasin", m, genie_asin_complex); a68_idf (A68_EXT, "complexatanh", m, genie_atanh_complex); a68_idf (A68_EXT, "complexatan", m, genie_atan_complex); a68_idf (A68_EXT, "complexcosh", m, genie_cosh_complex); a68_idf (A68_EXT, "complexcos", m, genie_cos_complex); a68_idf (A68_EXT, "complexexp", m, genie_exp_complex); a68_idf (A68_EXT, "complexln", m, genie_ln_complex); a68_idf (A68_EXT, "complexsinh", m, genie_sinh_complex); a68_idf (A68_EXT, "complexsin", m, genie_sin_complex); a68_idf (A68_EXT, "complexsqrt", m, genie_sqrt_complex); a68_idf (A68_EXT, "complextanh", m, genie_tanh_complex); a68_idf (A68_EXT, "complextan", m, genie_tan_complex); a68_idf (A68_EXT, "csinh", m, genie_sinh_complex); a68_idf (A68_EXT, "csin", m, genie_sin_complex); a68_idf (A68_EXT, "csqrt", m, genie_sqrt_complex); a68_idf (A68_EXT, "ctanh", m, genie_tanh_complex); a68_idf (A68_EXT, "ctan", m, genie_tan_complex); // BOOL ops. m = a68_proc (M_BOOL, M_BOOL, NO_MOID); a68_op (A68_STD, "NOT", m, genie_not_bool); a68_op (A68_STD, "~", m, genie_not_bool); m = a68_proc (M_INT, M_BOOL, NO_MOID); a68_op (A68_STD, "ABS", m, genie_abs_bool); m = a68_proc (M_BOOL, M_BOOL, M_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 (M_BOOL, M_CHAR, M_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 (M_INT, M_CHAR, NO_MOID); a68_op (A68_STD, "ABS", m, genie_abs_char); m = a68_proc (M_CHAR, M_INT, NO_MOID); a68_op (A68_STD, "REPR", m, genie_repr_char); m = a68_proc (M_BOOL, M_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 (M_CHAR, M_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 (M_INT, M_BITS, NO_MOID); a68_op (A68_STD, "ABS", m, genie_abs_bits); m = a68_proc (M_BITS, M_INT, NO_MOID); a68_op (A68_STD, "BIN", m, genie_bin_int); m = a68_proc (M_BITS, M_BITS, NO_MOID); a68_op (A68_STD, "NOT", m, genie_not_bits); a68_op (A68_STD, "~", m, genie_not_bits); m = a68_proc (M_BOOL, M_BITS, M_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); #if (A68_LEVEL >= 3) a68_op (A68_EXT, "<", m, genie_lt_bits); a68_op (A68_EXT, ">", m, genie_gt_bits); a68_op (A68_EXT, "LT", m, genie_lt_bits); a68_op (A68_EXT, "GT", m, genie_gt_bits); #endif m = a68_proc (M_BITS, M_BITS, M_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); a68_op (A68_EXT, "+", m, genie_add_bits); a68_op (A68_EXT, "-", m, genie_sub_bits); a68_op (A68_EXT, "*", m, genie_times_bits); a68_op (A68_EXT, "OVER", m, genie_over_bits); a68_op (A68_EXT, "MOD", m, genie_over_bits); m = a68_proc (M_BITS, M_BITS, M_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); a68_op (A68_EXT, "ROL", m, genie_rol_bits); a68_op (A68_EXT, "ROR", m, genie_ror_bits); m = a68_proc (M_BOOL, M_INT, M_BITS, NO_MOID); a68_op (A68_STD, "ELEM", m, genie_elem_bits); m = a68_proc (M_BITS, M_INT, M_BITS, NO_MOID); a68_op (A68_STD, "SET", m, genie_set_bits); a68_op (A68_STD, "CLEAR", m, genie_clear_bits); // LONG LONG INT in software m = a68_proc (M_LONG_LONG_INT, M_LONG_LONG_INT, NO_MOID); a68_op (A68_STD, "+", m, genie_idle); a68_op (A68_STD, "-", m, genie_minus_mp); a68_op (A68_STD, "ABS", m, genie_abs_mp); m = a68_proc (M_INT, M_LONG_LONG_INT, NO_MOID); a68_op (A68_STD, "SIGN", m, genie_sign_mp); m = a68_proc (M_BOOL, M_LONG_LONG_INT, NO_MOID); a68_op (A68_STD, "ODD", m, genie_odd_mp); m = a68_proc (M_LONG_LONG_INT, M_LONG_LONG_REAL, NO_MOID); a68_op (A68_STD, "ENTIER", m, genie_entier_mp); a68_op (A68_STD, "ROUND", m, genie_round_mp); m = a68_proc (M_LONG_LONG_INT, M_LONG_LONG_INT, M_LONG_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_mp); a68_op (A68_STD, "%", m, genie_over_mp); a68_op (A68_STD, "MOD", m, genie_mod_mp); a68_op (A68_STD, "%*", m, genie_mod_mp); m = a68_proc (M_REF_LONG_LONG_INT, M_REF_LONG_LONG_INT, M_LONG_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_mp); a68_op (A68_STD, "%*:=", m, genie_modab_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_mp); a68_op (A68_STD, "MODAB", m, genie_modab_mp); m = a68_proc (M_LONG_LONG_REAL, M_LONG_LONG_INT, M_LONG_LONG_INT, NO_MOID); a68_op (A68_STD, "/", m, genie_div_mp); m = a68_proc (M_BOOL, M_LONG_LONG_INT, M_LONG_LONG_INT, NO_MOID); a68_op (A68_STD, "=", m, genie_eq_mp); a68_op (A68_STD, "EQ", m, genie_eq_mp); a68_op (A68_STD, "/=", m, genie_ne_mp); a68_op (A68_STD, "~=", m, genie_ne_mp); a68_op (A68_STD, "^=", m, genie_ne_mp); a68_op (A68_STD, "NE", m, genie_ne_mp); a68_op (A68_STD, "<", m, genie_lt_mp); a68_op (A68_STD, "LT", m, genie_lt_mp); a68_op (A68_STD, "<=", m, genie_le_mp); a68_op (A68_STD, "LE", m, genie_le_mp); a68_op (A68_STD, ">", m, genie_gt_mp); a68_op (A68_STD, "GT", m, genie_gt_mp); a68_op (A68_STD, ">=", m, genie_ge_mp); a68_op (A68_STD, "GE", m, genie_ge_mp); m = a68_proc (M_LONG_LONG_INT, M_LONG_LONG_INT, M_INT, NO_MOID); a68_op (A68_STD, "**", m, genie_pow_mp_int_int); a68_op (A68_STD, "^", m, genie_pow_mp_int_int); m = a68_proc (M_LONG_LONG_COMPLEX, M_LONG_LONG_INT, M_LONG_LONG_INT, NO_MOID); a68_op (A68_STD, "I", m, genie_idle); a68_op (A68_STD, "+*", m, genie_idle); // LONG LONG REAL in software m = a68_proc (M_LONG_LONG_REAL, M_LONG_LONG_REAL, NO_MOID); a68_op (A68_STD, "+", m, genie_idle); a68_op (A68_STD, "-", m, genie_minus_mp); a68_op (A68_STD, "ABS", m, genie_abs_mp); // a68_idf (A68_EXT, "longlongarccosdg", m, genie_acosdg_mp); a68_idf (A68_EXT, "longlongarccosh", m, genie_acosh_mp); a68_idf (A68_EXT, "longlongarccotdg", m, genie_acotdg_mp); a68_idf (A68_EXT, "longlongarccot", m, genie_acot_mp); a68_idf (A68_EXT, "longlongarccsc", m, genie_acsc_mp); a68_idf (A68_EXT, "longlongarcsec", m, genie_asec_mp); a68_idf (A68_EXT, "longlongarcsindg", m, genie_asindg_mp); a68_idf (A68_EXT, "longlongarcsinh", m, genie_asinh_mp); a68_idf (A68_EXT, "longlongarctandg", m, genie_atandg_mp); a68_idf (A68_EXT, "longlongarctanh", m, genie_atanh_mp); a68_idf (A68_EXT, "longlongcbrt", m, genie_curt_mp); a68_idf (A68_EXT, "longlongcosdg", m, genie_cosdg_mp); a68_idf (A68_EXT, "longlongcosh", m, genie_cosh_mp); a68_idf (A68_EXT, "longlongcospi", m, genie_cospi_mp); a68_idf (A68_EXT, "longlongcotdg", m, genie_cotdg_mp); a68_idf (A68_EXT, "longlongcot", m, genie_cot_mp); a68_idf (A68_EXT, "longlongcotpi", m, genie_cotpi_mp); a68_idf (A68_EXT, "longlongcsc", m, genie_csc_mp); a68_idf (A68_EXT, "longlongcurt", m, genie_curt_mp); a68_idf (A68_EXT, "longlongerfc", m, genie_erfc_mp); a68_idf (A68_EXT, "longlongerf", m, genie_erf_mp); a68_idf (A68_EXT, "longlonginverfc", m, genie_inverfc_mp); a68_idf (A68_EXT, "longlonginverf", m, genie_inverf_mp); a68_idf (A68_EXT, "longlonggamma", m, genie_gamma_mp); a68_idf (A68_EXT, "longlonglngamma", m, genie_lngamma_mp); a68_idf (A68_EXT, "longlongsec", m, genie_sec_mp); a68_idf (A68_EXT, "longlongsindg", m, genie_sindg_mp); a68_idf (A68_EXT, "longlongsinh", m, genie_sinh_mp); a68_idf (A68_EXT, "longlongsinpi", m, genie_sinpi_mp); a68_idf (A68_EXT, "longlongtandg", m, genie_tandg_mp); a68_idf (A68_EXT, "longlongtanh", m, genie_tanh_mp); a68_idf (A68_EXT, "longlongtan", m, genie_tan_mp); a68_idf (A68_EXT, "longlongtanpi", m, genie_tanpi_mp); a68_idf (A68_EXT, "qacosdg", m, genie_acosdg_mp); a68_idf (A68_EXT, "qacosh", m, genie_acosh_mp); a68_idf (A68_EXT, "qacos", m, genie_acos_mp); a68_idf (A68_EXT, "qacotdg", m, genie_acotdg_mp); a68_idf (A68_EXT, "qacot", m, genie_acot_mp); a68_idf (A68_EXT, "qacsc", m, genie_acsc_mp); a68_idf (A68_EXT, "qasec", m, genie_asec_mp); a68_idf (A68_EXT, "qasindg", m, genie_asindg_mp); a68_idf (A68_EXT, "qasindg", m, genie_asindg_mp); a68_idf (A68_EXT, "qasinh", m, genie_asinh_mp); a68_idf (A68_EXT, "qasin", m, genie_asin_mp); a68_idf (A68_EXT, "qatandg", m, genie_atandg_mp); a68_idf (A68_EXT, "qatanh", m, genie_atanh_mp); a68_idf (A68_EXT, "qatan", m, genie_atan_mp); a68_idf (A68_EXT, "qcbrt", m, genie_curt_mp); a68_idf (A68_EXT, "qcosdg", m, genie_cosdg_mp); a68_idf (A68_EXT, "qcosh", m, genie_cosh_mp); a68_idf (A68_EXT, "qcos", m, genie_cos_mp); a68_idf (A68_EXT, "qcospi", m, genie_cospi_mp); a68_idf (A68_EXT, "qcotdg", m, genie_cotdg_mp); a68_idf (A68_EXT, "qcot", m, genie_cot_mp); a68_idf (A68_EXT, "qcotpi", m, genie_cotpi_mp); a68_idf (A68_EXT, "qcsc", m, genie_csc_mp); a68_idf (A68_EXT, "qcurt", m, genie_curt_mp); a68_idf (A68_EXT, "qerfc", m, genie_erfc_mp); a68_idf (A68_EXT, "qerf", m, genie_erf_mp); a68_idf (A68_EXT, "qexp", m, genie_exp_mp); a68_idf (A68_EXT, "qinverfc", m, genie_inverfc_mp); a68_idf (A68_EXT, "qinverf", m, genie_inverf_mp); a68_idf (A68_EXT, "qgamma", m, genie_gamma_mp); a68_idf (A68_EXT, "qlngamma", m, genie_lngamma_mp); a68_idf (A68_EXT, "qln", m, genie_ln_mp); a68_idf (A68_EXT, "qlog", m, genie_log_mp); a68_idf (A68_EXT, "qsec", m, genie_sec_mp); a68_idf (A68_EXT, "qsindg", m, genie_sindg_mp); a68_idf (A68_EXT, "qsinh", m, genie_sinh_mp); a68_idf (A68_EXT, "qsin", m, genie_sin_mp); a68_idf (A68_EXT, "qsinpi", m, genie_sinpi_mp); a68_idf (A68_EXT, "qsqrt", m, genie_sqrt_mp); a68_idf (A68_EXT, "qtandg", m, genie_tandg_mp); a68_idf (A68_EXT, "qtanh", m, genie_tanh_mp); a68_idf (A68_EXT, "qtan", m, genie_tan_mp); a68_idf (A68_EXT, "qtanpi", m, genie_tanpi_mp); a68_idf (A68_STD, "longlongarccos", m, genie_acos_mp); a68_idf (A68_STD, "longlongarcsin", m, genie_asin_mp); a68_idf (A68_STD, "longlongarctan", m, genie_atan_mp); a68_idf (A68_STD, "longlongcos", m, genie_cos_mp); a68_idf (A68_STD, "longlongexp", m, genie_exp_mp); a68_idf (A68_STD, "longlongln", m, genie_ln_mp); a68_idf (A68_STD, "longlonglog", m, genie_log_mp); a68_idf (A68_STD, "longlongsin", m, genie_sin_mp); a68_idf (A68_STD, "longlongsqrt", m, genie_sqrt_mp); a68_idf (A68_STD, "longlongtan", m, genie_tan_mp); m = a68_proc (M_LONG_LONG_REAL, M_LONG_LONG_REAL, M_LONG_LONG_REAL, NO_MOID); a68_idf (A68_EXT, "longlongarctan2dg", m, genie_atan2dg_mp); a68_idf (A68_EXT, "longlongarctan2", m, genie_atan2_mp); a68_idf (A68_EXT, "longlongbeta", m, genie_beta_mp); a68_idf (A68_EXT, "longlonggammaincgf", m, genie_gamma_inc_gf_mp); a68_idf (A68_EXT, "longlonggammaincf", m, genie_gamma_inc_f_mp); a68_idf (A68_EXT, "longlonggammainc", m, genie_gamma_inc_h_mp); a68_idf (A68_EXT, "longlonglnbeta", m, genie_lnbeta_mp); a68_idf (A68_EXT, "qarctan2dg", m, genie_atan2dg_mp); a68_idf (A68_EXT, "qatan2", m, genie_atan2_mp); a68_idf (A68_EXT, "qbeta", m, genie_beta_mp); a68_idf (A68_EXT, "qgammaincgf", m, genie_gamma_inc_gf_mp); a68_idf (A68_EXT, "qgammaincf", m, genie_gamma_inc_f_mp); a68_idf (A68_EXT, "qgammainc", m, genie_gamma_inc_h_mp); a68_idf (A68_EXT, "qlnbeta", m, genie_lnbeta_mp); m = a68_proc (M_LONG_LONG_REAL, M_LONG_LONG_REAL, M_LONG_LONG_REAL, M_LONG_LONG_REAL, NO_MOID); a68_idf (A68_STD, "longlongbetainc", m, genie_beta_inc_mp); a68_idf (A68_STD, "qbetainc", m, genie_beta_inc_mp); m = a68_proc (M_LONG_LONG_REAL, M_LONG_LONG_REAL, M_LONG_LONG_REAL, M_LONG_LONG_REAL, M_LONG_LONG_REAL, NO_MOID); a68_idf (A68_EXT, "longlonggammaincg", m, genie_gamma_inc_g_mp); a68_idf (A68_EXT, "qgammaincg", m, genie_gamma_inc_g_mp); m = a68_proc (M_LONG_LONG_REAL, M_LONG_LONG_REAL, M_LONG_LONG_REAL, NO_MOID); a68_op (A68_STD, "+", m, genie_add_mp); a68_op (A68_STD, "-", m, genie_sub_mp); a68_op (A68_STD, "*", m, genie_mul_mp); a68_op (A68_STD, "/", m, genie_div_mp); a68_op (A68_STD, "**", m, genie_pow_mp); a68_op (A68_STD, "UP", m, genie_pow_mp); a68_op (A68_STD, "^", m, genie_pow_mp); m = a68_proc (M_REF_LONG_LONG_REAL, M_REF_LONG_LONG_REAL, M_LONG_LONG_REAL, NO_MOID); a68_op (A68_STD, "+:=", m, genie_plusab_mp); a68_op (A68_STD, "-:=", m, genie_minusab_mp); a68_op (A68_STD, "*:=", m, genie_timesab_mp); a68_op (A68_STD, "/:=", m, genie_divab_mp); a68_op (A68_STD, "PLUSAB", m, genie_plusab_mp); a68_op (A68_STD, "MINUSAB", m, genie_minusab_mp); a68_op (A68_STD, "TIMESAB", m, genie_timesab_mp); a68_op (A68_STD, "DIVAB", m, genie_divab_mp); m = a68_proc (M_BOOL, M_LONG_LONG_REAL, M_LONG_LONG_REAL, NO_MOID); a68_op (A68_STD, "=", m, genie_eq_mp); a68_op (A68_STD, "EQ", m, genie_eq_mp); a68_op (A68_STD, "/=", m, genie_ne_mp); a68_op (A68_STD, "~=", m, genie_ne_mp); a68_op (A68_STD, "^=", m, genie_ne_mp); a68_op (A68_STD, "NE", m, genie_ne_mp); a68_op (A68_STD, "<", m, genie_lt_mp); a68_op (A68_STD, "LT", m, genie_lt_mp); a68_op (A68_STD, "<=", m, genie_le_mp); a68_op (A68_STD, "LE", m, genie_le_mp); a68_op (A68_STD, ">", m, genie_gt_mp); a68_op (A68_STD, "GT", m, genie_gt_mp); a68_op (A68_STD, ">=", m, genie_ge_mp); a68_op (A68_STD, "GE", m, genie_ge_mp); m = a68_proc (M_LONG_LONG_REAL, M_LONG_LONG_REAL, M_INT, NO_MOID); a68_op (A68_STD, "**", m, genie_pow_mp_int); a68_op (A68_STD, "UP", m, genie_pow_mp_int); a68_op (A68_STD, "^", m, genie_pow_mp_int); m = a68_proc (M_LONG_LONG_COMPLEX, M_LONG_LONG_REAL, M_LONG_LONG_REAL, NO_MOID); a68_op (A68_STD, "I", m, genie_idle); a68_op (A68_STD, "+*", m, genie_idle); // LONG LONG COMPLEX in software m = a68_proc (M_LONG_LONG_REAL, M_LONG_LONG_COMPLEX, NO_MOID); a68_op (A68_STD, "RE", m, genie_re_mp_complex); a68_op (A68_STD, "IM", m, genie_im_mp_complex); a68_op (A68_STD, "ARG", m, genie_arg_mp_complex); a68_op (A68_STD, "ABS", m, genie_abs_mp_complex); m = a68_proc (M_LONG_LONG_COMPLEX, M_LONG_LONG_COMPLEX, NO_MOID); a68_op (A68_STD, "+", m, genie_idle); a68_op (A68_STD, "-", m, genie_minus_mp_complex); a68_op (A68_STD, "CONJ", m, genie_conj_mp_complex); m = a68_proc (M_LONG_LONG_COMPLEX, M_LONG_LONG_COMPLEX, M_LONG_LONG_COMPLEX, NO_MOID); a68_op (A68_STD, "+", m, genie_add_mp_complex); a68_op (A68_STD, "-", m, genie_sub_mp_complex); a68_op (A68_STD, "*", m, genie_mul_mp_complex); a68_op (A68_STD, "/", m, genie_div_mp_complex); m = a68_proc (M_LONG_LONG_COMPLEX, M_LONG_LONG_COMPLEX, M_INT, NO_MOID); a68_op (A68_STD, "**", m, genie_pow_mp_complex_int); a68_op (A68_STD, "UP", m, genie_pow_mp_complex_int); a68_op (A68_STD, "^", m, genie_pow_mp_complex_int); m = a68_proc (M_BOOL, M_LONG_LONG_COMPLEX, M_LONG_LONG_COMPLEX, NO_MOID); a68_op (A68_STD, "=", m, genie_eq_mp_complex); a68_op (A68_STD, "EQ", m, genie_eq_mp_complex); a68_op (A68_STD, "/=", m, genie_ne_mp_complex); a68_op (A68_STD, "~=", m, genie_ne_mp_complex); a68_op (A68_STD, "^=", m, genie_ne_mp_complex); a68_op (A68_STD, "NE", m, genie_ne_mp_complex); m = a68_proc (M_REF_LONG_LONG_COMPLEX, M_REF_LONG_LONG_COMPLEX, M_LONG_LONG_COMPLEX, NO_MOID); a68_op (A68_STD, "+:=", m, genie_plusab_mp_complex); a68_op (A68_STD, "-:=", m, genie_minusab_mp_complex); a68_op (A68_STD, "*:=", m, genie_timesab_mp_complex); a68_op (A68_STD, "/:=", m, genie_divab_mp_complex); a68_op (A68_STD, "PLUSAB", m, genie_plusab_mp_complex); a68_op (A68_STD, "MINUSAB", m, genie_minusab_mp_complex); a68_op (A68_STD, "TIMESAB", m, genie_timesab_mp_complex); a68_op (A68_STD, "DIVAB", m, genie_divab_mp_complex); m = a68_proc (M_LONG_LONG_COMPLEX, M_LONG_LONG_COMPLEX, NO_MOID); a68_idf (A68_EXT, "longlongcomplexarccosh", m, genie_acosh_mp_complex); a68_idf (A68_EXT, "longlongcomplexarccos", m, genie_acos_mp_complex); a68_idf (A68_EXT, "longlongcomplexarcsinh", m, genie_asinh_mp_complex); a68_idf (A68_EXT, "longlongcomplexarcsin", m, genie_asin_mp_complex); a68_idf (A68_EXT, "longlongcomplexarctanh", m, genie_atanh_mp_complex); a68_idf (A68_EXT, "longlongcomplexarctan", m, genie_atan_mp_complex); a68_idf (A68_EXT, "longlongcomplexcosh", m, genie_cosh_mp_complex); a68_idf (A68_EXT, "longlongcomplexcos", m, genie_cos_mp_complex); a68_idf (A68_EXT, "longlongcomplexexp", m, genie_exp_mp_complex); a68_idf (A68_EXT, "longlongcomplexln", m, genie_ln_mp_complex); a68_idf (A68_EXT, "longlongcomplexsinh", m, genie_sinh_mp_complex); a68_idf (A68_EXT, "longlongcomplexsin", m, genie_sin_mp_complex); a68_idf (A68_EXT, "longlongcomplexsqrt", m, genie_sqrt_mp_complex); a68_idf (A68_EXT, "longlongcomplextanh", m, genie_tanh_mp_complex); a68_idf (A68_EXT, "longlongcomplextan", m, genie_tan_mp_complex); a68_idf (A68_EXT, "qcacosh", m, genie_acosh_mp_complex); a68_idf (A68_EXT, "qcacos", m, genie_acos_mp_complex); a68_idf (A68_EXT, "qcasinh", m, genie_asinh_mp_complex); a68_idf (A68_EXT, "qcasin", m, genie_asin_mp_complex); a68_idf (A68_EXT, "qcatanh", m, genie_atanh_mp_complex); a68_idf (A68_EXT, "qcatan", m, genie_atan_mp_complex); a68_idf (A68_EXT, "qccosh", m, genie_cosh_mp_complex); a68_idf (A68_EXT, "qccos", m, genie_cos_mp_complex); a68_idf (A68_EXT, "qcexp", m, genie_exp_mp_complex); a68_idf (A68_EXT, "qcln", m, genie_ln_mp_complex); a68_idf (A68_EXT, "qcsinh", m, genie_sinh_mp_complex); a68_idf (A68_EXT, "qcsin", m, genie_sin_mp_complex); a68_idf (A68_EXT, "qcsqrt", m, genie_sqrt_mp_complex); a68_idf (A68_EXT, "qctanh", m, genie_tanh_mp_complex); a68_idf (A68_EXT, "qctan", m, genie_tan_mp_complex); // BYTES ops. m = a68_proc (M_BYTES, M_STRING, NO_MOID); a68_idf (A68_STD, "bytespack", m, genie_bytespack); m = a68_proc (M_CHAR, M_INT, M_BYTES, NO_MOID); a68_op (A68_STD, "ELEM", m, genie_elem_bytes); m = a68_proc (M_BYTES, M_BYTES, M_BYTES, NO_MOID); a68_op (A68_STD, "+", m, genie_add_bytes); m = a68_proc (M_REF_BYTES, M_REF_BYTES, M_BYTES, NO_MOID); a68_op (A68_STD, "+:=", m, genie_plusab_bytes); a68_op (A68_STD, "PLUSAB", m, genie_plusab_bytes); m = a68_proc (M_REF_BYTES, M_BYTES, M_REF_BYTES, NO_MOID); a68_op (A68_STD, "+=:", m, genie_plusto_bytes); a68_op (A68_STD, "PLUSTO", m, genie_plusto_bytes); m = a68_proc (M_BOOL, M_BYTES, M_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 (M_LONG_BYTES, M_BYTES, NO_MOID); a68_op (A68_STD, "LENG", m, genie_leng_bytes); m = a68_proc (M_BYTES, M_LONG_BYTES, NO_MOID); a68_idf (A68_STD, "SHORTEN", m, genie_shorten_bytes); m = a68_proc (M_LONG_BYTES, M_STRING, NO_MOID); a68_idf (A68_STD, "longbytespack", m, genie_long_bytespack); m = a68_proc (M_CHAR, M_INT, M_LONG_BYTES, NO_MOID); a68_op (A68_STD, "ELEM", m, genie_elem_long_bytes); m = a68_proc (M_LONG_BYTES, M_LONG_BYTES, M_LONG_BYTES, NO_MOID); a68_op (A68_STD, "+", m, genie_add_long_bytes); m = a68_proc (M_REF_LONG_BYTES, M_REF_LONG_BYTES, M_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 (M_REF_LONG_BYTES, M_LONG_BYTES, M_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 (M_BOOL, M_LONG_BYTES, M_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 (M_BOOL, M_STRING, M_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 (M_STRING, M_CHAR, M_CHAR, NO_MOID); a68_op (A68_STD, "+", m, genie_add_char); m = a68_proc (M_STRING, M_STRING, M_STRING, NO_MOID); a68_op (A68_STD, "+", m, genie_add_string); m = a68_proc (M_REF_STRING, M_REF_STRING, M_STRING, NO_MOID); a68_op (A68_STD, "+:=", m, genie_plusab_string); a68_op (A68_STD, "PLUSAB", m, genie_plusab_string); m = a68_proc (M_REF_STRING, M_REF_STRING, M_INT, NO_MOID); a68_op (A68_STD, "*:=", m, genie_timesab_string); a68_op (A68_STD, "TIMESAB", m, genie_timesab_string); m = a68_proc (M_REF_STRING, M_STRING, M_REF_STRING, NO_MOID); a68_op (A68_STD, "+=:", m, genie_plusto_string); a68_op (A68_STD, "PLUSTO", m, genie_plusto_string); m = a68_proc (M_STRING, M_STRING, M_INT, NO_MOID); a68_op (A68_STD, "*", m, genie_times_string_int); m = a68_proc (M_STRING, M_INT, M_STRING, NO_MOID); a68_op (A68_STD, "*", m, genie_times_int_string); m = a68_proc (M_STRING, M_INT, M_CHAR, NO_MOID); a68_op (A68_STD, "*", m, genie_times_int_char); m = a68_proc (M_STRING, M_CHAR, M_INT, NO_MOID); a68_op (A68_STD, "*", m, genie_times_char_int); m = a68_proc (M_CHAR, M_INT, M_ROW_CHAR, NO_MOID); a68_op (A68_STD, "ELEM", m, genie_elem_string); m = a68_proc (M_STRING, M_STRING, NO_MOID); a68_idf (A68_EXT, "realpath", m, genie_realpath); // SEMA ops. #if defined (BUILD_PARALLEL_CLAUSE) m = a68_proc (M_SEMA, M_INT, NO_MOID); a68_op (A68_STD, "LEVEL", m, genie_level_sema_int); m = a68_proc (M_INT, M_SEMA, NO_MOID); a68_op (A68_STD, "LEVEL", m, genie_level_int_sema); m = a68_proc (M_VOID, M_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 (M_SEMA, M_INT, NO_MOID); a68_op (A68_STD, "LEVEL", m, genie_unimplemented); m = a68_proc (M_INT, M_SEMA, NO_MOID); a68_op (A68_STD, "LEVEL", m, genie_unimplemented); m = a68_proc (M_VOID, M_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 (M_INT, M_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 (M_INT, M_INT, M_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 (M_ROW_STRING, M_ROW_STRING, NO_MOID); a68_op (A68_EXT, "SORT", m, genie_sort_row_string); // 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 (M_LONG_LONG_INT, M_LONG_LONG_INT, NO_MOID); a68_op (A68_STD, "LENG", m, genie_idle); m = a68_proc (M_LONG_LONG_REAL, M_LONG_LONG_REAL, NO_MOID); a68_op (A68_STD, "LENG", m, genie_idle); m = a68_proc (M_LONG_LONG_COMPLEX, M_LONG_LONG_COMPLEX, NO_MOID); a68_op (A68_STD, "LENG", m, genie_idle); m = a68_proc (M_INT, M_INT, NO_MOID); a68_op (A68_STD, "SHORTEN", m, genie_idle); m = a68_proc (M_REAL, M_REAL, NO_MOID); a68_op (A68_STD, "SHORTEN", m, genie_idle); m = a68_proc (M_COMPLEX, M_COMPLEX, NO_MOID); a68_op (A68_STD, "SHORTEN", m, genie_idle); m = a68_proc (M_BITS, M_BITS, NO_MOID); a68_op (A68_STD, "SHORTEN", m, genie_idle); // SOUND/RIFF procs. m = a68_proc (M_SOUND, M_INT, M_INT, M_INT, M_INT, NO_MOID); a68_idf (A68_EXT, "newsound", m, genie_new_sound); m = a68_proc (M_INT, M_SOUND, M_INT, M_INT, NO_MOID); a68_idf (A68_EXT, "getsound", m, genie_get_sound); m = a68_proc (M_VOID, M_SOUND, M_INT, M_INT, M_INT, NO_MOID); a68_idf (A68_EXT, "setsound", m, genie_set_sound); m = a68_proc (M_INT, M_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. void stand_mp_level_2 (void) { #if (A68_LEVEL <= 2) MOID_T *m; a68_idf (A68_STD, "dpi", M_LONG_REAL, genie_pi_mp); a68_idf (A68_STD, "longpi", M_LONG_REAL, genie_pi_mp); a68_idf (A68_STD, "longmaxbits", M_LONG_BITS, genie_long_max_bits); a68_idf (A68_STD, "longmaxint", M_LONG_INT, genie_long_max_int); a68_idf (A68_STD, "longsmallreal", M_LONG_REAL, genie_long_small_real); a68_idf (A68_STD, "longmaxreal", M_LONG_REAL, genie_long_max_real); a68_idf (A68_STD, "longminreal", M_LONG_REAL, genie_long_min_real); a68_idf (A68_STD, "longinfinity", M_LONG_REAL, genie_infinity_mp); a68_idf (A68_STD, "longminusinfinity", M_LONG_REAL, genie_minus_infinity_mp); a68_idf (A68_STD, "longinf", M_LONG_REAL, genie_infinity_mp); a68_idf (A68_STD, "longmininf", M_LONG_REAL, genie_minus_infinity_mp); // LONG INT in software m = a68_proc (M_LONG_INT, M_LONG_INT, NO_MOID); a68_op (A68_STD, "+", m, genie_idle); a68_op (A68_STD, "-", m, genie_minus_mp); a68_op (A68_STD, "ABS", m, genie_abs_mp); m = a68_proc (M_LONG_INT, M_INT, NO_MOID); a68_op (A68_STD, "LENG", m, genie_lengthen_int_to_mp); m = a68_proc (M_INT, M_LONG_INT, NO_MOID); a68_op (A68_STD, "SHORTEN", m, genie_shorten_mp_to_int); a68_op (A68_STD, "SIGN", m, genie_sign_mp); m = a68_proc (M_LONG_LONG_REAL, M_LONG_REAL, NO_MOID); a68_op (A68_STD, "LENG", m, genie_lengthen_mp_to_long_mp); m = a68_proc (M_LONG_REAL, M_LONG_LONG_REAL, NO_MOID); a68_op (A68_STD, "SHORTEN", m, genie_shorten_long_mp_to_mp); m = a68_proc (M_LONG_LONG_INT, M_LONG_INT, NO_MOID); a68_op (A68_STD, "LENG", m, genie_lengthen_mp_to_long_mp); m = a68_proc (M_LONG_INT, M_LONG_LONG_INT, NO_MOID); a68_op (A68_STD, "SHORTEN", m, genie_shorten_long_mp_to_mp); m = a68_proc (M_BOOL, M_LONG_INT, NO_MOID); a68_op (A68_STD, "ODD", m, genie_odd_mp); m = a68_proc (M_LONG_INT, M_LONG_REAL, NO_MOID); a68_op (A68_STD, "ENTIER", m, genie_entier_mp); a68_op (A68_STD, "ROUND", m, genie_round_mp); m = a68_proc (M_LONG_INT, M_LONG_INT, M_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_mp); a68_op (A68_STD, "%", m, genie_over_mp); a68_op (A68_STD, "MOD", m, genie_mod_mp); a68_op (A68_STD, "%*", m, genie_mod_mp); m = a68_proc (M_REF_LONG_INT, M_REF_LONG_INT, M_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_mp); a68_op (A68_STD, "%*:=", m, genie_modab_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_mp); a68_op (A68_STD, "MODAB", m, genie_modab_mp); m = a68_proc (M_BOOL, M_LONG_INT, M_LONG_INT, NO_MOID); a68_op (A68_STD, "=", m, genie_eq_mp); a68_op (A68_STD, "EQ", m, genie_eq_mp); a68_op (A68_STD, "/=", m, genie_ne_mp); a68_op (A68_STD, "~=", m, genie_ne_mp); a68_op (A68_STD, "^=", m, genie_ne_mp); a68_op (A68_STD, "NE", m, genie_ne_mp); a68_op (A68_STD, "<", m, genie_lt_mp); a68_op (A68_STD, "LT", m, genie_lt_mp); a68_op (A68_STD, "<=", m, genie_le_mp); a68_op (A68_STD, "LE", m, genie_le_mp); a68_op (A68_STD, ">", m, genie_gt_mp); a68_op (A68_STD, "GT", m, genie_gt_mp); a68_op (A68_STD, ">=", m, genie_ge_mp); a68_op (A68_STD, "GE", m, genie_ge_mp); m = a68_proc (M_LONG_REAL, M_LONG_INT, M_LONG_INT, NO_MOID); a68_op (A68_STD, "/", m, genie_div_mp); m = a68_proc (M_LONG_INT, M_LONG_INT, M_INT, NO_MOID); a68_op (A68_STD, "**", m, genie_pow_mp_int_int); a68_op (A68_STD, "^", m, genie_pow_mp_int_int); m = a68_proc (M_LONG_COMPLEX, M_LONG_INT, M_LONG_INT, NO_MOID); a68_op (A68_STD, "I", m, genie_idle); a68_op (A68_STD, "+*", m, genie_idle); m = a68_proc (M_LONG_REAL, M_REAL, NO_MOID); a68_op (A68_STD, "LENG", m, genie_lengthen_real_to_mp); m = a68_proc (M_REAL, M_LONG_REAL, NO_MOID); a68_op (A68_STD, "SHORTEN", m, genie_shorten_mp_to_real); // LONG REAL in software m = a68_proc (M_LONG_REAL, M_LONG_REAL, NO_MOID); a68_op (A68_STD, "+", m, genie_idle); a68_op (A68_STD, "-", m, genie_minus_mp); a68_op (A68_STD, "ABS", m, genie_abs_mp); m = a68_proc (M_LONG_REAL, M_LONG_REAL, NO_MOID); a68_idf (A68_EXT, "dacosdg", m, genie_acosdg_mp); a68_idf (A68_EXT, "dacosh", m, genie_acosh_mp); a68_idf (A68_EXT, "dacos", m, genie_acos_mp); a68_idf (A68_EXT, "dacotdg", m, genie_acotdg_mp); a68_idf (A68_EXT, "dacot", m, genie_acot_mp); a68_idf (A68_EXT, "dacsc", m, genie_acsc_mp); a68_idf (A68_EXT, "dasec", m, genie_asec_mp); a68_idf (A68_EXT, "dasindg", m, genie_asindg_mp); a68_idf (A68_EXT, "dasinh", m, genie_asinh_mp); a68_idf (A68_EXT, "dasin", m, genie_asin_mp); a68_idf (A68_EXT, "datandg", m, genie_atandg_mp); a68_idf (A68_EXT, "datanh", m, genie_atanh_mp); a68_idf (A68_EXT, "datan", m, genie_atan_mp); a68_idf (A68_EXT, "dcbrt", m, genie_curt_mp); a68_idf (A68_EXT, "dcosdg", m, genie_cosdg_mp); a68_idf (A68_EXT, "dcosh", m, genie_cosh_mp); a68_idf (A68_EXT, "dcos", m, genie_cos_mp); a68_idf (A68_EXT, "dcospi", m, genie_cospi_mp); a68_idf (A68_EXT, "dcotdg", m, genie_cotdg_mp); a68_idf (A68_EXT, "dcot", m, genie_cot_mp); a68_idf (A68_EXT, "dcotpi", m, genie_cotpi_mp); a68_idf (A68_EXT, "dcsc", m, genie_csc_mp); a68_idf (A68_EXT, "dcurt", m, genie_curt_mp); a68_idf (A68_EXT, "derf", m, genie_erf_mp); a68_idf (A68_EXT, "derfc", m, genie_erfc_mp); a68_idf (A68_EXT, "dinverf", m, genie_inverf_mp); a68_idf (A68_EXT, "dinverfc", m, genie_inverfc_mp); a68_idf (A68_EXT, "dgamma", m, genie_gamma_mp); a68_idf (A68_EXT, "dlngamma", m, genie_lngamma_mp); a68_idf (A68_EXT, "dexp", m, genie_exp_mp); a68_idf (A68_EXT, "dln", m, genie_ln_mp); a68_idf (A68_EXT, "dlog", m, genie_log_mp); a68_idf (A68_EXT, "dsec", m, genie_sec_mp); a68_idf (A68_EXT, "dsindg", m, genie_sindg_mp); a68_idf (A68_EXT, "dsinh", m, genie_sinh_mp); a68_idf (A68_EXT, "dsin", m, genie_sin_mp); a68_idf (A68_EXT, "dsinpi", m, genie_sinpi_mp); a68_idf (A68_EXT, "dsqrt", m, genie_sqrt_mp); a68_idf (A68_EXT, "dtandg", m, genie_tandg_mp); a68_idf (A68_EXT, "dtanh", m, genie_tanh_mp); a68_idf (A68_EXT, "dtan", m, genie_tan_mp); a68_idf (A68_EXT, "dtanpi", m, genie_tan_mp); a68_idf (A68_EXT, "longarccosdg", m, genie_acosdg_mp); a68_idf (A68_EXT, "longarccosh", m, genie_acosh_mp); a68_idf (A68_EXT, "longarccotdg", m, genie_acosdg_mp); a68_idf (A68_EXT, "longarccot", m, genie_acot_mp); a68_idf (A68_EXT, "longarccsc", m, genie_acsc_mp); a68_idf (A68_EXT, "longarcsec", m, genie_asec_mp); a68_idf (A68_EXT, "longarcsindg", m, genie_asindg_mp); a68_idf (A68_EXT, "longarcsinh", m, genie_asinh_mp); a68_idf (A68_EXT, "longarctandg", m, genie_atandg_mp); a68_idf (A68_EXT, "longarctanh", m, genie_atanh_mp); a68_idf (A68_EXT, "longcbrt", m, genie_curt_mp); a68_idf (A68_EXT, "longcosdg", m, genie_cosdg_mp); a68_idf (A68_EXT, "longcosh", m, genie_cosh_mp); a68_idf (A68_EXT, "longcospi", m, genie_cospi_mp); a68_idf (A68_EXT, "longcotdg", m, genie_cotdg_mp); a68_idf (A68_EXT, "longcot", m, genie_cot_mp); a68_idf (A68_EXT, "longcotpi", m, genie_cotpi_mp); a68_idf (A68_EXT, "longcsc", m, genie_csc_mp); a68_idf (A68_EXT, "longcurt", m, genie_curt_mp); a68_idf (A68_EXT, "longerf", m, genie_erf_mp); a68_idf (A68_EXT, "longerfc", m, genie_erfc_mp); a68_idf (A68_EXT, "longinverfc", m, genie_inverfc_mp); a68_idf (A68_EXT, "longinverf", m, genie_inverf_mp); a68_idf (A68_EXT, "longgamma", m, genie_gamma_mp); a68_idf (A68_EXT, "longlngamma", m, genie_lngamma_mp); a68_idf (A68_EXT, "longsec", m, genie_sec_mp); a68_idf (A68_EXT, "longsindg", m, genie_sindg_mp); a68_idf (A68_EXT, "longsinh", m, genie_sinh_mp); a68_idf (A68_EXT, "longsinpi", m, genie_sinpi_mp); a68_idf (A68_EXT, "longtandg", m, genie_tandg_mp); a68_idf (A68_EXT, "longtanh", m, genie_tanh_mp); a68_idf (A68_EXT, "longtanpi", m, genie_tanpi_mp); a68_idf (A68_STD, "longarccos", m, genie_acos_mp); a68_idf (A68_STD, "longarcsin", m, genie_asin_mp); a68_idf (A68_STD, "longarctan", m, genie_atan_mp); a68_idf (A68_STD, "longcos", m, genie_cos_mp); a68_idf (A68_STD, "longexp", m, genie_exp_mp); a68_idf (A68_STD, "longln", m, genie_ln_mp); a68_idf (A68_STD, "longlog", m, genie_log_mp); a68_idf (A68_STD, "longsin", m, genie_sin_mp); a68_idf (A68_STD, "longsqrt", m, genie_sqrt_mp); a68_idf (A68_STD, "longtan", m, genie_tan_mp); m = a68_proc (M_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 (M_LONG_REAL, M_LONG_REAL, M_LONG_REAL, NO_MOID); a68_idf (A68_EXT, "dbeta", m, genie_beta_mp); a68_idf (A68_EXT, "dgammaincgf", m, genie_gamma_inc_gf_mp); a68_idf (A68_EXT, "dgammaincf", m, genie_gamma_inc_f_mp); a68_idf (A68_EXT, "dgammainc", m, genie_gamma_inc_h_mp); a68_idf (A68_EXT, "dlnbeta", m, genie_lnbeta_mp); a68_idf (A68_EXT, "longbeta", m, genie_beta_mp); a68_idf (A68_EXT, "longgammaincgf", m, genie_gamma_inc_gf_mp); a68_idf (A68_EXT, "longgammaincf", m, genie_gamma_inc_f_mp); a68_idf (A68_EXT, "longgammainc", m, genie_gamma_inc_h_mp); a68_idf (A68_EXT, "longlnbeta", m, genie_lnbeta_mp); a68_idf (A68_STD, "darctan2dg", m, genie_atan2dg_mp); a68_idf (A68_STD, "darctan2", m, genie_atan2_mp); a68_idf (A68_STD, "longarctan2dg", m, genie_atan2dg_mp); a68_idf (A68_STD, "longarctan2", m, genie_atan2_mp); m = a68_proc (M_LONG_REAL, M_LONG_REAL, M_LONG_REAL, M_LONG_REAL, NO_MOID); a68_idf (A68_STD, "longbetainc", m, genie_beta_inc_mp); a68_idf (A68_STD, "dbetainc", m, genie_beta_inc_mp); m = a68_proc (M_LONG_REAL, M_LONG_REAL, M_LONG_REAL, M_LONG_REAL, M_LONG_REAL, NO_MOID); a68_idf (A68_EXT, "longgammaincg", m, genie_gamma_inc_g_mp); a68_idf (A68_EXT, "dgammaincg", m, genie_gamma_inc_g_mp); m = a68_proc (M_INT, M_LONG_REAL, NO_MOID); a68_op (A68_STD, "SIGN", m, genie_sign_mp); m = a68_proc (M_LONG_REAL, M_LONG_REAL, M_LONG_REAL, NO_MOID); a68_op (A68_STD, "+", m, genie_add_mp); a68_op (A68_STD, "-", m, genie_sub_mp); a68_op (A68_STD, "*", m, genie_mul_mp); a68_op (A68_STD, "/", m, genie_div_mp); a68_op (A68_STD, "**", m, genie_pow_mp); a68_op (A68_STD, "UP", m, genie_pow_mp); a68_op (A68_STD, "^", m, genie_pow_mp); m = a68_proc (M_REF_LONG_REAL, M_REF_LONG_REAL, M_LONG_REAL, NO_MOID); a68_op (A68_STD, "+:=", m, genie_plusab_mp); a68_op (A68_STD, "-:=", m, genie_minusab_mp); a68_op (A68_STD, "*:=", m, genie_timesab_mp); a68_op (A68_STD, "/:=", m, genie_divab_mp); a68_op (A68_STD, "PLUSAB", m, genie_plusab_mp); a68_op (A68_STD, "MINUSAB", m, genie_minusab_mp); a68_op (A68_STD, "TIMESAB", m, genie_timesab_mp); a68_op (A68_STD, "DIVAB", m, genie_divab_mp); m = a68_proc (M_BOOL, M_LONG_REAL, M_LONG_REAL, NO_MOID); a68_op (A68_STD, "=", m, genie_eq_mp); a68_op (A68_STD, "EQ", m, genie_eq_mp); a68_op (A68_STD, "/=", m, genie_ne_mp); a68_op (A68_STD, "~=", m, genie_ne_mp); a68_op (A68_STD, "^=", m, genie_ne_mp); a68_op (A68_STD, "NE", m, genie_ne_mp); a68_op (A68_STD, "<", m, genie_lt_mp); a68_op (A68_STD, "LT", m, genie_lt_mp); a68_op (A68_STD, "<=", m, genie_le_mp); a68_op (A68_STD, "LE", m, genie_le_mp); a68_op (A68_STD, ">", m, genie_gt_mp); a68_op (A68_STD, "GT", m, genie_gt_mp); a68_op (A68_STD, ">=", m, genie_ge_mp); a68_op (A68_STD, "GE", m, genie_ge_mp); m = a68_proc (M_LONG_REAL, M_LONG_REAL, M_INT, NO_MOID); a68_op (A68_STD, "**", m, genie_pow_mp_int); a68_op (A68_STD, "UP", m, genie_pow_mp_int); a68_op (A68_STD, "^", m, genie_pow_mp_int); m = a68_proc (M_LONG_COMPLEX, M_LONG_REAL, M_LONG_REAL, NO_MOID); a68_op (A68_STD, "I", m, genie_idle); a68_op (A68_STD, "+*", m, genie_idle); // LONG COMPLEX in software m = a68_proc (M_LONG_LONG_COMPLEX, M_LONG_COMPLEX, NO_MOID); a68_op (A68_STD, "LENG", m, genie_lengthen_mp_complex_to_long_mp_complex); m = a68_proc (M_LONG_COMPLEX, M_LONG_LONG_COMPLEX, NO_MOID); a68_op (A68_STD, "SHORTEN", m, genie_shorten_long_mp_complex_to_mp_complex); m = a68_proc (M_LONG_COMPLEX, M_COMPLEX, NO_MOID); a68_op (A68_STD, "LENG", m, genie_lengthen_complex_to_mp_complex); m = a68_proc (M_COMPLEX, M_LONG_COMPLEX, NO_MOID); a68_op (A68_STD, "SHORTEN", m, genie_shorten_mp_complex_to_complex); m = a68_proc (M_LONG_REAL, M_LONG_COMPLEX, NO_MOID); a68_op (A68_STD, "RE", m, genie_re_mp_complex); a68_op (A68_STD, "IM", m, genie_im_mp_complex); a68_op (A68_STD, "ARG", m, genie_arg_mp_complex); a68_op (A68_STD, "ABS", m, genie_abs_mp_complex); m = a68_proc (M_LONG_COMPLEX, M_LONG_COMPLEX, NO_MOID); a68_op (A68_STD, "+", m, genie_idle); a68_op (A68_STD, "-", m, genie_minus_mp_complex); a68_op (A68_STD, "CONJ", m, genie_conj_mp_complex); m = a68_proc (M_LONG_COMPLEX, M_LONG_COMPLEX, M_LONG_COMPLEX, NO_MOID); a68_op (A68_STD, "+", m, genie_add_mp_complex); a68_op (A68_STD, "-", m, genie_sub_mp_complex); a68_op (A68_STD, "*", m, genie_mul_mp_complex); a68_op (A68_STD, "/", m, genie_div_mp_complex); m = a68_proc (M_LONG_COMPLEX, M_LONG_COMPLEX, M_INT, NO_MOID); a68_op (A68_STD, "**", m, genie_pow_mp_complex_int); a68_op (A68_STD, "UP", m, genie_pow_mp_complex_int); a68_op (A68_STD, "^", m, genie_pow_mp_complex_int); m = a68_proc (M_BOOL, M_LONG_COMPLEX, M_LONG_COMPLEX, NO_MOID); a68_op (A68_STD, "=", m, genie_eq_mp_complex); a68_op (A68_STD, "EQ", m, genie_eq_mp_complex); a68_op (A68_STD, "/=", m, genie_ne_mp_complex); a68_op (A68_STD, "~=", m, genie_ne_mp_complex); a68_op (A68_STD, "^=", m, genie_ne_mp_complex); a68_op (A68_STD, "NE", m, genie_ne_mp_complex); m = a68_proc (M_REF_LONG_COMPLEX, M_REF_LONG_COMPLEX, M_LONG_COMPLEX, NO_MOID); a68_op (A68_STD, "+:=", m, genie_plusab_mp_complex); a68_op (A68_STD, "-:=", m, genie_minusab_mp_complex); a68_op (A68_STD, "*:=", m, genie_timesab_mp_complex); a68_op (A68_STD, "/:=", m, genie_divab_mp_complex); a68_op (A68_STD, "PLUSAB", m, genie_plusab_mp_complex); a68_op (A68_STD, "MINUSAB", m, genie_minusab_mp_complex); a68_op (A68_STD, "TIMESAB", m, genie_timesab_mp_complex); a68_op (A68_STD, "DIVAB", m, genie_divab_mp_complex); m = a68_proc (M_LONG_COMPLEX, M_LONG_COMPLEX, NO_MOID); a68_idf (A68_EXT, "dcacos", m, genie_acos_mp_complex); a68_idf (A68_EXT, "dcasin", m, genie_asin_mp_complex); a68_idf (A68_EXT, "dcatan", m, genie_atan_mp_complex); a68_idf (A68_EXT, "dccos", m, genie_cos_mp_complex); a68_idf (A68_EXT, "dcexp", m, genie_exp_mp_complex); a68_idf (A68_EXT, "dcln", m, genie_ln_mp_complex); a68_idf (A68_EXT, "dcsin", m, genie_sin_mp_complex); a68_idf (A68_EXT, "dcsqrt", m, genie_sqrt_mp_complex); a68_idf (A68_EXT, "dctan", m, genie_tan_mp_complex); a68_idf (A68_EXT, "longcomplexarccos", m, genie_acos_mp_complex); a68_idf (A68_EXT, "longcomplexarcsin", m, genie_asin_mp_complex); a68_idf (A68_EXT, "longcomplexarctan", m, genie_atan_mp_complex); a68_idf (A68_EXT, "longcomplexcos", m, genie_cos_mp_complex); a68_idf (A68_EXT, "longcomplexexp", m, genie_exp_mp_complex); a68_idf (A68_EXT, "longcomplexln", m, genie_ln_mp_complex); a68_idf (A68_EXT, "longcomplexsin", m, genie_sin_mp_complex); a68_idf (A68_EXT, "longcomplexsqrt", m, genie_sqrt_mp_complex); a68_idf (A68_EXT, "longcomplextan", m, genie_tan_mp_complex); // LONG BITS in software m = a68_proc (M_LONG_BITS, M_ROW_BOOL, NO_MOID); a68_idf (A68_STD, "longbitspack", m, genie_long_bits_pack); m = a68_proc (M_LONG_INT, M_LONG_BITS, NO_MOID); a68_op (A68_STD, "ABS", m, genie_idle); m = a68_proc (M_LONG_BITS, M_LONG_INT, NO_MOID); a68_op (A68_STD, "BIN", m, genie_bin_mp); m = a68_proc (M_BITS, M_LONG_BITS, NO_MOID); a68_op (A68_STD, "SHORTEN", m, genie_shorten_mp_to_bits); m = a68_proc (M_LONG_BITS, M_BITS, NO_MOID); a68_op (A68_STD, "LENG", m, genie_lengthen_unt_to_mp); m = a68_proc (M_LONG_BITS, M_LONG_BITS, NO_MOID); a68_op (A68_STD, "NOT", m, genie_not_mp); a68_op (A68_STD, "~", m, genie_not_mp); m = a68_proc (M_BOOL, M_LONG_BITS, M_LONG_BITS, NO_MOID); a68_op (A68_STD, "=", m, genie_eq_mp); a68_op (A68_STD, "EQ", m, genie_eq_mp); a68_op (A68_STD, "/=", m, genie_ne_mp); a68_op (A68_STD, "~=", m, genie_ne_mp); a68_op (A68_STD, "^=", m, genie_ne_mp); a68_op (A68_STD, "NE", m, genie_ne_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 (M_LONG_BITS, M_LONG_BITS, M_LONG_BITS, NO_MOID); a68_op (A68_STD, "AND", m, genie_and_mp); a68_op (A68_STD, "&", m, genie_and_mp); a68_op (A68_STD, "OR", m, genie_or_mp); a68_op (A68_EXT, "XOR", m, genie_xor_mp); m = a68_proc (M_LONG_BITS, M_LONG_BITS, M_INT, NO_MOID); a68_op (A68_STD, "SHL", m, genie_shl_mp); a68_op (A68_STD, "UP", m, genie_shl_mp); a68_op (A68_STD, "SHR", m, genie_shr_mp); a68_op (A68_STD, "DOWN", m, genie_shr_mp); m = a68_proc (M_BOOL, M_INT, M_LONG_BITS, NO_MOID); a68_op (A68_STD, "ELEM", m, genie_elem_long_bits); m = a68_proc (M_LONG_BITS, M_INT, M_LONG_BITS, NO_MOID); a68_op (A68_STD, "SET", m, genie_set_long_bits); a68_op (A68_STD, "CLEAR", m, genie_clear_long_bits); #endif } void stand_mp_level_3 (void) { #if (A68_LEVEL >= 3) MOID_T *m; a68_idf (A68_STD, "dpi", M_LONG_REAL, genie_pi_double); a68_idf (A68_STD, "longpi", M_LONG_REAL, genie_pi_double); a68_idf (A68_STD, "longmaxbits", M_LONG_BITS, genie_double_max_bits); a68_idf (A68_STD, "longmaxint", M_LONG_INT, genie_double_max_int); a68_idf (A68_STD, "longsmallreal", M_LONG_REAL, genie_double_small_real); a68_idf (A68_STD, "longmaxreal", M_LONG_REAL, genie_double_max_real); a68_idf (A68_STD, "longminreal", M_LONG_REAL, genie_double_min_real); a68_idf (A68_STD, "longinfinity", M_LONG_REAL, genie_infinity_real_16); a68_idf (A68_STD, "longminusinfinity", M_LONG_REAL, genie_minus_infinity_real_16); a68_idf (A68_STD, "longinf", M_LONG_REAL, genie_infinity_real_16); a68_idf (A68_STD, "longmininf", M_LONG_REAL, genie_minus_infinity_real_16); // LONG INT as 128 bit m = a68_proc (M_LONG_INT, M_LONG_INT, NO_MOID); a68_op (A68_STD, "+", m, genie_idle); a68_op (A68_STD, "-", m, genie_minus_int_16); a68_op (A68_STD, "ABS", m, genie_abs_int_16); m = a68_proc (M_LONG_INT, M_INT, NO_MOID); a68_op (A68_STD, "LENG", m, genie_lengthen_int_to_int_16); m = a68_proc (M_LONG_LONG_INT, M_LONG_INT, NO_MOID); a68_op (A68_STD, "LENG", m, genie_lengthen_int_16_to_mp); m = a68_proc (M_INT, M_LONG_INT, NO_MOID); a68_op (A68_STD, "SHORTEN", m, genie_shorten_long_int_to_int); a68_op (A68_STD, "SIGN", m, genie_sign_int_16); m = a68_proc (M_BOOL, M_LONG_INT, NO_MOID); a68_op (A68_STD, "ODD", m, genie_odd_int_16); m = a68_proc (M_LONG_INT, M_LONG_REAL, NO_MOID); a68_op (A68_STD, "ENTIER", m, genie_entier_real_16); a68_op (A68_STD, "ROUND", m, genie_round_real_16); m = a68_proc (M_LONG_INT, M_LONG_INT, M_LONG_INT, NO_MOID); a68_op (A68_STD, "+", m, genie_add_int_16); a68_op (A68_STD, "-", m, genie_sub_int_16); a68_op (A68_STD, "*", m, genie_mul_int_16); a68_op (A68_STD, "OVER", m, genie_over_int_16); a68_op (A68_STD, "%", m, genie_over_int_16); a68_op (A68_STD, "MOD", m, genie_mod_int_16); a68_op (A68_STD, "%*", m, genie_mod_int_16); m = a68_proc (M_LONG_INT, M_LONG_INT, M_INT, NO_MOID); a68_op (A68_STD, "**", m, genie_pow_int_16_int); a68_op (A68_STD, "^", m, genie_pow_int_16_int); m = a68_proc (M_REF_LONG_INT, M_REF_LONG_INT, M_LONG_INT, NO_MOID); a68_op (A68_STD, "+:=", m, genie_plusab_int_16); a68_op (A68_STD, "-:=", m, genie_minusab_int_16); a68_op (A68_STD, "*:=", m, genie_timesab_int_16); a68_op (A68_STD, "%:=", m, genie_overab_int_16); a68_op (A68_STD, "%*:=", m, genie_modab_int_16); a68_op (A68_STD, "PLUSAB", m, genie_plusab_int_16); a68_op (A68_STD, "MINUSAB", m, genie_minusab_int_16); a68_op (A68_STD, "TIMESAB", m, genie_timesab_int_16); a68_op (A68_STD, "OVERAB", m, genie_overab_int_16); a68_op (A68_STD, "MODAB", m, genie_modab_int_16); m = a68_proc (M_LONG_REAL, M_LONG_INT, M_LONG_INT, NO_MOID); a68_op (A68_STD, "/", m, genie_div_int_16); m = a68_proc (M_BOOL, M_LONG_INT, M_LONG_INT, NO_MOID); a68_op (A68_STD, "=", m, genie_eq_int_16); a68_op (A68_STD, "EQ", m, genie_eq_int_16); a68_op (A68_STD, "/=", m, genie_ne_int_16); a68_op (A68_STD, "~=", m, genie_ne_int_16); a68_op (A68_STD, "^=", m, genie_ne_int_16); a68_op (A68_STD, "NE", m, genie_ne_int_16); a68_op (A68_STD, "<", m, genie_lt_int_16); a68_op (A68_STD, "LT", m, genie_lt_int_16); a68_op (A68_STD, "<=", m, genie_le_int_16); a68_op (A68_STD, "LE", m, genie_le_int_16); a68_op (A68_STD, ">", m, genie_gt_int_16); a68_op (A68_STD, "GT", m, genie_gt_int_16); a68_op (A68_STD, ">=", m, genie_ge_int_16); a68_op (A68_STD, "GE", m, genie_ge_int_16); // LONG REAL as 128 bit m = a68_proc (M_LONG_REAL, M_LONG_REAL, NO_MOID); a68_op (A68_STD, "+", m, genie_idle); a68_op (A68_STD, "-", m, genie_minus_real_16); a68_op (A68_STD, "ABS", m, genie_abs_real_16); m = a68_proc (M_INT, M_LONG_REAL, NO_MOID); a68_op (A68_STD, "SIGN", m, genie_sign_real_16); m = a68_proc (M_LONG_REAL, M_LONG_REAL, M_LONG_REAL, NO_MOID); a68_op (A68_STD, "+", m, genie_add_real_16); a68_op (A68_STD, "-", m, genie_sub_real_16); a68_op (A68_STD, "*", m, genie_mul_real_16); a68_op (A68_STD, "/", m, genie_over_real_16); a68_op (A68_STD, "**", m, genie_pow_real_16); a68_op (A68_STD, "UP", m, genie_pow_real_16); a68_op (A68_STD, "^", m, genie_pow_real_16); m = a68_proc (M_LONG_REAL, M_LONG_REAL, M_INT, NO_MOID); a68_op (A68_STD, "**", m, genie_pow_real_16_int); a68_op (A68_STD, "UP", m, genie_pow_real_16_int); a68_op (A68_STD, "^", m, genie_pow_real_16_int); m = a68_proc (M_LONG_REAL, M_REAL, NO_MOID); a68_op (A68_STD, "LENG", m, genie_lengthen_real_to_real_16); m = a68_proc (M_REAL, M_LONG_REAL, NO_MOID); a68_op (A68_STD, "SHORTEN", m, genie_shorten_real_16_to_real); m = a68_proc (M_LONG_LONG_REAL, M_LONG_REAL, NO_MOID); a68_op (A68_STD, "LENG", m, genie_lengthen_real_16_to_mp); m = a68_proc (M_LONG_REAL, M_LONG_LONG_REAL, NO_MOID); a68_op (A68_STD, "SHORTEN", m, genie_shorten_mp_to_real_16); m = a68_proc (M_LONG_INT, M_LONG_LONG_INT, NO_MOID); a68_op (A68_STD, "SHORTEN", m, genie_shorten_mp_to_int_16); m = a68_proc (M_REF_LONG_REAL, M_REF_LONG_REAL, M_LONG_REAL, NO_MOID); a68_op (A68_STD, "+:=", m, genie_plusab_real_16); a68_op (A68_STD, "-:=", m, genie_minusab_real_16); a68_op (A68_STD, "*:=", m, genie_timesab_real_16); a68_op (A68_STD, "/:=", m, genie_divab_real_16); a68_op (A68_STD, "PLUSAB", m, genie_plusab_real_16); a68_op (A68_STD, "MINUSAB", m, genie_minusab_real_16); a68_op (A68_STD, "TIMESAB", m, genie_timesab_real_16); a68_op (A68_STD, "DIVAB", m, genie_divab_real_16); m = a68_proc (M_BOOL, M_LONG_REAL, M_LONG_REAL, NO_MOID); a68_op (A68_STD, "=", m, genie_eq_real_16); a68_op (A68_STD, "EQ", m, genie_eq_real_16); a68_op (A68_STD, "/=", m, genie_ne_real_16); a68_op (A68_STD, "~=", m, genie_ne_real_16); a68_op (A68_STD, "^=", m, genie_ne_real_16); a68_op (A68_STD, "NE", m, genie_ne_real_16); a68_op (A68_STD, "<", m, genie_lt_real_16); a68_op (A68_STD, "LT", m, genie_lt_real_16); a68_op (A68_STD, "<=", m, genie_le_real_16); a68_op (A68_STD, "LE", m, genie_le_real_16); a68_op (A68_STD, ">", m, genie_gt_real_16); a68_op (A68_STD, "GT", m, genie_gt_real_16); a68_op (A68_STD, ">=", m, genie_ge_real_16); a68_op (A68_STD, "GE", m, genie_ge_real_16); m = a68_proc (M_LONG_REAL, M_LONG_REAL, NO_MOID); a68_idf (A68_EXT, "dacosdg", m, genie_acosdg_real_16); a68_idf (A68_EXT, "dacosh", m, genie_acosh_real_16); a68_idf (A68_EXT, "dacos", m, genie_acos_real_16); a68_idf (A68_EXT, "dacotdg", m, genie_acotdg_real_16); a68_idf (A68_EXT, "dacot", m, genie_acot_real_16); a68_idf (A68_EXT, "dacsc", m, genie_acsc_real_16); a68_idf (A68_EXT, "dasec", m, genie_asec_real_16); a68_idf (A68_EXT, "dasindg", m, genie_asindg_real_16); a68_idf (A68_EXT, "dasinh", m, genie_asinh_real_16); a68_idf (A68_EXT, "dasin", m, genie_asin_real_16); a68_idf (A68_EXT, "datandg", m, genie_atandg_real_16); a68_idf (A68_EXT, "datanh", m, genie_atanh_real_16); a68_idf (A68_EXT, "datan", m, genie_atan_real_16); a68_idf (A68_EXT, "dcbrt", m, genie_curt_real_16); a68_idf (A68_EXT, "dcosdg", m, genie_cosdg_real_16); a68_idf (A68_EXT, "dcosh", m, genie_cosh_real_16); a68_idf (A68_EXT, "dcos", m, genie_cos_real_16); a68_idf (A68_EXT, "dcospi", m, genie_cospi_real_16); a68_idf (A68_EXT, "dcotdg", m, genie_cotdg_real_16); a68_idf (A68_EXT, "dcot", m, genie_cot_real_16); a68_idf (A68_EXT, "dcotpi", m, genie_cotpi_real_16); a68_idf (A68_EXT, "dcsc", m, genie_csc_real_16); a68_idf (A68_EXT, "dcurt", m, genie_curt_real_16); a68_idf (A68_EXT, "derfc", m, genie_erfc_real_16); a68_idf (A68_EXT, "derf", m, genie_erf_real_16); a68_idf (A68_EXT, "dexp", m, genie_exp_real_16); a68_idf (A68_EXT, "dinverfc", m, genie_inverfc_real_16); a68_idf (A68_EXT, "dinverf", m, genie_inverf_real_16); a68_idf (A68_EXT, "dgamma", m, genie_gamma_real_16); a68_idf (A68_EXT, "dlngamma", m, genie_lngamma_real_16); a68_idf (A68_EXT, "dln", m, genie_ln_real_16); a68_idf (A68_EXT, "dlog", m, genie_log_real_16); a68_idf (A68_EXT, "dsec", m, genie_sec_real_16); a68_idf (A68_EXT, "dsindg", m, genie_sindg_real_16); a68_idf (A68_EXT, "dsinh", m, genie_sinh_real_16); a68_idf (A68_EXT, "dsin", m, genie_sin_real_16); a68_idf (A68_EXT, "dsinpi", m, genie_sinpi_real_16); a68_idf (A68_EXT, "dsqrt", m, genie_sqrt_real_16); a68_idf (A68_EXT, "dtandg", m, genie_tandg_real_16); a68_idf (A68_EXT, "dtanh", m, genie_tanh_real_16); a68_idf (A68_EXT, "dtan", m, genie_tan_real_16); a68_idf (A68_EXT, "dtanpi", m, genie_tanpi_real_16); a68_idf (A68_EXT, "longarccosdg", m, genie_acosdg_real_16); a68_idf (A68_EXT, "longarccosh", m, genie_acosh_real_16); a68_idf (A68_EXT, "longarccotdg", m, genie_acotdg_real_16); a68_idf (A68_EXT, "longarccot", m, genie_acot_real_16); a68_idf (A68_EXT, "longarccsc", m, genie_acsc_real_16); a68_idf (A68_EXT, "longarcsec", m, genie_asec_real_16); a68_idf (A68_EXT, "longarcsindg", m, genie_asindg_real_16); a68_idf (A68_EXT, "longarcsinh", m, genie_asinh_real_16); a68_idf (A68_EXT, "longarctandg", m, genie_atandg_real_16); a68_idf (A68_EXT, "longarctanh", m, genie_atanh_real_16); a68_idf (A68_EXT, "longcbrt", m, genie_curt_real_16); a68_idf (A68_EXT, "longcosdg", m, genie_cosdg_real_16); a68_idf (A68_EXT, "longcosh", m, genie_cosh_real_16); a68_idf (A68_EXT, "longcospi", m, genie_cospi_real_16); a68_idf (A68_EXT, "longcotdg", m, genie_cotdg_real_16); a68_idf (A68_EXT, "longcot", m, genie_cot_real_16); a68_idf (A68_EXT, "longcotpi", m, genie_cotpi_real_16); a68_idf (A68_EXT, "longcsc", m, genie_csc_real_16); a68_idf (A68_EXT, "longcurt", m, genie_curt_real_16); a68_idf (A68_EXT, "longerfc", m, genie_erfc_real_16); a68_idf (A68_EXT, "longerf", m, genie_erf_real_16); a68_idf (A68_EXT, "longinverfc", m, genie_inverfc_real_16); a68_idf (A68_EXT, "longinverf", m, genie_inverf_real_16); a68_idf (A68_EXT, "longgamma", m, genie_gamma_real_16); a68_idf (A68_EXT, "longlngamma", m, genie_lngamma_real_16); a68_idf (A68_EXT, "longsec", m, genie_sec_real_16); a68_idf (A68_EXT, "longsindg", m, genie_sindg_real_16); a68_idf (A68_EXT, "longsinh", m, genie_sinh_real_16); a68_idf (A68_EXT, "longsinpi", m, genie_sinpi_real_16); a68_idf (A68_EXT, "longtandg", m, genie_tandg_real_16); a68_idf (A68_EXT, "longtanh", m, genie_tanh_real_16); a68_idf (A68_EXT, "longtanpi", m, genie_tanpi_real_16); a68_idf (A68_STD, "longarccos", m, genie_acos_real_16); a68_idf (A68_STD, "longarcsin", m, genie_asin_real_16); a68_idf (A68_STD, "longarctan", m, genie_atan_real_16); a68_idf (A68_STD, "longcos", m, genie_cos_real_16); a68_idf (A68_STD, "longexp", m, genie_exp_real_16); a68_idf (A68_STD, "longln", m, genie_ln_real_16); a68_idf (A68_STD, "longlog", m, genie_log_real_16); a68_idf (A68_STD, "longsin", m, genie_sin_real_16); a68_idf (A68_STD, "longsqrt", m, genie_sqrt_real_16); a68_idf (A68_STD, "longtan", m, genie_tan_real_16); m = a68_proc (M_LONG_REAL, NO_MOID); a68_idf (A68_STD, "longnextrandom", m, genie_next_random_real_16); a68_idf (A68_STD, "longrandom", m, genie_next_random_real_16); m = a68_proc (M_LONG_REAL, M_LONG_REAL, M_LONG_REAL, NO_MOID); a68_idf (A68_EXT, "darctan2dg", m, genie_atan2dg_real_16); a68_idf (A68_EXT, "darctan2", m, genie_atan2_real_16); a68_idf (A68_EXT, "dbeta", m, genie_beta_real_16); a68_idf (A68_EXT, "dgammaincgf", m, genie_gamma_inc_gf_real_16); a68_idf (A68_EXT, "dgammaincf", m, genie_gamma_inc_f_real_16); a68_idf (A68_EXT, "dgammainc", m, genie_gamma_inc_h_real_16); a68_idf (A68_EXT, "dlnbeta", m, genie_ln_beta_real_16); a68_idf (A68_EXT, "longarctan2dg", m, genie_atan2dg_real_16); a68_idf (A68_EXT, "longarctan2", m, genie_atan2_real_16); a68_idf (A68_EXT, "longbeta", m, genie_beta_real_16); a68_idf (A68_EXT, "longgammaincgf", m, genie_gamma_inc_gf_real_16); a68_idf (A68_EXT, "longgammaincf", m, genie_gamma_inc_f_real_16); a68_idf (A68_EXT, "longgammainc", m, genie_gamma_inc_h_real_16); a68_idf (A68_EXT, "longlnbeta", m, genie_ln_beta_real_16); m = a68_proc (M_LONG_REAL, M_LONG_REAL, M_LONG_REAL, M_LONG_REAL, NO_MOID); a68_idf (A68_EXT, "longbetainc", m, genie_beta_inc_cf_real_16); a68_idf (A68_EXT, "dbetainc", m, genie_beta_inc_cf_real_16); m = a68_proc (M_LONG_REAL, M_LONG_REAL, M_LONG_REAL, M_LONG_REAL, M_LONG_REAL, NO_MOID); a68_idf (A68_EXT, "longgammaincg", m, genie_gamma_inc_g_real_16); a68_idf (A68_EXT, "dgammaincg", m, genie_gamma_inc_g_real_16); // LONG BITS as 128 bit m = a68_proc (M_LONG_BITS, M_ROW_BOOL, NO_MOID); a68_idf (A68_STD, "longbitspack", m, genie_double_bits_pack); m = a68_proc (M_BITS, M_LONG_BITS, NO_MOID); a68_op (A68_STD, "SHORTEN", m, genie_shorten_double_bits_to_bits); m = a68_proc (M_LONG_BITS, M_BITS, NO_MOID); a68_op (A68_STD, "LENG", m, genie_lengthen_bits_to_double_bits); m = a68_proc (M_LONG_INT, M_LONG_BITS, NO_MOID); a68_op (A68_STD, "ABS", m, genie_idle); m = a68_proc (M_LONG_BITS, M_LONG_INT, NO_MOID); a68_op (A68_STD, "BIN", m, genie_bin_int_16); m = a68_proc (M_LONG_BITS, M_LONG_BITS, NO_MOID); a68_op (A68_STD, "NOT", m, genie_not_double_bits); a68_op (A68_STD, "~", m, genie_not_double_bits); m = a68_proc (M_LONG_BITS, M_LONG_BITS, M_LONG_BITS, NO_MOID); a68_op (A68_STD, "AND", m, genie_and_double_bits); a68_op (A68_STD, "&", m, genie_and_double_bits); a68_op (A68_STD, "OR", m, genie_or_double_bits); a68_op (A68_EXT, "XOR", m, genie_xor_double_bits); a68_op (A68_EXT, "+", m, genie_add_double_bits); a68_op (A68_EXT, "-", m, genie_sub_double_bits); a68_op (A68_EXT, "*", m, genie_times_double_bits); a68_op (A68_EXT, "OVER", m, genie_over_double_bits); a68_op (A68_EXT, "MOD", m, genie_over_double_bits); m = a68_proc (M_BOOL, M_LONG_BITS, M_LONG_BITS, NO_MOID); a68_op (A68_STD, "=", m, genie_eq_double_bits); a68_op (A68_STD, "/=", m, genie_ne_double_bits); a68_op (A68_STD, "~=", m, genie_ne_double_bits); a68_op (A68_STD, "^=", m, genie_ne_double_bits); a68_op (A68_STD, "<=", m, genie_le_double_bits); a68_op (A68_STD, ">=", m, genie_ge_double_bits); a68_op (A68_STD, "EQ", m, genie_eq_double_bits); a68_op (A68_STD, "NE", m, genie_ne_double_bits); a68_op (A68_STD, "LE", m, genie_le_double_bits); a68_op (A68_STD, "GE", m, genie_ge_double_bits); a68_op (A68_EXT, "<", m, genie_lt_double_bits); a68_op (A68_EXT, ">", m, genie_gt_double_bits); a68_op (A68_EXT, "LT", m, genie_lt_double_bits); a68_op (A68_EXT, "GT", m, genie_gt_double_bits); m = a68_proc (M_BOOL, M_INT, M_LONG_BITS, NO_MOID); a68_op (A68_STD, "ELEM", m, genie_elem_double_bits); m = a68_proc (M_LONG_BITS, M_INT, M_LONG_BITS, NO_MOID); a68_op (A68_STD, "SET", m, genie_set_double_bits); a68_op (A68_STD, "CLEAR", m, genie_clear_double_bits); m = a68_proc (M_LONG_BITS, M_LONG_BITS, M_INT, NO_MOID); a68_op (A68_STD, "SHL", m, genie_shl_double_bits); a68_op (A68_STD, "UP", m, genie_shl_double_bits); a68_op (A68_STD, "SHR", m, genie_shr_double_bits); a68_op (A68_STD, "DOWN", m, genie_shr_double_bits); a68_op (A68_EXT, "ROL", m, genie_rol_double_bits); a68_op (A68_EXT, "ROR", m, genie_ror_double_bits); // LONG COMPLEX as 2 x 128 bit. m = a68_proc (M_LONG_COMPLEX, M_COMPLEX, NO_MOID); a68_op (A68_STD, "LENG", m, genie_lengthen_complex_to_complex_32); m = a68_proc (M_LONG_LONG_COMPLEX, M_LONG_COMPLEX, NO_MOID); a68_op (A68_STD, "LENG", m, genie_lengthen_complex_32_to_long_mp_complex); m = a68_proc (M_COMPLEX, M_LONG_COMPLEX, NO_MOID); a68_op (A68_STD, "SHORTEN", m, genie_shorten_complex_32_to_complex); m = a68_proc (M_LONG_COMPLEX, M_LONG_REAL, M_LONG_REAL, NO_MOID); a68_op (A68_STD, "I", m, genie_i_complex_32); a68_op (A68_STD, "+*", m, genie_i_complex_32); m = a68_proc (M_LONG_COMPLEX, M_LONG_INT, M_LONG_INT, NO_MOID); a68_op (A68_STD, "I", m, genie_i_int_complex_32); a68_op (A68_STD, "+*", m, genie_i_int_complex_32); m = a68_proc (M_LONG_REAL, M_LONG_COMPLEX, NO_MOID); a68_op (A68_STD, "RE", m, genie_re_complex_32); a68_op (A68_STD, "IM", m, genie_im_complex_32); a68_op (A68_STD, "ABS", m, genie_abs_complex_32); a68_op (A68_STD, "ARG", m, genie_arg_complex_32); m = a68_proc (M_LONG_COMPLEX, M_LONG_COMPLEX, NO_MOID); a68_op (A68_STD, "+", m, genie_idle); a68_op (A68_STD, "-", m, genie_minus_complex_32); a68_op (A68_STD, "CONJ", m, genie_conj_complex_32); m = a68_proc (M_BOOL, M_LONG_COMPLEX, M_LONG_COMPLEX, NO_MOID); a68_op (A68_STD, "=", m, genie_eq_complex_32); a68_op (A68_STD, "/=", m, genie_ne_complex_32); a68_op (A68_STD, "~=", m, genie_ne_complex_32); a68_op (A68_STD, "^=", m, genie_ne_complex_32); a68_op (A68_STD, "EQ", m, genie_eq_complex_32); a68_op (A68_STD, "NE", m, genie_ne_complex_32); m = a68_proc (M_LONG_COMPLEX, M_LONG_COMPLEX, M_LONG_COMPLEX, NO_MOID); a68_op (A68_STD, "+", m, genie_add_complex_32); a68_op (A68_STD, "-", m, genie_sub_complex_32); a68_op (A68_STD, "*", m, genie_mul_complex_32); a68_op (A68_STD, "/", m, genie_div_complex_32); m = a68_proc (M_LONG_COMPLEX, M_LONG_COMPLEX, M_INT, NO_MOID); a68_op (A68_STD, "**", m, genie_pow_complex_32_int); a68_op (A68_STD, "UP", m, genie_pow_complex_32_int); a68_op (A68_STD, "^", m, genie_pow_complex_32_int); m = a68_proc (M_REF_LONG_COMPLEX, M_REF_LONG_COMPLEX, M_LONG_COMPLEX, NO_MOID); a68_op (A68_STD, "+:=", m, genie_plusab_complex_32); a68_op (A68_STD, "-:=", m, genie_minusab_complex_32); a68_op (A68_STD, "*:=", m, genie_timesab_complex_32); a68_op (A68_STD, "/:=", m, genie_divab_complex_32); a68_op (A68_STD, "PLUSAB", m, genie_plusab_complex_32); a68_op (A68_STD, "MINUSAB", m, genie_minusab_complex_32); a68_op (A68_STD, "TIMESAB", m, genie_timesab_complex_32); a68_op (A68_STD, "DIVAB", m, genie_divab_complex_32); m = a68_proc (M_LONG_COMPLEX, M_LONG_COMPLEX, NO_MOID); a68_idf (A68_EXT, "dcacosh", m, genie_acosh_complex_32); a68_idf (A68_EXT, "dcacos", m, genie_acos_complex_32); a68_idf (A68_EXT, "dcarccosh", m, genie_acosh_complex_32); a68_idf (A68_EXT, "dcarccos", m, genie_acos_complex_32); a68_idf (A68_EXT, "dcarcsinh", m, genie_asinh_complex_32); a68_idf (A68_EXT, "dcarcsin", m, genie_asin_complex_32); a68_idf (A68_EXT, "dcarctanh", m, genie_atanh_complex_32); a68_idf (A68_EXT, "dcarctan", m, genie_atan_complex_32); a68_idf (A68_EXT, "dcasinh", m, genie_asinh_complex_32); a68_idf (A68_EXT, "dcasin", m, genie_asin_complex_32); a68_idf (A68_EXT, "dcatanh", m, genie_atanh_complex_32); a68_idf (A68_EXT, "dcatan", m, genie_atan_complex_32); a68_idf (A68_EXT, "dccosh", m, genie_cosh_complex_32); a68_idf (A68_EXT, "dccos", m, genie_cos_complex_32); a68_idf (A68_EXT, "dcexp", m, genie_exp_complex_32); a68_idf (A68_EXT, "dcln", m, genie_ln_complex_32); a68_idf (A68_EXT, "dcomplexacosh", m, genie_acosh_complex_32); a68_idf (A68_EXT, "dcomplexacos", m, genie_acos_complex_32); a68_idf (A68_EXT, "dcomplexarccosh", m, genie_acosh_complex_32); a68_idf (A68_EXT, "dcomplexarccos", m, genie_acos_complex_32); a68_idf (A68_EXT, "dcomplexarcsinh", m, genie_asinh_complex_32); a68_idf (A68_EXT, "dcomplexarcsin", m, genie_asin_complex_32); a68_idf (A68_EXT, "dcomplexarctanh", m, genie_atanh_complex_32); a68_idf (A68_EXT, "dcomplexarctan", m, genie_atan_complex_32); a68_idf (A68_EXT, "dcomplexasinh", m, genie_asinh_complex_32); a68_idf (A68_EXT, "dcomplexasin", m, genie_asin_complex_32); a68_idf (A68_EXT, "dcomplexatanh", m, genie_atanh_complex_32); a68_idf (A68_EXT, "dcomplexatan", m, genie_atan_complex_32); a68_idf (A68_EXT, "dcomplexcosh", m, genie_cosh_complex_32); a68_idf (A68_EXT, "dcomplexcos", m, genie_cos_complex_32); a68_idf (A68_EXT, "dcomplexexp", m, genie_exp_complex_32); a68_idf (A68_EXT, "dcomplexln", m, genie_ln_complex_32); a68_idf (A68_EXT, "dcomplexsin", m, genie_sin_complex_32); a68_idf (A68_EXT, "dcomplexsqrt", m, genie_sqrt_complex_32); a68_idf (A68_EXT, "dcomplextanh", m, genie_tanh_complex_32); a68_idf (A68_EXT, "dcomplextan", m, genie_tan_complex_32); a68_idf (A68_EXT, "dcsinh", m, genie_sinh_complex_32); a68_idf (A68_EXT, "dcsin", m, genie_sin_complex_32); a68_idf (A68_EXT, "dcsqrt", m, genie_sqrt_complex_32); a68_idf (A68_EXT, "dctanh", m, genie_tanh_complex_32); a68_idf (A68_EXT, "dctan", m, genie_tan_complex_32); a68_idf (A68_EXT, "longcacosh", m, genie_acosh_complex_32); a68_idf (A68_EXT, "longcacos", m, genie_acos_complex_32); a68_idf (A68_EXT, "longcarccosh", m, genie_acosh_complex_32); a68_idf (A68_EXT, "longcarccos", m, genie_acos_complex_32); a68_idf (A68_EXT, "longcarcsinh", m, genie_asinh_complex_32); a68_idf (A68_EXT, "longcarcsin", m, genie_asin_complex_32); a68_idf (A68_EXT, "longcarctanh", m, genie_atanh_complex_32); a68_idf (A68_EXT, "longcarctan", m, genie_atan_complex_32); a68_idf (A68_EXT, "longcasinh", m, genie_asinh_complex_32); a68_idf (A68_EXT, "longcasin", m, genie_asin_complex_32); a68_idf (A68_EXT, "longcatanh", m, genie_atanh_complex_32); a68_idf (A68_EXT, "longcatan", m, genie_atan_complex_32); a68_idf (A68_EXT, "longccosh", m, genie_cosh_complex_32); a68_idf (A68_EXT, "longccos", m, genie_cos_complex_32); a68_idf (A68_EXT, "longcexp", m, genie_exp_complex_32); a68_idf (A68_EXT, "longcln", m, genie_ln_complex_32); a68_idf (A68_EXT, "longcomplexacosh", m, genie_acosh_complex_32); a68_idf (A68_EXT, "longcomplexacos", m, genie_acos_complex_32); a68_idf (A68_EXT, "longcomplexarccosh", m, genie_acosh_complex_32); a68_idf (A68_EXT, "longcomplexarccos", m, genie_acos_complex_32); a68_idf (A68_EXT, "longcomplexarcsinh", m, genie_asinh_complex_32); a68_idf (A68_EXT, "longcomplexarcsin", m, genie_asin_complex_32); a68_idf (A68_EXT, "longcomplexarctanh", m, genie_atanh_complex_32); a68_idf (A68_EXT, "longcomplexarctan", m, genie_atan_complex_32); a68_idf (A68_EXT, "longcomplexasinh", m, genie_asinh_complex_32); a68_idf (A68_EXT, "longcomplexasin", m, genie_asin_complex_32); a68_idf (A68_EXT, "longcomplexatanh", m, genie_atanh_complex_32); a68_idf (A68_EXT, "longcomplexatan", m, genie_atan_complex_32); a68_idf (A68_EXT, "longcomplexcosh", m, genie_cosh_complex_32); a68_idf (A68_EXT, "longcomplexcos", m, genie_cos_complex_32); a68_idf (A68_EXT, "longcomplexexp", m, genie_exp_complex_32); a68_idf (A68_EXT, "longcomplexln", m, genie_ln_complex_32); a68_idf (A68_EXT, "longcomplexsinh", m, genie_sinh_complex_32); a68_idf (A68_EXT, "longcomplexsin", m, genie_sin_complex_32); a68_idf (A68_EXT, "longcomplexsqrt", m, genie_sqrt_complex_32); a68_idf (A68_EXT, "longcomplextanh", m, genie_tanh_complex_32); a68_idf (A68_EXT, "longcomplextan", m, genie_tan_complex_32); a68_idf (A68_EXT, "longcsinh", m, genie_sinh_complex_32); a68_idf (A68_EXT, "longcsin", m, genie_sin_complex_32); a68_idf (A68_EXT, "longcsqrt", m, genie_sqrt_complex_32); a68_idf (A68_EXT, "longctanh", m, genie_tanh_complex_32); a68_idf (A68_EXT, "longctan", m, genie_tan_complex_32); #if defined (HAVE_GNU_MPFR) m = a68_proc (M_LONG_REAL, M_LONG_REAL, M_LONG_REAL, NO_MOID); a68_idf (A68_EXT, "mpfrlonggammainc", m, genie_gamma_inc_real_16_mpfr); a68_idf (A68_EXT, "mpfrdgammainc", m, genie_gamma_inc_real_16_mpfr); m = a68_proc (M_LONG_LONG_REAL, M_LONG_LONG_REAL, M_LONG_LONG_REAL, NO_MOID); a68_idf (A68_STD, "mpfrlonglongbeta", m, genie_beta_mpfr); a68_idf (A68_STD, "mpfrqbeta", m, genie_beta_mpfr); a68_idf (A68_STD, "mpfrlonglonglnbeta", m, genie_ln_beta_mpfr); a68_idf (A68_STD, "mpfrqlnbeta", m, genie_ln_beta_mpfr); a68_idf (A68_STD, "mpfrlonglonggammainc", m, genie_gamma_inc_mpfr); a68_idf (A68_STD, "mpfrqgammainc", m, genie_gamma_inc_mpfr); m = a68_proc (M_LONG_LONG_REAL, M_LONG_LONG_REAL, M_LONG_LONG_REAL, M_LONG_LONG_REAL, NO_MOID); a68_idf (A68_STD, "mpfrlonglongbetainc", m, genie_beta_inc_mpfr); a68_idf (A68_STD, "mpfrqbetainc", m, genie_beta_inc_mpfr); m = a68_proc (M_LONG_LONG_REAL, M_LONG_LONG_REAL, NO_MOID); a68_idf (A68_EXT, "mpfrlonglonggamma", m, genie_gamma_mpfr); a68_idf (A68_EXT, "mpfrlonglonglngamma", m, genie_lngamma_mpfr); a68_idf (A68_EXT, "mpfrlonglongerfc", m, genie_mpfr_erfc_mp); a68_idf (A68_EXT, "mpfrlonglongerf", m, genie_mpfr_erf_mp); a68_idf (A68_EXT, "mpfrlonglonginverfc", m, genie_mpfr_inverfc_mp); a68_idf (A68_EXT, "mpfrlonglonginverf", m, genie_mpfr_inverf_mp); a68_idf (A68_EXT, "mpfrlonglong", m, genie_mpfr_mp); a68_idf (A68_EXT, "mpfrqgamma", m, genie_gamma_mpfr); a68_idf (A68_EXT, "mpfrqlngamma", m, genie_lngamma_mpfr); a68_idf (A68_EXT, "mpfrqerfc", m, genie_mpfr_erfc_mp); a68_idf (A68_EXT, "mpfrqerf", m, genie_mpfr_erf_mp); a68_idf (A68_EXT, "mpfrqinverfc", m, genie_mpfr_inverfc_mp); a68_idf (A68_EXT, "mpfrqinverf", m, genie_mpfr_inverf_mp); a68_idf (A68_EXT, "mpfrq", m, genie_mpfr_mp); #endif #endif } void stand_transput (void) { MOID_T *m; a68_idf (A68_EXT, "blankcharacter", M_CHAR, genie_blank_char); a68_idf (A68_EXT, "formfeedcharacter", M_CHAR, genie_formfeed_char); a68_idf (A68_EXT, "formfeedchar", M_CHAR, genie_formfeed_char); a68_idf (A68_EXT, "newlinecharacter", M_CHAR, genie_newline_char); a68_idf (A68_EXT, "newlinechar", M_CHAR, genie_newline_char); a68_idf (A68_EXT, "nullcharacter", M_CHAR, genie_null_char); a68_idf (A68_EXT, "tabcharacter", M_CHAR, genie_tab_char); a68_idf (A68_EXT, "tabchar", M_CHAR, genie_tab_char); a68_idf (A68_STD, "blankchar", M_CHAR, genie_blank_char); a68_idf (A68_STD, "blank", M_CHAR, genie_blank_char); a68_idf (A68_STD, "errorchar", M_CHAR, genie_error_char); a68_idf (A68_STD, "expchar", M_CHAR, genie_exp_char); a68_idf (A68_STD, "flip", M_CHAR, genie_flip_char); a68_idf (A68_STD, "flop", M_CHAR, genie_flop_char); a68_idf (A68_STD, "nullchar", M_CHAR, genie_null_char); m = a68_proc (M_STRING, M_HEX_NUMBER, M_INT, M_INT, NO_MOID); a68_idf (A68_STD, "bits", m, genie_bits); m = a68_proc (M_STRING, M_NUMBER, M_INT, NO_MOID); a68_idf (A68_STD, "whole", m, genie_whole); m = a68_proc (M_STRING, M_NUMBER, M_INT, M_INT, NO_MOID); a68_idf (A68_STD, "fixed", m, genie_fixed); m = a68_proc (M_STRING, M_NUMBER, M_INT, M_INT, M_INT, NO_MOID); a68_idf (A68_STD, "float", m, genie_float); m = a68_proc (M_STRING, M_NUMBER, M_INT, M_INT, M_INT, M_INT, NO_MOID); a68_idf (A68_STD, "real", m, genie_real); a68_idf (A68_STD, "standin", M_REF_FILE, genie_stand_in); a68_idf (A68_STD, "standout", M_REF_FILE, genie_stand_out); a68_idf (A68_STD, "standback", M_REF_FILE, genie_stand_back); a68_idf (A68_EXT, "standerror", M_REF_FILE, genie_stand_error); a68_idf (A68_STD, "standinchannel", M_CHANNEL, genie_stand_in_channel); a68_idf (A68_STD, "standoutchannel", M_CHANNEL, genie_stand_out_channel); a68_idf (A68_EXT, "standdrawchannel", M_CHANNEL, genie_stand_draw_channel); a68_idf (A68_STD, "standbackchannel", M_CHANNEL, genie_stand_back_channel); a68_idf (A68_EXT, "standerrorchannel", M_CHANNEL, genie_stand_error_channel); m = a68_proc (M_VOID, M_REF_FILE, M_STRING, NO_MOID); a68_idf (A68_STD, "maketerm", m, genie_make_term); m = a68_proc (M_BOOL, M_CHAR, M_REF_INT, M_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 (M_BOOL, M_STRING, M_REF_INT, M_STRING, NO_MOID); a68_idf (A68_EXT, "stringinstring", m, genie_string_in_string); m = a68_proc (M_STRING, M_REF_FILE, NO_MOID); a68_idf (A68_EXT, "idf", m, genie_idf); a68_idf (A68_EXT, "term", m, genie_term); m = a68_proc (M_STRING, NO_MOID); a68_idf (A68_EXT, "programidf", m, genie_program_idf); // Event routines. m = a68_proc (M_VOID, M_REF_FILE, M_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_EXT, "drawpossible", M_PROC_REF_FILE_BOOL, genie_draw_possible); a68_idf (A68_EXT, "endoffile", M_PROC_REF_FILE_BOOL, genie_eof); a68_idf (A68_EXT, "endofline", M_PROC_REF_FILE_BOOL, genie_eoln); a68_idf (A68_EXT, "eof", M_PROC_REF_FILE_BOOL, genie_eof); a68_idf (A68_EXT, "eoln", M_PROC_REF_FILE_BOOL, genie_eoln); a68_idf (A68_EXT, "rewindpossible", M_PROC_REF_FILE_BOOL, genie_reset_possible); a68_idf (A68_STD, "binpossible", M_PROC_REF_FILE_BOOL, genie_bin_possible); a68_idf (A68_STD, "compressible", M_PROC_REF_FILE_BOOL, genie_compressible); a68_idf (A68_STD, "getpossible", M_PROC_REF_FILE_BOOL, genie_get_possible); a68_idf (A68_STD, "putpossible", M_PROC_REF_FILE_BOOL, genie_put_possible); a68_idf (A68_STD, "reidfpossible", M_PROC_REF_FILE_BOOL, genie_reidf_possible); a68_idf (A68_STD, "resetpossible", M_PROC_REF_FILE_BOOL, genie_reset_possible); a68_idf (A68_STD, "setpossible", M_PROC_REF_FILE_BOOL, genie_set_possible); // Handling of files. m = a68_proc (M_INT, M_REF_FILE, M_STRING, M_CHANNEL, NO_MOID); a68_idf (A68_STD, "open", m, genie_open); a68_idf (A68_STD, "establish", m, genie_establish); m = a68_proc (M_VOID, M_REF_FILE, M_REF_STRING, NO_MOID); a68_idf (A68_STD, "associate", m, genie_associate); m = a68_proc (M_INT, M_REF_FILE, M_CHANNEL, NO_MOID); a68_idf (A68_EXT, "rewind", M_PROC_REF_FILE_VOID, genie_reset); a68_idf (A68_STD, "backspace", M_PROC_REF_FILE_VOID, genie_backspace); a68_idf (A68_STD, "close", M_PROC_REF_FILE_VOID, genie_close); a68_idf (A68_STD, "create", m, genie_create); a68_idf (A68_STD, "erase", M_PROC_REF_FILE_VOID, genie_erase); a68_idf (A68_STD, "lock", M_PROC_REF_FILE_VOID, genie_lock); a68_idf (A68_STD, "newline", M_PROC_REF_FILE_VOID, genie_new_line); a68_idf (A68_STD, "newpage", M_PROC_REF_FILE_VOID, genie_new_page); a68_idf (A68_STD, "reset", M_PROC_REF_FILE_VOID, genie_reset); a68_idf (A68_STD, "scratch", M_PROC_REF_FILE_VOID, genie_erase); a68_idf (A68_STD, "space", M_PROC_REF_FILE_VOID, genie_space); m = a68_proc (M_INT, M_REF_FILE, M_INT, NO_MOID); a68_idf (A68_STD, "set", m, genie_set); a68_idf (A68_STD, "seek", m, genie_set); m = a68_proc (M_VOID, M_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 (M_VOID, M_ROW_SIMPLOUT, NO_MOID); a68_idf (A68_STD, "printbin", m, genie_write_bin); a68_idf (A68_STD, "printf", m, genie_write_format); a68_idf (A68_STD, "print", m, genie_write); a68_idf (A68_STD, "writebin", m, genie_write_bin); a68_idf (A68_STD, "writef", m, genie_write_format); a68_idf (A68_STD, "write", m, genie_write); m = a68_proc (M_VOID, M_REF_FILE, M_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 (M_VOID, M_REF_FILE, M_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); A68C_DEFIO (bits, bits, BITS); A68C_DEFIO (bool, bool, BOOL); A68C_DEFIO (char, char, CHAR); A68C_DEFIO (compl, complex, COMPLEX); A68C_DEFIO (complex, complex, COMPLEX); A68C_DEFIO (double, long_real, LONG_REAL); A68C_DEFIO (int, int, INT); A68C_DEFIO (longbits, long_bits, LONG_BITS); A68C_DEFIO (longcomplex, mp_complex, LONG_COMPLEX); A68C_DEFIO (longcompl, mp_complex, LONG_COMPLEX); A68C_DEFIO (longint, long_int, LONG_INT); A68C_DEFIO (longlongcomplex, long_mp_complex, LONG_LONG_COMPLEX); A68C_DEFIO (longlongcompl, long_mp_complex, LONG_LONG_COMPLEX); A68C_DEFIO (longlongint, long_mp_int, LONG_LONG_INT); A68C_DEFIO (longlongreal, long_mp_real, LONG_LONG_REAL); A68C_DEFIO (longreal, long_real, LONG_REAL); A68C_DEFIO (quad, long_mp_real, LONG_LONG_REAL); A68C_DEFIO (real, real, REAL); A68C_DEFIO (string, string, STRING); a68_idf (A68_EXT, "readline", M_PROC_STRING, genie_read_line); } //! @brief Set up standenv - extensions. void stand_extensions (void) { MOID_T *m = NO_MOID; // UNIX things. m = A68_MCACHE (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, "a68gargc", m, genie_a68_argc); a68_idf (A68_EXT, "errno", m, genie_errno); a68_idf (A68_EXT, "fork", m, genie_fork); m = a68_proc (M_STRING, NO_MOID); a68_idf (A68_EXT, "getpwd", m, genie_pwd); m = a68_proc (M_INT, M_STRING, NO_MOID); a68_idf (A68_EXT, "setpwd", m, genie_cd); m = a68_proc (M_BOOL, M_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_ISFIFO) a68_idf (A68_EXT, "fileisfifo", m, genie_file_is_fifo); #endif #if defined (S_ISLNK) a68_idf (A68_EXT, "fileislink", m, genie_file_is_link); #endif m = a68_proc (M_BITS, M_STRING, NO_MOID); a68_idf (A68_EXT, "filemode", m, genie_file_mode); m = a68_proc (M_STRING, M_INT, NO_MOID); a68_idf (A68_EXT, "argv", m, genie_argv); a68_idf (A68_EXT, "a68gargv", m, genie_a68_argv); a68_idf (A68_EXT, "reseterrno", A68_MCACHE (proc_void), genie_reset_errno); m = a68_proc (M_STRING, M_INT, NO_MOID); a68_idf (A68_EXT, "strerror", m, genie_strerror); m = a68_proc (M_INT, M_STRING, M_ROW_STRING, M_ROW_STRING, NO_MOID); a68_idf (A68_EXT, "exec", m, genie_exec); a68_idf (A68_EXT, "execve", m, genie_exec); m = a68_proc (M_PIPE, NO_MOID); a68_idf (A68_EXT, "createpipe", m, genie_create_pipe); m = a68_proc (M_INT, M_STRING, M_ROW_STRING, M_ROW_STRING, NO_MOID); a68_idf (A68_EXT, "execsub", m, genie_exec_sub); a68_idf (A68_EXT, "execvechild", m, genie_exec_sub); m = a68_proc (M_PIPE, M_STRING, M_ROW_STRING, M_ROW_STRING, NO_MOID); a68_idf (A68_EXT, "execsubpipeline", m, genie_exec_sub_pipeline); a68_idf (A68_EXT, "execvechildpipe", m, genie_exec_sub_pipeline); m = a68_proc (M_INT, M_STRING, M_ROW_STRING, M_ROW_STRING, M_REF_STRING, NO_MOID); a68_idf (A68_EXT, "execsuboutput", m, genie_exec_sub_output); a68_idf (A68_EXT, "execveoutput", m, genie_exec_sub_output); m = a68_proc (M_STRING, M_STRING, NO_MOID); a68_idf (A68_EXT, "getenv", m, genie_getenv); m = a68_proc (M_VOID, M_INT, NO_MOID); a68_idf (A68_EXT, "waitpid", m, genie_waitpid); m = a68_proc (M_ROW_INT, NO_MOID); a68_idf (A68_EXT, "utctime", m, genie_utctime); a68_idf (A68_EXT, "localtime", m, genie_localtime); m = a68_proc (M_INT, M_STRING, M_STRING, M_REF_INT, M_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 (M_INT, M_STRING, M_STRING, M_REF_STRING, NO_MOID); a68_idf (A68_EXT, "subinstring", m, genie_sub_in_string); #if defined (HAVE_DIRENT_H) m = a68_proc (M_ROW_STRING, M_STRING, NO_MOID); a68_idf (A68_EXT, "getdirectory", m, genie_directory); #endif #if defined (BUILD_HTTP) m = a68_proc (M_INT, M_REF_STRING, M_STRING, M_STRING, M_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_GNU_PLOTUTILS) void stand_plot (void) { MOID_T *m = NO_MOID; // Drawing. m = a68_proc (M_BOOL, M_REF_FILE, M_STRING, M_STRING, NO_MOID); a68_idf (A68_EXT, "drawdevice", m, genie_make_device); a68_idf (A68_EXT, "makedevice", m, genie_make_device); m = a68_proc (M_REAL, M_REF_FILE, NO_MOID); a68_idf (A68_EXT, "drawaspect", m, genie_draw_aspect); m = a68_proc (M_VOID, M_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 (M_VOID, M_REF_FILE, M_INT, NO_MOID); a68_idf (A68_EXT, "drawfillstyle", m, genie_draw_fillstyle); m = a68_proc (M_STRING, M_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 (M_VOID, M_REF_FILE, M_REAL, M_REAL, M_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 (M_VOID, M_REF_FILE, M_REAL, M_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 (M_VOID, M_REF_FILE, M_CHAR, M_CHAR, M_ROW_CHAR, NO_MOID); a68_idf (A68_EXT, "drawtext", m, genie_draw_text); m = a68_proc (M_VOID, M_REF_FILE, M_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 (M_VOID, M_REF_FILE, M_REAL, NO_MOID); a68_idf (A68_EXT, "drawlinewidth", m, genie_draw_linewidth); m = a68_proc (M_VOID, M_REF_FILE, M_INT, NO_MOID); a68_idf (A68_EXT, "drawfontsize", m, genie_draw_fontsize); a68_idf (A68_EXT, "drawtextangle", m, genie_draw_textangle); m = a68_proc (M_VOID, M_REF_FILE, M_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_CURSES) void stand_curses (void) { MOID_T *m; a68_idf (A68_EXT, "cursesstart", A68_MCACHE (proc_void), genie_curses_start); a68_idf (A68_EXT, "cursesend", A68_MCACHE (proc_void), genie_curses_end); a68_idf (A68_EXT, "cursesclear", A68_MCACHE (proc_void), genie_curses_clear); a68_idf (A68_EXT, "cursesrefresh", A68_MCACHE (proc_void), genie_curses_refresh); a68_idf (A68_EXT, "cursesgreen", A68_MCACHE (proc_void), genie_curses_green); a68_idf (A68_EXT, "cursescyan", A68_MCACHE (proc_void), genie_curses_cyan); a68_idf (A68_EXT, "cursesred", A68_MCACHE (proc_void), genie_curses_red); a68_idf (A68_EXT, "cursesyellow", A68_MCACHE (proc_void), genie_curses_yellow); a68_idf (A68_EXT, "cursesmagenta", A68_MCACHE (proc_void), genie_curses_magenta); a68_idf (A68_EXT, "cursesblue", A68_MCACHE (proc_void), genie_curses_blue); a68_idf (A68_EXT, "curseswhite", A68_MCACHE (proc_void), genie_curses_white); a68_idf (A68_EXT, "cursesgreeninverse", A68_MCACHE (proc_void), genie_curses_green_inverse); a68_idf (A68_EXT, "cursescyaninverse", A68_MCACHE (proc_void), genie_curses_cyan_inverse); a68_idf (A68_EXT, "cursesredinverse", A68_MCACHE (proc_void), genie_curses_red_inverse); a68_idf (A68_EXT, "cursesyellowinverse", A68_MCACHE (proc_void), genie_curses_yellow_inverse); a68_idf (A68_EXT, "cursesmagentainverse", A68_MCACHE (proc_void), genie_curses_magenta_inverse); a68_idf (A68_EXT, "cursesblueinverse", A68_MCACHE (proc_void), genie_curses_blue_inverse); a68_idf (A68_EXT, "curseswhiteinverse", A68_MCACHE (proc_void), genie_curses_white_inverse); m = A68_MCACHE (proc_char); a68_idf (A68_EXT, "cursesgetchar", m, genie_curses_getchar); m = a68_proc (M_VOID, M_CHAR, NO_MOID); a68_idf (A68_EXT, "cursesputchar", m, genie_curses_putchar); m = a68_proc (M_VOID, M_INT, M_INT, NO_MOID); a68_idf (A68_EXT, "cursesmove", m, genie_curses_move); m = A68_MCACHE (proc_int); a68_idf (A68_EXT, "curseslines", m, genie_curses_lines); a68_idf (A68_EXT, "cursescolumns", m, genie_curses_columns); m = a68_proc (M_BOOL, M_CHAR, NO_MOID); a68_idf (A68_EXT, "cursesdelchar", m, genie_curses_del_char); } #endif #if defined (HAVE_POSTGRESQL) void stand_postgresql (void) { MOID_T *m = NO_MOID; m = a68_proc (M_INT, M_REF_FILE, M_STRING, M_REF_STRING, NO_MOID); a68_idf (A68_EXT, "pqconnectdb", m, genie_pq_connectdb); m = a68_proc (M_INT, M_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 (M_INT, M_REF_FILE, M_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 (M_INT, M_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 (M_INT, M_REF_FILE, M_INT, NO_MOID); a68_idf (A68_EXT, "pqfname", m, genie_pq_fname); a68_idf (A68_EXT, "pqfformat", m, genie_pq_fformat); m = a68_proc (M_INT, M_REF_FILE, M_INT, M_INT, NO_MOID); a68_idf (A68_EXT, "pqgetvalue", m, genie_pq_getvalue); a68_idf (A68_EXT, "pqgetisnull", m, genie_pq_getisnull); } #endif #if defined (BUILD_LINUX) void stand_linux (void) { a68_idf (A68_EXT, "sigsegv", A68_MCACHE (proc_void), genie_sigsegv); } #endif //! @brief Build the standard environ symbol table. void make_standard_environ (void) { stand_moids (); // A68_MCACHE (proc_bool) = a68_proc (M_BOOL, NO_MOID); A68_MCACHE (proc_char) = a68_proc (M_CHAR, NO_MOID); A68_MCACHE (proc_complex_complex) = a68_proc (M_COMPLEX, M_COMPLEX, NO_MOID); A68_MCACHE (proc_int) = a68_proc (M_INT, NO_MOID); A68_MCACHE (proc_int_int) = a68_proc (M_INT, M_INT, NO_MOID); A68_MCACHE (proc_int_int_real) = a68_proc (M_REAL, M_INT, M_INT, NO_MOID); A68_MCACHE (proc_int_real) = a68_proc (M_REAL, M_INT, NO_MOID); A68_MCACHE (proc_int_real_real) = a68_proc (M_REAL, M_INT, M_REAL, NO_MOID); A68_MCACHE (proc_int_real_real_real) = a68_proc (M_REAL, M_INT, M_REAL, M_REAL, NO_MOID); A68_MCACHE (proc_real) = a68_proc (M_REAL, NO_MOID); A68_MCACHE (proc_real_int_real) = a68_proc (M_REAL, M_REAL, M_INT, NO_MOID); A68_MCACHE (proc_real_real_int_real) = a68_proc (M_REAL, M_REAL, M_REAL, M_INT, NO_MOID); A68_MCACHE (proc_real_real) = M_PROC_REAL_REAL; A68_MCACHE (proc_real_real_real) = a68_proc (M_REAL, M_REAL, M_REAL, NO_MOID); A68_MCACHE (proc_real_real_real_int) = a68_proc (M_INT, M_REAL, M_REAL, M_REAL, NO_MOID); A68_MCACHE (proc_real_real_real_real) = a68_proc (M_REAL, M_REAL, M_REAL, M_REAL, NO_MOID); A68_MCACHE (proc_real_real_real_real_real) = a68_proc (M_REAL, M_REAL, M_REAL, M_REAL, M_REAL, NO_MOID); A68_MCACHE (proc_real_real_real_real_real_real) = a68_proc (M_REAL, M_REAL, M_REAL, M_REAL, M_REAL, M_REAL, NO_MOID); A68_MCACHE (proc_real_ref_real_ref_int_void) = a68_proc (M_VOID, M_REAL, M_REF_REAL, M_REF_INT, NO_MOID); A68_MCACHE (proc_void) = a68_proc (M_VOID, NO_MOID); // stand_prelude (); stand_mp_level_2 (); stand_mp_level_3 (); stand_transput (); stand_extensions (); #if (A68_LEVEL <= 2) stand_longlong_bits (); #endif #if defined (BUILD_LINUX) stand_linux (); #endif #if defined (HAVE_GSL) stand_gsl (); #endif #if defined (HAVE_MATHLIB) stand_mathlib (); #endif #if defined (HAVE_GNU_PLOTUTILS) stand_plot (); #endif #if defined (HAVE_CURSES) stand_curses (); #endif #if defined (HAVE_POSTGRESQL) stand_postgresql (); #endif } algol68g-3.1.2/src/a68g/script.c0000644000175000017500000001512414361065320013070 00000000000000//! @file script.c //! @author J. Marcel van der Veer // //! @section Copyright // // This file is part of Algol68G - an Algol 68 compiler-interpreter. // Copyright 2001-2023 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" #include "a68g-prelude.h" #include "a68g-mp.h" #include "a68g-optimiser.h" #include "a68g-genie.h" #include "a68g-options.h" #if defined (BUILD_A68_COMPILER) //! @brief Build shell script from program. void build_script (void) { int ret; FILE_T script, source; LINE_T *sl; char cmd[BUFFER_SIZE], *strop; #if !defined (BUILD_A68_COMPILER) return; #endif announce_phase ("script builder"); ABEND (OPTION_OPT_LEVEL (&A68_JOB) == 0, ERROR_ACTION, __func__); // Flatten the source file. ASSERT (snprintf (cmd, SNPRINTF_SIZE, "%s.%s", HIDDEN_TEMP_FILE_NAME, FILE_SOURCE_NAME (&A68_JOB)) >= 0); source = open (cmd, O_WRONLY | O_CREAT | O_TRUNC, A68_PROTECTION); ABEND (source == -1, ERROR_ACTION, cmd); for (sl = TOP_LINE (&A68_JOB); 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 (&A68_JOB), HIDDEN_TEMP_FILE_NAME, FILE_LIBRARY_NAME (&A68_JOB)) >= 0); ret = system (cmd); ABEND (ret != 0, ERROR_ACTION, cmd); ASSERT (snprintf (cmd, SNPRINTF_SIZE, "tar czf %s.%s.tgz %s.%s %s.%s", HIDDEN_TEMP_FILE_NAME, FILE_GENERIC_NAME (&A68_JOB), HIDDEN_TEMP_FILE_NAME, FILE_SOURCE_NAME (&A68_JOB), HIDDEN_TEMP_FILE_NAME, FILE_LIBRARY_NAME (&A68_JOB)) >= 0); ret = system (cmd); ABEND (ret != 0, ERROR_ACTION, cmd); // Compose script. ASSERT (snprintf (cmd, SNPRINTF_SIZE, "%s.%s", HIDDEN_TEMP_FILE_NAME, FILE_SCRIPT_NAME (&A68_JOB)) >= 0); script = open (cmd, O_WRONLY | O_CREAT | O_TRUNC, A68_PROTECTION); ABEND (script == -1, ERROR_ACTION, cmd); strop = ""; if (OPTION_STROPPING (&A68_JOB) == QUOTE_STROPPING) { strop = "--run-quote-script"; } else { strop = "--run-script"; } ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "#! %s/a68g %s\n", BINDIR, strop) >= 0); WRITE (script, A68 (output_line)); ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "%s\n%s --verify \"%s\"\n", FILE_GENERIC_NAME (&A68_JOB), optimisation_option (), PACKAGE_STRING) >= 0); WRITE (script, A68 (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 (&A68_JOB), HIDDEN_TEMP_FILE_NAME, FILE_GENERIC_NAME (&A68_JOB), FILE_SCRIPT_NAME (&A68_JOB)) >= 0); ret = system (cmd); ABEND (ret != 0, ERROR_ACTION, cmd); ASSERT (snprintf (cmd, SNPRINTF_SIZE, "%s", FILE_SCRIPT_NAME (&A68_JOB)) >= 0); ret = chmod (cmd, (__mode_t) (S_IRUSR | S_IWUSR | S_IXUSR | S_IRGRP | S_IXGRP | S_IROTH | S_IXOTH)); // -rwx-r-xr-x ABEND (ret != 0, ERROR_ACTION, cmd); ABEND (ret != 0, ERROR_ACTION, cmd); // Clean up. ASSERT (snprintf (cmd, SNPRINTF_SIZE, "%s.%s.tgz", HIDDEN_TEMP_FILE_NAME, FILE_GENERIC_NAME (&A68_JOB)) >= 0); ret = remove (cmd); ABEND (ret != 0, ERROR_ACTION, cmd); ASSERT (snprintf (cmd, SNPRINTF_SIZE, "%s.%s", HIDDEN_TEMP_FILE_NAME, FILE_SOURCE_NAME (&A68_JOB)) >= 0); ret = remove (cmd); ABEND (ret != 0, ERROR_ACTION, cmd); ASSERT (snprintf (cmd, SNPRINTF_SIZE, "%s.%s", HIDDEN_TEMP_FILE_NAME, FILE_LIBRARY_NAME (&A68_JOB)) >= 0); ret = remove (cmd); ABEND (ret != 0, ERROR_ACTION, cmd); ASSERT (snprintf (cmd, SNPRINTF_SIZE, "%s.%s", HIDDEN_TEMP_FILE_NAME, FILE_SCRIPT_NAME (&A68_JOB)) >= 0); ret = remove (cmd); ABEND (ret != 0, ERROR_ACTION, cmd); } //! @brief Load program from shell script . void load_script (void) { int k; FILE_T script; char cmd[BUFFER_SIZE], ch; #if !defined (BUILD_A68_COMPILER) return; #endif announce_phase ("script loader"); // Decompress the archive. ASSERT (snprintf (cmd, SNPRINTF_SIZE, "sed '1,3d' < %s | tar xzf -", FILE_INITIAL_NAME (&A68_JOB)) >= 0); ABEND (system (cmd) != 0, ERROR_ACTION, cmd); // Reread the header. script = open (FILE_INITIAL_NAME (&A68_JOB), O_RDONLY); ABEND (script == -1, ERROR_ACTION, 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. A68 (input_line)[0] = NULL_CHAR; k = 0; ASSERT (io_read (script, &ch, 1) == 1); while (ch != NEWLINE_CHAR) { A68 (input_line)[k++] = ch; ASSERT (io_read (script, &ch, 1) == 1); } A68 (input_line)[k] = NULL_CHAR; ASSERT (snprintf (cmd, SNPRINTF_SIZE, "%s.%s", HIDDEN_TEMP_FILE_NAME, A68 (input_line)) >= 0); FILE_INITIAL_NAME (&A68_JOB) = new_string (cmd, NO_TEXT); // Read options. A68 (input_line)[0] = NULL_CHAR; k = 0; ASSERT (io_read (script, &ch, 1) == 1); while (ch != NEWLINE_CHAR) { A68 (input_line)[k++] = ch; ASSERT (io_read (script, &ch, 1) == 1); } isolate_options (A68 (input_line), NO_LINE); (void) set_options (OPTION_LIST (&A68_JOB), A68_FALSE); ASSERT (close (script) == 0); } //! @brief Rewrite source for shell script . void rewrite_script_source (void) { LINE_T *ref_l = NO_LINE; FILE_T source; // Rebuild the source file. ASSERT (remove (FILE_SOURCE_NAME (&A68_JOB)) == 0); source = open (FILE_SOURCE_NAME (&A68_JOB), O_WRONLY | O_CREAT | O_TRUNC, A68_PROTECTION); ABEND (source == -1, ERROR_ACTION, FILE_SOURCE_NAME (&A68_JOB)); for (ref_l = TOP_LINE (&A68_JOB); 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 algol68g-3.1.2/src/a68g/monitor.c0000644000175000017500000022577514361065320013272 00000000000000//! @file monitor.c //! @author J. Marcel van der Veer // //! @section Copyright // // This file is part of Algol68G - an Algol 68 compiler-interpreter. // Copyright 2001-2023 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 . // Gdb-style monitor for the interpreter. // 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. #include "a68g.h" #include "a68g-genie.h" #include "a68g-frames.h" #include "a68g-prelude.h" #include "a68g-mp.h" #include "a68g-transput.h" #include "a68g-parser.h" #include "a68g-listing.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 TOP_MODE (A68_MON (_m_stack)[A68_MON (_m_sp) - 1]) #define LOGOUT_STRING "exit" void parse (FILE_T, NODE_T *, int); BOOL_T check_initialisation (NODE_T *, BYTE_T *, MOID_T *, BOOL_T *); #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(A68 (edit_line), SNPRINTF_SIZE, "%s", moid_to_string ((m), MOID_WIDTH, NO_NODE)) >= 0);\ monitor_error (NO_VALUE, A68 (edit_line));\ QUIT_ON_ERROR;\ } else if (IS_NIL (z)) {\ ASSERT (snprintf(A68 (edit_line), SNPRINTF_SIZE, "%s", moid_to_string ((m), MOID_WIDTH, NO_NODE)) >= 0);\ monitor_error ("accessing NIL name", A68 (edit_line));\ QUIT_ON_ERROR;\ } #define QUIT_ON_ERROR\ if (A68_MON (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. BOOL_T confirm_exit (void) { char *cmd; int k; ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "Terminate %s (yes|no): ", A68 (a68_cmd_name)) >= 0); WRITELN (STDOUT_FILENO, A68 (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. void monitor_error (char *msg, char *info) { QUIT_ON_ERROR; A68_MON (mon_errors)++; bufcpy (A68_MON (error_text), msg, BUFFER_SIZE); WRITELN (STDOUT_FILENO, A68 (a68_cmd_name)); WRITE (STDOUT_FILENO, ": monitor error: "); WRITE (STDOUT_FILENO, A68_MON (error_text)); if (info != NO_TEXT) { WRITE (STDOUT_FILENO, " ("); WRITE (STDOUT_FILENO, info); WRITE (STDOUT_FILENO, ")"); } WRITE (STDOUT_FILENO, "."); } //! @brief Scan symbol from input. void scan_sym (FILE_T f, NODE_T * p) { int k = 0; (void) f; (void) p; A68_MON (symbol)[0] = NULL_CHAR; A68_MON (attr) = 0; QUIT_ON_ERROR; while (IS_SPACE (A68_MON (expr)[A68_MON (pos)])) { A68_MON (pos)++; } if (A68_MON (expr)[A68_MON (pos)] == NULL_CHAR) { A68_MON (attr) = 0; A68_MON (symbol)[0] = NULL_CHAR; return; } else if (A68_MON (expr)[A68_MON (pos)] == ':') { if (strncmp (&(A68_MON (expr)[A68_MON (pos)]), ":=:", 3) == 0) { A68_MON (pos) += 3; bufcpy (A68_MON (symbol), ":=:", BUFFER_SIZE); A68_MON (attr) = IS_SYMBOL; } else if (strncmp (&(A68_MON (expr)[A68_MON (pos)]), ":/=:", 4) == 0) { A68_MON (pos) += 4; bufcpy (A68_MON (symbol), ":/=:", BUFFER_SIZE); A68_MON (attr) = ISNT_SYMBOL; } else if (strncmp (&(A68_MON (expr)[A68_MON (pos)]), ":=", 2) == 0) { A68_MON (pos) += 2; bufcpy (A68_MON (symbol), ":=", BUFFER_SIZE); A68_MON (attr) = ASSIGN_SYMBOL; } else { A68_MON (pos)++; bufcpy (A68_MON (symbol), ":", BUFFER_SIZE); A68_MON (attr) = COLON_SYMBOL; } return; } else if (A68_MON (expr)[A68_MON (pos)] == QUOTE_CHAR) { BOOL_T cont = A68_TRUE; A68_MON (pos)++; while (cont) { while (A68_MON (expr)[A68_MON (pos)] != QUOTE_CHAR) { A68_MON (symbol)[k++] = A68_MON (expr)[A68_MON (pos)++]; } if (A68_MON (expr)[++A68_MON (pos)] == QUOTE_CHAR) { A68_MON (symbol)[k++] = QUOTE_CHAR; } else { cont = A68_FALSE; } } A68_MON (symbol)[k] = NULL_CHAR; A68_MON (attr) = ROW_CHAR_DENOTATION; return; } else if (IS_LOWER (A68_MON (expr)[A68_MON (pos)])) { while (IS_LOWER (A68_MON (expr)[A68_MON (pos)]) || IS_DIGIT (A68_MON (expr)[A68_MON (pos)]) || IS_SPACE (A68_MON (expr)[A68_MON (pos)])) { if (IS_SPACE (A68_MON (expr)[A68_MON (pos)])) { A68_MON (pos)++; } else { A68_MON (symbol)[k++] = A68_MON (expr)[A68_MON (pos)++]; } } A68_MON (symbol)[k] = NULL_CHAR; A68_MON (attr) = IDENTIFIER; return; } else if (IS_UPPER (A68_MON (expr)[A68_MON (pos)])) { KEYWORD_T *kw; while (IS_UPPER (A68_MON (expr)[A68_MON (pos)])) { A68_MON (symbol)[k++] = A68_MON (expr)[A68_MON (pos)++]; } A68_MON (symbol)[k] = NULL_CHAR; kw = find_keyword (A68 (top_keyword), A68_MON (symbol)); if (kw != NO_KEYWORD) { A68_MON (attr) = ATTRIBUTE (kw); } else { A68_MON (attr) = OPERATOR; } return; } else if (IS_DIGIT (A68_MON (expr)[A68_MON (pos)])) { while (IS_DIGIT (A68_MON (expr)[A68_MON (pos)])) { A68_MON (symbol)[k++] = A68_MON (expr)[A68_MON (pos)++]; } if (A68_MON (expr)[A68_MON (pos)] == 'r') { A68_MON (symbol)[k++] = A68_MON (expr)[A68_MON (pos)++]; while (IS_XDIGIT (A68_MON (expr)[A68_MON (pos)])) { A68_MON (symbol)[k++] = A68_MON (expr)[A68_MON (pos)++]; } A68_MON (symbol)[k] = NULL_CHAR; A68_MON (attr) = BITS_DENOTATION; return; } if (A68_MON (expr)[A68_MON (pos)] != POINT_CHAR && A68_MON (expr)[A68_MON (pos)] != 'e' && A68_MON (expr)[A68_MON (pos)] != 'E') { A68_MON (symbol)[k] = NULL_CHAR; A68_MON (attr) = INT_DENOTATION; return; } if (A68_MON (expr)[A68_MON (pos)] == POINT_CHAR) { A68_MON (symbol)[k++] = A68_MON (expr)[A68_MON (pos)++]; while (IS_DIGIT (A68_MON (expr)[A68_MON (pos)])) { A68_MON (symbol)[k++] = A68_MON (expr)[A68_MON (pos)++]; } } if (A68_MON (expr)[A68_MON (pos)] != 'e' && A68_MON (expr)[A68_MON (pos)] != 'E') { A68_MON (symbol)[k] = NULL_CHAR; A68_MON (attr) = REAL_DENOTATION; return; } A68_MON (symbol)[k++] = (char) TO_UPPER (A68_MON (expr)[A68_MON (pos)++]); if (A68_MON (expr)[A68_MON (pos)] == '+' || A68_MON (expr)[A68_MON (pos)] == '-') { A68_MON (symbol)[k++] = A68_MON (expr)[A68_MON (pos)++]; } while (IS_DIGIT (A68_MON (expr)[A68_MON (pos)])) { A68_MON (symbol)[k++] = A68_MON (expr)[A68_MON (pos)++]; } A68_MON (symbol)[k] = NULL_CHAR; A68_MON (attr) = REAL_DENOTATION; return; } else if (strchr (MONADS, A68_MON (expr)[A68_MON (pos)]) != NO_TEXT || strchr (NOMADS, A68_MON (expr)[A68_MON (pos)]) != NO_TEXT) { A68_MON (symbol)[k++] = A68_MON (expr)[A68_MON (pos)++]; if (strchr (NOMADS, A68_MON (expr)[A68_MON (pos)]) != NO_TEXT) { A68_MON (symbol)[k++] = A68_MON (expr)[A68_MON (pos)++]; } if (A68_MON (expr)[A68_MON (pos)] == ':') { A68_MON (symbol)[k++] = A68_MON (expr)[A68_MON (pos)++]; if (A68_MON (expr)[A68_MON (pos)] == '=') { A68_MON (symbol)[k++] = A68_MON (expr)[A68_MON (pos)++]; } else { A68_MON (symbol)[k] = NULL_CHAR; monitor_error ("invalid operator symbol", A68_MON (symbol)); } } else if (A68_MON (expr)[A68_MON (pos)] == '=') { A68_MON (symbol)[k++] = A68_MON (expr)[A68_MON (pos)++]; if (A68_MON (expr)[A68_MON (pos)] == ':') { A68_MON (symbol)[k++] = A68_MON (expr)[A68_MON (pos)++]; } else { A68_MON (symbol)[k] = NULL_CHAR; monitor_error ("invalid operator symbol", A68_MON (symbol)); } } A68_MON (symbol)[k] = NULL_CHAR; A68_MON (attr) = OPERATOR; return; } else if (A68_MON (expr)[A68_MON (pos)] == '(') { A68_MON (pos)++; A68_MON (attr) = OPEN_SYMBOL; return; } else if (A68_MON (expr)[A68_MON (pos)] == ')') { A68_MON (pos)++; A68_MON (attr) = CLOSE_SYMBOL; return; } else if (A68_MON (expr)[A68_MON (pos)] == '[') { A68_MON (pos)++; A68_MON (attr) = SUB_SYMBOL; return; } else if (A68_MON (expr)[A68_MON (pos)] == ']') { A68_MON (pos)++; A68_MON (attr) = BUS_SYMBOL; return; } else if (A68_MON (expr)[A68_MON (pos)] == ',') { A68_MON (pos)++; A68_MON (attr) = COMMA_SYMBOL; return; } else if (A68_MON (expr)[A68_MON (pos)] == ';') { A68_MON (pos)++; A68_MON (attr) = SEMI_SYMBOL; return; } } //! @brief Find a tag, searching symbol tables towards the root. 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, ERROR_INTERNAL_CONSISTENCY, __func__); } 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. int prio (FILE_T f, NODE_T * p) { TAG_T *s = find_tag (A68_STANDENV, PRIO_SYMBOL, A68_MON (symbol)); (void) p; (void) f; if (s == NO_TAG) { monitor_error ("unknown operator, cannot set priority", A68_MON (symbol)); return 0; } return PRIO (s); } //! @brief Push a mode on the stack. void push_mode (FILE_T f, MOID_T * m) { (void) f; if (A68_MON (_m_sp) < MON_STACK_SIZE) { A68_MON (_m_stack)[A68_MON (_m_sp)++] = m; } else { monitor_error ("expression too complex", NO_TEXT); } } //! @brief Dereference, WEAK or otherwise. BOOL_T deref_condition (int k, int context) { MOID_T *u = A68_MON (_m_stack)[k]; if (context == WEAK && SUB (u) != NO_MOID) { MOID_T *v = SUB (u); BOOL_T stowed = (BOOL_T) (IS_FLEX (v) || IS_ROW (v) || IS_STRUCT (v)); return (BOOL_T) (IS_REF (u) && !stowed); } else { return (BOOL_T) (IS_REF (u)); } } //! @brief Weak dereferencing. 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, A68_MON (_m_stack)[k]); A68_MON (_m_stack)[k] = SUB (A68_MON (_m_stack)[k]); PUSH (p, ADDRESS (&z), SIZE (A68_MON (_m_stack)[k])); } } //! @brief Search moid that matches indicant. MOID_T *search_mode (int refs, int leng, char *indy) { MOID_T *m = NO_MOID, *z = NO_MOID; for (m = TOP_MOID (&A68_JOB); 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 (&A68_JOB); m != NO_MOID; FORWARD (m)) { int k = 0; while (IS_REF (m)) { 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. TAG_T *search_operator (char *sym, MOID_T * x, MOID_T * y) { TAG_T *t; for (t = OPERATORS (A68_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_REF (x)) { return search_operator (sym, SUB (x), y); } if (y != NO_MOID && IS_REF (y)) { return search_operator (sym, x, SUB (y)); } // Not found. Grrrr. Give a message. if (y == NO_MOID) { ASSERT (snprintf (A68 (edit_line), SNPRINTF_SIZE, "%s %s", sym, moid_to_string (x, MOID_WIDTH, NO_NODE)) >= 0); } else { ASSERT (snprintf (A68 (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", A68 (edit_line)); return NO_TAG; } //! @brief Search identifier in frame stack and push value. void search_identifier (FILE_T f, NODE_T * p, ADDR_T a68_link, char *sym) { if (a68_link > 0) { int dynamic_a68_link = FRAME_DYNAMIC_LINK (a68_link); if (A68_MON (current_frame) == 0 || (A68_MON (current_frame) == FRAME_NUMBER (a68_link))) { NODE_T *u = FRAME_TREE (a68_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 = a68_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_a68_link, sym); } else { TABLE_T *q = A68_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_T) (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. 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 pop_sp = 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 (A68_MON (_m_stack)[k] == MOID (u)) { PUSH (p, STACK_ADDRESS (pop_sp), SIZE (MOID (u))); pop_sp += SIZE (MOID (u)); } else if (IS_REF (A68_MON (_m_stack)[k])) { A68_REF *v = (A68_REF *) STACK_ADDRESS (pop_sp); PUSH_REF (p, *v); pop_sp += A68_REF_SIZE; deref (p, k, STRONG); if (A68_MON (_m_stack)[k] != MOID (u)) { ASSERT (snprintf (A68 (edit_line), SNPRINTF_SIZE, "%s to %s", moid_to_string (A68_MON (_m_stack)[k], MOID_WIDTH, NO_NODE), moid_to_string (MOID (u), MOID_WIDTH, NO_NODE)) >= 0); monitor_error ("invalid argument mode", A68 (edit_line)); } } else { ASSERT (snprintf (A68 (edit_line), SNPRINTF_SIZE, "%s to %s", moid_to_string (A68_MON (_m_stack)[k], MOID_WIDTH, NO_NODE), moid_to_string (MOID (u), MOID_WIDTH, NO_NODE)) >= 0); monitor_error ("cannot coerce argument", A68 (edit_line)); } QUIT_ON_ERROR; } MOVE (STACK_ADDRESS (top_sp), STACK_ADDRESS (pop_sp), A68_SP - pop_sp); A68_SP = top_sp + (A68_SP - pop_sp); } //! @brief Perform a selection. 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 (A68_MON (attr) != IDENTIFIER && A68_MON (attr) != OPEN_SYMBOL) { monitor_error ("invalid selection syntax", NO_TEXT); } QUIT_ON_ERROR; PARSE_CHECK (f, p, MAX_PRIORITY + 1); deref (p, A68_MON (_m_sp) - 1, WEAK); if (IS_REF (TOP_MODE)) { name = A68_TRUE; u = PACK (NAME (TOP_MODE)); moid = SUB (A68_MON (_m_stack)[--A68_MON (_m_sp)]); v = PACK (moid); } else { name = A68_FALSE; moid = A68_MON (_m_stack)[--A68_MON (_m_sp)]; u = PACK (moid); v = PACK (moid); } if (!IS (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)), (unt) 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. void call (FILE_T f, NODE_T * p, int depth) { A68_PROCEDURE z; NODE_T q; int args, old_m_sp; MOID_T *proc; (void) depth; QUIT_ON_ERROR; deref (p, A68_MON (_m_sp) - 1, STRONG); proc = A68_MON (_m_stack)[--A68_MON (_m_sp)]; old_m_sp = A68_MON (_m_sp); if (!IS (proc, PROC_SYMBOL)) { monitor_error ("invalid procedure mode", moid_to_string (proc, MOID_WIDTH, NO_NODE)); } QUIT_ON_ERROR; POP_PROCEDURE (p, &z); args = A68_MON (_m_sp); ADDR_T top_sp = A68_SP; if (A68_MON (attr) == OPEN_SYMBOL) { do { SCAN_CHECK (f, p); PARSE_CHECK (f, p, 0); } while (A68_MON (attr) == COMMA_SYMBOL); if (A68_MON (attr) != CLOSE_SYMBOL) { monitor_error ("unmatched parenthesis", NO_TEXT); } SCAN_CHECK (f, p); } coerce_arguments (f, p, proc, args, A68_MON (_m_sp), top_sp); if (STATUS (&z) & STANDENV_PROC_MASK) { MOID (&q) = A68_MON (_m_stack)[--A68_MON (_m_sp)]; INFO (&q) = INFO (p); NSYMBOL (&q) = NSYMBOL (p); (void) ((*PROCEDURE (&(BODY (&z)))) (&q)); A68_MON (_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. 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, A68_MON (_m_sp) - 1, WEAK); if (IS_REF (TOP_MODE)) { name = A68_TRUE; res = NAME (TOP_MODE); deref (p, A68_MON (_m_sp) - 1, STRONG); moid = A68_MON (_m_stack)[--A68_MON (_m_sp)]; } else { name = A68_FALSE; moid = A68_MON (_m_stack)[--A68_MON (_m_sp)]; res = SUB (moid); } if (!IS_ROW (moid) && !IS_FLEX (moid)) { 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_FLEX (moid)) { dim = DIM (SUB (moid)); } else { dim = DIM (moid); } // Get iindexer. args = A68_MON (_m_sp); if (A68_MON (attr) == SUB_SYMBOL) { do { SCAN_CHECK (f, p); PARSE_CHECK (f, p, 0); } while (A68_MON (attr) == COMMA_SYMBOL); if (A68_MON (attr) != BUS_SYMBOL) { monitor_error ("unmatched parenthesis", NO_TEXT); } SCAN_CHECK (f, p); } if ((A68_MON (_m_sp) - args) != dim) { monitor_error ("invalid slice index count", NO_TEXT); } QUIT_ON_ERROR; for (k = 0, iindex = 0; k < dim; k++, A68_MON (_m_sp)--) { A68_TUPLE *t = &(tup[dim - k - 1]); A68_INT i; deref (p, A68_MON (_m_sp) - 1, MEEK); if (TOP_MODE != M_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 (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. void call_or_slice (FILE_T f, NODE_T * p, int depth) { while (A68_MON (attr) == OPEN_SYMBOL || A68_MON (attr) == SUB_SYMBOL) { QUIT_ON_ERROR; if (A68_MON (attr) == OPEN_SYMBOL) { call (f, p, depth); } else if (A68_MON (attr) == SUB_SYMBOL) { slice (f, p, depth); } } } //! @brief Parse expression on input. 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 (A68_MON (attr) == IS_SYMBOL || A68_MON (attr) == ISNT_SYMBOL) { A68_REF x, y; BOOL_T res; int op = A68_MON (attr); if (TOP_MODE != M_HIP && !IS_REF (TOP_MODE)) { 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 != M_HIP && !IS_REF (TOP_MODE)) { monitor_error ("identity relation operand must yield a name", moid_to_string (TOP_MODE, MOID_WIDTH, NO_NODE)); } QUIT_ON_ERROR; if (TOP_MODE != M_HIP && A68_MON (_m_stack)[A68_MON (_m_sp) - 2] != M_HIP) { if (TOP_MODE != A68_MON (_m_stack)[A68_MON (_m_sp) - 2]) { monitor_error ("invalid identity relation operand mode", NO_TEXT); } } QUIT_ON_ERROR; A68_MON (_m_sp) -= 2; POP_REF (p, &y); POP_REF (p, &x); res = (BOOL_T) (ADDRESS (&x) == ADDRESS (&y)); PUSH_VALUE (p, (BOOL_T) (op == IS_SYMBOL ? res : !res), A68_BOOL); push_mode (f, M_BOOL); } } else { // Dyadic expressions. PARSE_CHECK (f, p, depth + 1); while (A68_MON (attr) == OPERATOR && prio (f, p) == depth) { int args; NODE_T q; TAG_T *opt; char name[BUFFER_SIZE]; bufcpy (name, A68_MON (symbol), BUFFER_SIZE); args = A68_MON (_m_sp) - 1; ADDR_T top_sp = A68_SP - SIZE (A68_MON (_m_stack)[args]); SCAN_CHECK (f, p); PARSE_CHECK (f, p, depth + 1); opt = search_operator (name, A68_MON (_m_stack)[A68_MON (_m_sp) - 2], TOP_MODE); QUIT_ON_ERROR; coerce_arguments (f, p, MOID (opt), args, A68_MON (_m_sp), top_sp); A68_MON (_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 (A68_MON (attr) == OPERATOR) { int args; NODE_T q; TAG_T *opt; char name[BUFFER_SIZE]; bufcpy (name, A68_MON (symbol), BUFFER_SIZE); args = A68_MON (_m_sp); ADDR_T top_sp = A68_SP; 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, A68_MON (_m_sp), top_sp); A68_MON (_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 (A68_MON (attr) == REF_SYMBOL) { int refs = 0, length = 0; MOID_T *m = NO_MOID; while (A68_MON (attr) == REF_SYMBOL) { refs++; SCAN_CHECK (f, p); } while (A68_MON (attr) == LONG_SYMBOL) { length++; SCAN_CHECK (f, p); } m = search_mode (refs, length, A68_MON (symbol)); QUIT_ON_ERROR; if (m == NO_MOID) { monitor_error ("unknown reference to mode", NO_TEXT); } SCAN_CHECK (f, p); if (A68_MON (attr) != OPEN_SYMBOL) { monitor_error ("cast expects open-symbol", NO_TEXT); } SCAN_CHECK (f, p); PARSE_CHECK (f, p, 0); if (A68_MON (attr) != CLOSE_SYMBOL) { monitor_error ("cast expects close-symbol", NO_TEXT); } SCAN_CHECK (f, p); while (IS_REF (TOP_MODE) && 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 (A68_MON (attr) == LONG_SYMBOL) { int length = 0; MOID_T *m; while (A68_MON (attr) == LONG_SYMBOL) { length++; SCAN_CHECK (f, p); } // Cast L INT -> L REAL. if (A68_MON (attr) == REAL_SYMBOL) { MOID_T *i = (length == 1 ? M_LONG_INT : M_LONG_LONG_INT); MOID_T *r = (length == 1 ? M_LONG_REAL : M_LONG_LONG_REAL); SCAN_CHECK (f, p); if (A68_MON (attr) != OPEN_SYMBOL) { monitor_error ("cast expects open-symbol", NO_TEXT); } SCAN_CHECK (f, p); PARSE_CHECK (f, p, 0); if (A68_MON (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 (A68_MON (attr) == INT_DENOTATION) { m = (length == 1 ? M_LONG_INT : M_LONG_LONG_INT); } else if (A68_MON (attr) == REAL_DENOTATION) { m = (length == 1 ? M_LONG_REAL : M_LONG_LONG_REAL); } else if (A68_MON (attr) == BITS_DENOTATION) { m = (length == 1 ? M_LONG_BITS : M_LONG_LONG_BITS); } else { m = NO_MOID; } if (m != NO_MOID) { int digits = DIGITS (m); MP_T *z = nil_mp (p, digits); if (genie_string_to_value_internal (p, m, A68_MON (symbol), (BYTE_T *) z) == A68_FALSE) { diagnostic (A68_RUNTIME_ERROR, p, ERROR_IN_DENOTATION, m); exit_genie (p, A68_RUNTIME_ERROR); } MP_STATUS (z) = (MP_T) (INIT_MASK | CONSTANT_MASK); push_mode (f, m); SCAN_CHECK (f, p); } else { monitor_error ("invalid mode", NO_TEXT); } } else if (A68_MON (attr) == INT_DENOTATION) { A68_INT z; if (genie_string_to_value_internal (p, M_INT, A68_MON (symbol), (BYTE_T *) & z) == A68_FALSE) { diagnostic (A68_RUNTIME_ERROR, p, ERROR_IN_DENOTATION, M_INT); exit_genie (p, A68_RUNTIME_ERROR); } PUSH_VALUE (p, VALUE (&z), A68_INT); push_mode (f, M_INT); SCAN_CHECK (f, p); } else if (A68_MON (attr) == REAL_DENOTATION) { A68_REAL z; if (genie_string_to_value_internal (p, M_REAL, A68_MON (symbol), (BYTE_T *) & z) == A68_FALSE) { diagnostic (A68_RUNTIME_ERROR, p, ERROR_IN_DENOTATION, M_REAL); exit_genie (p, A68_RUNTIME_ERROR); } PUSH_VALUE (p, VALUE (&z), A68_REAL); push_mode (f, M_REAL); SCAN_CHECK (f, p); } else if (A68_MON (attr) == BITS_DENOTATION) { A68_BITS z; if (genie_string_to_value_internal (p, M_BITS, A68_MON (symbol), (BYTE_T *) & z) == A68_FALSE) { diagnostic (A68_RUNTIME_ERROR, p, ERROR_IN_DENOTATION, M_BITS); exit_genie (p, A68_RUNTIME_ERROR); } PUSH_VALUE (p, VALUE (&z), A68_BITS); push_mode (f, M_BITS); SCAN_CHECK (f, p); } else if (A68_MON (attr) == ROW_CHAR_DENOTATION) { if (strlen (A68_MON (symbol)) == 1) { PUSH_VALUE (p, A68_MON (symbol)[0], A68_CHAR); push_mode (f, M_CHAR); } else { A68_REF z; A68_ARRAY *arr; A68_TUPLE *tup; z = c_to_a_string (p, A68_MON (symbol), DEFAULT_WIDTH); GET_DESCRIPTOR (arr, tup, &z); BLOCK_GC_HANDLE (&z); BLOCK_GC_HANDLE (&(ARRAY (arr))); PUSH_REF (p, z); push_mode (f, M_STRING); (void) tup; } SCAN_CHECK (f, p); } else if (A68_MON (attr) == TRUE_SYMBOL) { PUSH_VALUE (p, A68_TRUE, A68_BOOL); push_mode (f, M_BOOL); SCAN_CHECK (f, p); } else if (A68_MON (attr) == FALSE_SYMBOL) { PUSH_VALUE (p, A68_FALSE, A68_BOOL); push_mode (f, M_BOOL); SCAN_CHECK (f, p); } else if (A68_MON (attr) == NIL_SYMBOL) { PUSH_REF (p, nil_ref); push_mode (f, M_HIP); SCAN_CHECK (f, p); } else if (A68_MON (attr) == REAL_SYMBOL) { A68_INT k; SCAN_CHECK (f, p); if (A68_MON (attr) != OPEN_SYMBOL) { monitor_error ("cast expects open-symbol", NO_TEXT); } SCAN_CHECK (f, p); PARSE_CHECK (f, p, 0); if (A68_MON (attr) != CLOSE_SYMBOL) { monitor_error ("cast expects close-symbol", NO_TEXT); } SCAN_CHECK (f, p); if (TOP_MODE != M_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_VALUE (p, (REAL_T) VALUE (&k), A68_REAL); TOP_MODE = M_REAL; } else if (A68_MON (attr) == IDENTIFIER) { ADDR_T old_sp = A68_SP; BOOL_T init; MOID_T *moid; char name[BUFFER_SIZE]; bufcpy (name, A68_MON (symbol), BUFFER_SIZE); SCAN_CHECK (f, p); if (A68_MON (attr) == OF_SYMBOL) { selection (f, p, name); } else { search_identifier (f, p, A68_FP, 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 (A68_MON (attr) == OPEN_SYMBOL) { do { SCAN_CHECK (f, p); PARSE_CHECK (f, p, 0); } while (A68_MON (attr) == COMMA_SYMBOL); if (A68_MON (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. void assign (FILE_T f, NODE_T * p) { LOW_STACK_ALERT (p); PARSE_CHECK (f, p, 0); if (A68_MON (attr) == ASSIGN_SYMBOL) { MOID_T *m = A68_MON (_m_stack)[--A68_MON (_m_sp)]; A68_REF z; if (!IS_REF (m)) { 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_REF (TOP_MODE) && 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 != M_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. void evaluate (FILE_T f, NODE_T * p, char *str) { LOW_STACK_ALERT (p); A68_MON (_m_sp) = 0; A68_MON (_m_stack)[0] = NO_MOID; A68_MON (pos) = 0; bufcpy (A68_MON (expr), str, BUFFER_SIZE); SCAN_CHECK (f, p); QUIT_ON_ERROR; assign (f, p); if (A68_MON (attr) != 0) { monitor_error ("trailing character in expression", A68_MON (symbol)); } } //! @brief Convert string to int. 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])) { errno = 0; k = (int) a68_strtou (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. 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_ALIGNED (A68_REAL)); initialised = (BOOL_T) (INITIALISED (r) && INITIALISED (i)); recognised = A68_TRUE; break; } #if (A68_LEVEL >= 3) case MODE_LONG_INT: case MODE_LONG_BITS: { A68_LONG_INT *z = (A68_LONG_INT *) w; initialised = INITIALISED (z); recognised = A68_TRUE; break; } case MODE_LONG_REAL: { A68_LONG_REAL *z = (A68_LONG_REAL *) w; initialised = INITIALISED (z); recognised = A68_TRUE; break; } #else case MODE_LONG_INT: case MODE_LONG_REAL: case MODE_LONG_BITS: { MP_T *z = (MP_T *) w; initialised = (BOOL_T) ((unt) MP_STATUS (z) & INIT_MASK); recognised = A68_TRUE; break; } #endif case MODE_LONG_LONG_INT: case MODE_LONG_LONG_REAL: case MODE_LONG_LONG_BITS: { MP_T *z = (MP_T *) w; initialised = (BOOL_T) ((unt) MP_STATUS (z) & INIT_MASK); recognised = A68_TRUE; break; } case MODE_LONG_COMPLEX: { MP_T *r = (MP_T *) w; MP_T *i = (MP_T *) (w + size_mp ()); initialised = (BOOL_T) (((unt) MP_STATUS (r) & INIT_MASK) && ((unt) MP_STATUS (i) & INIT_MASK)); recognised = A68_TRUE; break; } case MODE_LONG_LONG_COMPLEX: { MP_T *r = (MP_T *) w; MP_T *i = (MP_T *) (w + size_mp ()); initialised = (BOOL_T) (((unt) MP_STATUS (r) & INIT_MASK) && ((unt) MP_STATUS (i) & 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. 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 == M_CHAR || mode == M_ROW_CHAR || mode == M_STRING) { ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, " \"%s\"", get_transput_buffer (UNFORMATTED_BUFFER)) >= 0); WRITE (f, A68 (output_line)); } else { char *str = get_transput_buffer (UNFORMATTED_BUFFER); while (IS_SPACE (str[0])) { str++; } ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, " %s", str) >= 0); WRITE (f, A68 (output_line)); } } else { WRITE (f, CANNOT_SHOW); } } //! @brief Indented indent_crlf. void indent_crlf (FILE_T f) { int k; io_close_tty_line (); for (k = 0; k < A68_MON (tabs); k++) { WRITE (f, " "); } } //! @brief Show value of object. 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_REF (mode)) { 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 (A68 (output_line), SNPRINTF_SIZE, "heap(%p)", (void *) ADDRESS (z)) >= 0); WRITE (STDOUT_FILENO, A68 (output_line)); A68_MON (tabs)++; show_item (f, p, ADDRESS (z), SUB (mode)); A68_MON (tabs)--; } else if (IS_IN_FRAME (z)) { ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "frame(" A68_LU ")", REF_OFFSET (z)) >= 0); WRITE (STDOUT_FILENO, A68 (output_line)); } else if (IS_IN_STACK (z)) { ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "stack(" A68_LU ")", REF_OFFSET (z)) >= 0); WRITE (STDOUT_FILENO, A68 (output_line)); } } else { WRITE (STDOUT_FILENO, NO_VALUE); } } } else if (mode == M_STRING) { if (!INITIALISED ((A68_REF *) item)) { WRITE (STDOUT_FILENO, NO_VALUE); } else { print_item (p, f, item, mode); } } else if ((IS_ROW (mode) || IS_FLEX (mode)) && mode != M_STRING) { MOID_T *deflexed = DEFLEX (mode); int old_tabs = A68_MON (tabs); A68_MON (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 (A68 (output_line), SNPRINTF_SIZE, ", %d element(s)", elems) >= 0); WRITE (f, A68 (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 <= (A68_MON (max_row_elems) + 1)) { if (count <= A68_MON (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 (A68 (output_line), SNPRINTF_SIZE, " %d element(s) written (%d%%)", act_count, (int) ((100.0 * act_count) / elems)) >= 0); WRITE (f, A68 (output_line)); } } A68_MON (tabs) = old_tabs; } else if (IS_STRUCT (mode)) { PACK_T *q = PACK (mode); A68_MON (tabs)++; for (; q != NO_PACK; FORWARD (q)) { BYTE_T *elem = &item[OFFSET (q)]; indent_crlf (f); ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, " %s \"%s\"", moid_to_string (MOID (q), MOID_WIDTH, NO_NODE), TEXT (q)) >= 0); WRITE (STDOUT_FILENO, A68 (output_line)); show_item (f, p, elem, MOID (q)); } A68_MON (tabs)--; } else if (IS (mode, UNION_SYMBOL)) { A68_UNION *z = (A68_UNION *) item; ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, " united-moid %s", moid_to_string ((MOID_T *) (VALUE (z)), MOID_WIDTH, NO_NODE)) >= 0); WRITE (STDOUT_FILENO, A68 (output_line)); show_item (f, p, &item[SIZE_ALIGNED (A68_UNION)], (MOID_T *) (VALUE (z))); } else if (mode == M_SIMPLIN) { A68_UNION *z = (A68_UNION *) item; ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, " united-moid %s", moid_to_string ((MOID_T *) (VALUE (z)), MOID_WIDTH, NO_NODE)) >= 0); WRITE (STDOUT_FILENO, A68 (output_line)); } else if (mode == M_SIMPLOUT) { A68_UNION *z = (A68_UNION *) item; ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, " united-moid %s", moid_to_string ((MOID_T *) (VALUE (z)), MOID_WIDTH, NO_NODE)) >= 0); WRITE (STDOUT_FILENO, A68 (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 (A68 (output_line), SNPRINTF_SIZE, " line %d, environ at frame(" A68_LU "), locale %p", LINE_NUMBER ((NODE_T *) NODE (&BODY (z))), ENVIRON (z), (void *) LOCALE (z)) >= 0); WRITE (STDOUT_FILENO, A68 (output_line)); } else { WRITE (STDOUT_FILENO, " cannot show value"); } } else if (mode == M_FORMAT) { A68_FORMAT *z = (A68_FORMAT *) item; if (z != NO_FORMAT && BODY (z) != NO_NODE) { ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, " line %d, environ at frame(" A68_LU ")", LINE_NUMBER (BODY (z)), ENVIRON (z)) >= 0); WRITE (STDOUT_FILENO, A68 (output_line)); } else { monitor_error (CANNOT_SHOW, NO_TEXT); } } else if (mode == M_SOUND) { A68_SOUND *z = (A68_SOUND *) item; if (z != NO_SOUND) { ASSERT (snprintf (A68 (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, A68 (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 (A68 (output_line), SNPRINTF_SIZE, " mode %s, %s", moid_to_string (mode, MOID_WIDTH, NO_NODE), CANNOT_SHOW) >= 0); WRITE (STDOUT_FILENO, A68 (output_line)); } } } //! @brief Overview of frame item. void show_frame_item (FILE_T f, NODE_T * p, ADDR_T a68_link, TAG_T * q, int modif) { ADDR_T addr = a68_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 (A68 (output_line), SNPRINTF_SIZE, " frame(" A68_LU "=" A68_LU "+" A68_LU ") %s \"%s\"", addr, a68_link, loc, moid_to_string (MOID (q), MOID_WIDTH, NO_NODE), NSYMBOL (NODE (q))) >= 0); WRITE (STDOUT_FILENO, A68 (output_line)); show_item (f, p, FRAME_ADDRESS (addr), MOID (q)); } else { switch (PRIO (q)) { case GENERATOR: { ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, " frame(" A68_LU "=" A68_LU "+" A68_LU ") LOC %s", addr, a68_link, loc, moid_to_string (MOID (q), MOID_WIDTH, NO_NODE)) >= 0); WRITE (STDOUT_FILENO, A68 (output_line)); break; } default: { ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, " frame(" A68_LU "=" A68_LU "+" A68_LU ") internal %s", addr, a68_link, loc, moid_to_string (MOID (q), MOID_WIDTH, NO_NODE)) >= 0); WRITE (STDOUT_FILENO, A68 (output_line)); break; } } show_item (f, p, FRAME_ADDRESS (addr), MOID (q)); } } //! @brief Overview of frame items. void show_frame_items (FILE_T f, NODE_T * p, ADDR_T a68_link, TAG_T * q, int modif) { (void) p; for (; q != NO_TAG; FORWARD (q)) { show_frame_item (f, p, a68_link, q, modif); } } //! @brief Introduce stack frame. void intro_frame (FILE_T f, NODE_T * p, ADDR_T a68_link, int *printed) { TABLE_T *q = TABLE (p); if (*printed > 0) { WRITELN (f, ""); } (*printed)++; where_in_source (f, p); ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "Stack frame %d at frame(" A68_LU "), level=%d, size=" A68_LU " bytes", FRAME_NUMBER (a68_link), a68_link, LEVEL (q), (UNSIGNED_T) (FRAME_INCREMENT (a68_link) + FRAME_INFO_SIZE)) >= 0); WRITELN (f, A68 (output_line)); } //! @brief View contents of stack frame. void show_stack_frame (FILE_T f, NODE_T * p, ADDR_T a68_link, int *printed) { // show the frame starting at frame pointer 'a68_link', using symbol table from p as a map. if (p != NO_NODE) { TABLE_T *q = TABLE (p); intro_frame (f, p, a68_link, printed); #if (A68_LEVEL >= 3) ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "Dynamic link=frame(%llu), static link=frame(%llu), parameters=frame(%llu)", FRAME_DYNAMIC_LINK (a68_link), FRAME_STATIC_LINK (a68_link), FRAME_PARAMETERS (a68_link)) >= 0); WRITELN (STDOUT_FILENO, A68 (output_line)); #else ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "Dynamic link=frame(%u), static link=frame(%u), parameters=frame(%u)", FRAME_DYNAMIC_LINK (a68_link), FRAME_STATIC_LINK (a68_link), FRAME_PARAMETERS (a68_link)) >= 0); WRITELN (STDOUT_FILENO, A68 (output_line)); #endif ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "Procedure frame=%s", (FRAME_PROC_FRAME (a68_link) ? "yes" : "no")) >= 0); WRITELN (STDOUT_FILENO, A68 (output_line)); #if defined (BUILD_PARALLEL_CLAUSE) if (pthread_equal (FRAME_THREAD_ID (a68_link), A68_PAR (main_thread_id)) != 0) { ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "In main thread") >= 0); } else { ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "Not in main thread") >= 0); } WRITELN (STDOUT_FILENO, A68 (output_line)); #endif show_frame_items (f, p, a68_link, IDENTIFIERS (q), IDENTIFIER); show_frame_items (f, p, a68_link, OPERATORS (q), OPERATOR); show_frame_items (f, p, a68_link, ANONYMOUS (q), ANONYMOUS); } } //! @brief Shows lines around the line where 'p' is at. 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 (&A68_JOB); 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 (&A68_JOB); 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. 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 (A68 (output_line), SNPRINTF_SIZE, "size=%u available=%d garbage collections=" A68_LD, A68 (heap_size), heap_available (), A68_GC (sweeps)) >= 0); WRITELN (f, A68 (output_line)); for (; z != NO_HANDLE; FORWARD (z), k++) { if (n > 0 && sum <= top) { n--; indent_crlf (f); ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "heap(%p+%d) %s", (void *) POINTER (z), SIZE (z), moid_to_string (MOID (z), MOID_WIDTH, NO_NODE)) >= 0); WRITE (f, A68 (output_line)); sum += SIZE (z); } } ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "printed %d out of %d handles", m, k) >= 0); WRITELN (f, A68 (output_line)); } //! @brief Search current frame and print it. void stack_dump_current (FILE_T f, ADDR_T a68_link) { if (a68_link > 0) { int dynamic_a68_link = FRAME_DYNAMIC_LINK (a68_link); NODE_T *p = FRAME_TREE (a68_link); if (p != NO_NODE && LEVEL (TABLE (p)) > 3) { if (FRAME_NUMBER (a68_link) == A68_MON (current_frame)) { int printed = 0; show_stack_frame (f, p, a68_link, &printed); } else { stack_dump_current (f, dynamic_a68_link); } } } } //! @brief Overview of the stack. void stack_a68_link_dump (FILE_T f, ADDR_T a68_link, int depth, int *printed) { if (depth > 0 && a68_link > 0) { NODE_T *p = FRAME_TREE (a68_link); if (p != NO_NODE && LEVEL (TABLE (p)) > 3) { show_stack_frame (f, p, a68_link, printed); stack_a68_link_dump (f, FRAME_STATIC_LINK (a68_link), depth - 1, printed); } } } //! @brief Overview of the stack. void stack_dump (FILE_T f, ADDR_T a68_link, int depth, int *printed) { if (depth > 0 && a68_link > 0) { NODE_T *p = FRAME_TREE (a68_link); if (p != NO_NODE && LEVEL (TABLE (p)) > 3) { show_stack_frame (f, p, a68_link, printed); stack_dump (f, FRAME_DYNAMIC_LINK (a68_link), depth - 1, printed); } } } //! @brief Overview of the stack. void stack_trace (FILE_T f, ADDR_T a68_link, int depth, int *printed) { if (depth > 0 && a68_link > 0) { int dynamic_a68_link = FRAME_DYNAMIC_LINK (a68_link); if (FRAME_PROC_FRAME (a68_link)) { NODE_T *p = FRAME_TREE (a68_link); show_stack_frame (f, p, a68_link, printed); stack_trace (f, dynamic_a68_link, depth - 1, printed); } else { stack_trace (f, dynamic_a68_link, depth, printed); } } } //! @brief Examine tags. void examine_tags (FILE_T f, NODE_T * p, ADDR_T a68_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, a68_link, printed); show_frame_item (f, p, a68_link, q, PRIO (q)); } } } //! @brief Search symbol in stack. void examine_stack (FILE_T f, ADDR_T a68_link, char *sym, int *printed) { if (a68_link > 0) { int dynamic_a68_link = FRAME_DYNAMIC_LINK (a68_link); NODE_T *p = FRAME_TREE (a68_link); if (p != NO_NODE) { TABLE_T *q = TABLE (p); examine_tags (f, p, a68_link, IDENTIFIERS (q), sym, printed); examine_tags (f, p, a68_link, OPERATORS (q), sym, printed); } examine_stack (f, dynamic_a68_link, sym, printed); } } //! @brief Set or reset breakpoints. void change_breakpoints (NODE_T * p, unt 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) { a68_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) { a68_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) { a68_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) { a68_free (EXPR (INFO (p))); } EXPR (INFO (p)) = NO_TEXT; } } } } //! @brief List breakpoints. 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. BOOL_T single_stepper (NODE_T * p, char *cmd) { A68_MON (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, A68_FP, k, &printed); } else if (k == 0) { stack_trace (STDOUT_FILENO, A68_FP, 3, &printed); } return A68_FALSE; } else if (match_string (cmd, "Continue", NULL_CHAR) || match_string (cmd, "Resume", NULL_CHAR)) { A68 (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 (A68 (output_line), SNPRINTF_SIZE, "return code %d", system (sym)) >= 0); WRITELN (STDOUT_FILENO, A68 (output_line)); } return A68_FALSE; } else if (match_string (cmd, "ELems", BLANK_CHAR)) { int k = get_num_arg (cmd, NO_VAR); if (k > 0) { A68_MON (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 = A68_SP; evaluate (STDOUT_FILENO, p, sym); if (A68_MON (mon_errors) == 0 && A68_MON (_m_sp) > 0) { MOID_T *res; BOOL_T cont = A68_TRUE; while (cont) { res = A68_MON (_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_REF (res) && !IS_NIL (*(A68_REF *) STACK_ADDRESS (old_sp))); if (cont) { A68_REF z; POP_REF (p, &z); A68_MON (_m_stack)[0] = SUB (A68_MON (_m_stack)[0]); PUSH (p, ADDRESS (&z), SIZE (A68_MON (_m_stack)[0])); } } } else { monitor_error (CANNOT_SHOW, NO_TEXT); } A68_SP = old_sp; A68_MON (_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, A68_FP, 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 (A68_MON (current_frame) == 0) { int printed = 0; stack_dump (STDOUT_FILENO, A68_FP, 1, &printed); } else { stack_dump_current (STDOUT_FILENO, A68_FP); } return A68_FALSE; } else if (match_string (cmd, "Frame", BLANK_CHAR)) { int n = get_num_arg (cmd, NO_VAR); A68_MON (current_frame) = (n > 0 ? n : 0); stack_dump_current (STDOUT_FILENO, A68_FP); return A68_FALSE; } else if (match_string (cmd, "HEAp", BLANK_CHAR)) { int top = get_num_arg (cmd, NO_VAR); if (top <= 0) { top = A68 (heap_size); } show_heap (STDOUT_FILENO, p, A68_GC (busy_handles), top, A68 (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)) { A68 (halt_typing) = A68_TRUE; A68 (do_confirm_exit) = A68_TRUE; return A68_TRUE; } else if (match_string (cmd, "RT", NULL_CHAR)) { A68 (halt_typing) = A68_FALSE; A68 (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 (&A68_JOB), &listed); if (listed == 0) { WRITELN (STDOUT_FILENO, "No breakpoints set"); } if (A68_MON (watchpoint_expression) != NO_TEXT) { WRITELN (STDOUT_FILENO, "Watchpoint condition \""); WRITE (STDOUT_FILENO, A68_MON (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 (&A68_JOB), 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 (&A68_JOB), 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 (&A68_JOB), 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 (&A68_JOB), &listed); if (listed == 0) { WRITELN (STDOUT_FILENO, "No breakpoints set"); } if (A68_MON (watchpoint_expression) != NO_TEXT) { WRITELN (STDOUT_FILENO, "Watchpoint condition \""); WRITE (STDOUT_FILENO, A68_MON (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 (A68_MON (watchpoint_expression) != NO_TEXT) { a68_free (A68_MON (watchpoint_expression)); A68_MON (watchpoint_expression) = NO_TEXT; } A68_MON (watchpoint_expression) = new_string (cexpr, NO_TEXT); change_masks (TOP_NODE (&A68_JOB), 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 (&A68_JOB), NULL_MASK, 0, NULL, NULL); if (A68_MON (watchpoint_expression) != NO_TEXT) { a68_free (A68_MON (watchpoint_expression)); A68_MON (watchpoint_expression) = NO_TEXT; } change_masks (TOP_NODE (&A68_JOB), BREAKPOINT_WATCH_MASK, A68_FALSE); } else if (match_string (mod, "ALL", NULL_CHAR)) { change_breakpoints (TOP_NODE (&A68_JOB), NULL_MASK, 0, NULL, NULL); if (A68_MON (watchpoint_expression) != NO_TEXT) { a68_free (A68_MON (watchpoint_expression)); A68_MON (watchpoint_expression) = NO_TEXT; } change_masks (TOP_NODE (&A68_JOB), BREAKPOINT_WATCH_MASK, A68_FALSE); } else if (match_string (mod, "Breakpoints", NULL_CHAR)) { change_breakpoints (TOP_NODE (&A68_JOB), NULL_MASK, 0, NULL, NULL); } else if (match_string (mod, "Watchpoint", NULL_CHAR)) { if (A68_MON (watchpoint_expression) != NO_TEXT) { a68_free (A68_MON (watchpoint_expression)); A68_MON (watchpoint_expression) = NO_TEXT; } change_masks (TOP_NODE (&A68_JOB), 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 (A68_MON (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 (&A68_JOB), NULL_MASK, 0, NULL, NULL); if (A68_MON (watchpoint_expression) != NO_TEXT) { a68_free (A68_MON (watchpoint_expression)); A68_MON (watchpoint_expression) = NO_TEXT; } change_masks (TOP_NODE (&A68_JOB), 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_a68_link_dump (STDOUT_FILENO, A68_FP, k, &printed); } else if (k == NOT_A_NUM) { stack_a68_link_dump (STDOUT_FILENO, A68_FP, 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, A68_FP, k, &printed); } else if (k == NOT_A_NUM) { stack_dump (STDOUT_FILENO, A68_FP, 3, &printed); } return A68_FALSE; } else if (match_string (cmd, "Next", NULL_CHAR)) { change_masks (TOP_NODE (&A68_JOB), BREAKPOINT_TEMPORARY_MASK, A68_TRUE); A68 (do_confirm_exit) = A68_FALSE; A68_MON (break_proc_level) = PROCEDURE_LEVEL (INFO (p)); return A68_TRUE; } else if (match_string (cmd, "STEp", NULL_CHAR)) { change_masks (TOP_NODE (&A68_JOB), BREAKPOINT_TEMPORARY_MASK, A68_TRUE); A68 (do_confirm_exit) = A68_FALSE; return A68_TRUE; } else if (match_string (cmd, "FINish", NULL_CHAR) || match_string (cmd, "OUT", NULL_CHAR)) { A68_MON (finish_frame_pointer) = FRAME_PARAMETERS (A68_FP); A68 (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 (&A68_JOB), BREAKPOINT_TEMPORARY_MASK, k, &set, NULL); if (set == A68_FALSE) { monitor_error ("cannot set breakpoint in that line", NO_TEXT); return A68_FALSE; } A68 (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, A68_MON (prompt), "monitor"); return A68_FALSE; } else if (match_string (cmd, "Sizes", NULL_CHAR)) { ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "Frame stack pointer=" A68_LU " available=" A68_LU, A68_FP, A68 (frame_stack_size) - A68_FP) >= 0); WRITELN (STDOUT_FILENO, A68 (output_line)); ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "Expression stack pointer=" A68_LU " available=" A68_LU, A68_SP, (UNSIGNED_T) (A68 (expr_stack_size) - A68_SP)) >= 0); WRITELN (STDOUT_FILENO, A68 (output_line)); ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "Heap size=%u available=%u", A68 (heap_size), heap_available ()) >= 0); WRITELN (STDOUT_FILENO, A68 (output_line)); ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "Garbage collections=" A68_LD, A68_GC (sweeps)) >= 0); WRITELN (STDOUT_FILENO, A68 (output_line)); return A68_FALSE; } else if (match_string (cmd, "XRef", NULL_CHAR)) { int k = LINE_NUMBER (p); LINE_T *line = TOP_LINE (&A68_JOB); 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 (&A68_JOB); 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. BOOL_T evaluate_breakpoint_expression (NODE_T * p) { ADDR_T top_sp = A68_SP; volatile BOOL_T res = A68_FALSE; A68_MON (mon_errors) = 0; if (EXPR (INFO (p)) != NO_TEXT) { evaluate (STDOUT_FILENO, p, EXPR (INFO (p))); if (A68_MON (_m_sp) != 1 || A68_MON (mon_errors) != 0) { A68_MON (mon_errors) = 0; monitor_error ("deleted invalid breakpoint expression", NO_TEXT); if (EXPR (INFO (p)) != NO_TEXT) { a68_free (EXPR (INFO (p))); } EXPR (INFO (p)) = A68_MON (expr); res = A68_TRUE; } else if (TOP_MODE == M_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) { a68_free (EXPR (INFO (p))); } EXPR (INFO (p)) = A68_MON (expr); res = A68_TRUE; } } A68_SP = top_sp; return res; } //! @brief Evaluate conditional watchpoint expression. BOOL_T evaluate_watchpoint_expression (NODE_T * p) { ADDR_T top_sp = A68_SP; volatile BOOL_T res = A68_FALSE; A68_MON (mon_errors) = 0; if (A68_MON (watchpoint_expression) != NO_TEXT) { evaluate (STDOUT_FILENO, p, A68_MON (watchpoint_expression)); if (A68_MON (_m_sp) != 1 || A68_MON (mon_errors) != 0) { A68_MON (mon_errors) = 0; monitor_error ("deleted invalid watchpoint expression", NO_TEXT); if (A68_MON (watchpoint_expression) != NO_TEXT) { a68_free (A68_MON (watchpoint_expression)); A68_MON (watchpoint_expression) = NO_TEXT; } res = A68_TRUE; } if (TOP_MODE == M_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 (A68_MON (watchpoint_expression) != NO_TEXT) { a68_free (A68_MON (watchpoint_expression)); A68_MON (watchpoint_expression) = NO_TEXT; } res = A68_TRUE; } } A68_SP = top_sp; return res; } //! @brief Execute monitor. void single_step (NODE_T * p, unt mask) { volatile BOOL_T do_cmd = A68_TRUE; ADDR_T top_sp = A68_SP; A68_MON (current_frame) = 0; A68_MON (max_row_elems) = MAX_ROW_ELEMS; A68_MON (mon_errors) = 0; A68_MON (tabs) = 0; A68_MON (prompt_set) = A68_FALSE; if (LINE_NUMBER (p) == 0) { return; } #if defined (HAVE_CURSES) genie_curses_end (NO_NODE); #endif if (mask == (unt) 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 (A68 (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 (A68 (output_line), SNPRINTF_SIZE, "Breakpoint (%s)", EXPR (INFO (p))) >= 0); } else { ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "Breakpoint") >= 0); } WRITELN (STDOUT_FILENO, A68 (output_line)); WIS (p); } else if ((mask & BREAKPOINT_TEMPORARY_MASK) != 0) { if (A68_MON (break_proc_level) != 0 && PROCEDURE_LEVEL (INFO (p)) > A68_MON (break_proc_level)) { return; } change_masks (TOP_NODE (&A68_JOB), 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 (A68_MON (watchpoint_expression) != NO_TEXT) { ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "Watchpoint (%s)", A68_MON (watchpoint_expression)) >= 0); } else { ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "Watchpoint (now removed)") >= 0); } WRITELN (STDOUT_FILENO, A68 (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 (BUILD_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 (A68_MON (prompt_set) == A68_FALSE) { bufcpy (A68_MON (prompt), "(a68g) ", BUFFER_SIZE); A68_MON (prompt_set) = A68_TRUE; } A68_MON (in_monitor) = A68_TRUE; A68_MON (break_proc_level) = 0; change_masks (TOP_NODE (&A68_JOB), BREAKPOINT_INTERRUPT_MASK, A68_FALSE); STATUS_CLEAR (TOP_NODE (&A68_JOB), BREAKPOINT_INTERRUPT_MASK); while (do_cmd) { char *cmd; A68_SP = top_sp; io_close_tty_line (); while (strlen (cmd = read_string_from_tty (A68_MON (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); } A68_MON (_m_sp) = 0; do_cmd = (BOOL_T) (!single_stepper (p, cmd)); } A68_SP = top_sp; A68_MON (in_monitor) = A68_FALSE; if (mask == (unt) BREAKPOINT_ERROR_MASK) { WRITELN (STDOUT_FILENO, "Continuing from an error might corrupt things"); single_step (p, (unt) BREAKPOINT_ERROR_MASK); } else { WRITELN (STDOUT_FILENO, "Continuing ..."); WRITELN (STDOUT_FILENO, ""); } } //! @brief PROC debug = VOID void genie_debug (NODE_T * p) { single_step (p, BREAKPOINT_INTERRUPT_MASK); } //! @brief PROC break = VOID void genie_break (NODE_T * p) { (void) p; change_masks (TOP_NODE (&A68_JOB), BREAKPOINT_INTERRUPT_MASK, A68_TRUE); } //! @brief PROC evaluate = (STRING) STRING void genie_evaluate (NODE_T * p) { A68_REF u, v; v = empty_string (p); // Pop argument. POP_REF (p, (A68_REF *) & u); volatile ADDR_T top_sp = A68_SP; CHECK_MON_REF (p, u, M_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. A68_MON (in_monitor) = A68_TRUE; A68_MON (mon_errors) = 0; evaluate (STDOUT_FILENO, p, get_transput_buffer (UNFORMATTED_BUFFER)); A68_MON (in_monitor) = A68_FALSE; if (A68_MON (_m_sp) != 1) { monitor_error ("invalid expression", NO_TEXT); } if (A68_MON (mon_errors) == 0) { MOID_T *res; BOOL_T cont = A68_TRUE; while (cont) { res = TOP_MODE; cont = (BOOL_T) (IS_REF (res) && !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); } A68_SP = top_sp; PUSH_REF (p, v); } //! @brief PROC abend = (STRING) VOID 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 (A68_RUNTIME_ERROR | A68_NO_SYNTHESIS, p, get_transput_buffer (UNFORMATTED_BUFFER), NO_TEXT); exit_genie (p, A68_RUNTIME_ERROR); } algol68g-3.1.2/src/a68g/postulates.c0000644000175000017500000000472214361065320013771 00000000000000//! @file postulates.c //! @author J. Marcel van der Veer // //! @section Copyright // // This file is part of Algol68G - an Algol 68 compiler-interpreter. // Copyright 2001-2023 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 . // Postulates are for proving A assuming A is true. #include "a68g.h" #include "a68g-prelude.h" #include "a68g-mp.h" #include "a68g-genie.h" #include "a68g-postulates.h" //! @brief Initialise use of postulate-lists. void init_postulates (void) { A68 (top_postulate) = NO_POSTULATE; A68 (top_postulate_list) = NO_POSTULATE; } //! @brief Make old postulates available for new use. 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)) { ; } NEXT (last) = A68 (top_postulate_list); A68 (top_postulate_list) = start; } //! @brief Add postulates to postulate-list. void make_postulate (POSTULATE_T ** p, MOID_T * a, MOID_T * b) { POSTULATE_T *new_one; if (A68 (top_postulate_list) != NO_POSTULATE) { new_one = A68 (top_postulate_list); FORWARD (A68 (top_postulate_list)); } else { new_one = (POSTULATE_T *) get_temp_heap_space ((size_t) SIZE_ALIGNED (POSTULATE_T)); A68 (new_postulates)++; } A (new_one) = a; B (new_one) = b; NEXT (new_one) = *p; *p = new_one; } //! @brief Where postulates are in the list. 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 postulate is in the list. 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; } algol68g-3.1.2/src/a68g/single-math.c0000644000175000017500000003521514361065320013777 00000000000000//! @file single-math.c //! @author J. Marcel van der Veer // //! @section Copyright // // This file is part of Algol68G - an Algol 68 compiler-interpreter. // Copyright 2001-2023 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 . // // References: // // Milton Abramowitz and Irene Stegun, Handbook of Mathematical Functions, // Dover Publications, New York [1970] // https://en.wikipedia.org/wiki/Abramowitz_and_Stegun #include "a68g.h" #include "a68g-genie.h" #include "a68g-prelude.h" #include "a68g-double.h" #include "a68g-numbers.h" #include "a68g-math.h" inline REAL_T a68_max (REAL_T x, REAL_T y) { return (x > y ? x : y); } inline REAL_T a68_min (REAL_T x, REAL_T y) { return (x < y ? x : y); } inline REAL_T a68_sign (REAL_T x) { return (x == 0 ? 0 : (x > 0 ? 1 : -1)); } inline REAL_T a68_int (REAL_T x) { return (x >= 0 ? (INT_T) x : -(INT_T) - x); } inline INT_T a68_round (REAL_T x) { return (INT_T) (x >= 0 ? x + 0.5 : x - 0.5); } #define IS_INTEGER(n) (n == a68_int (n)) inline REAL_T a68_abs (REAL_T x) { return (x >= 0 ? x : -x); } REAL_T a68_fdiv (REAL_T x, REAL_T y) { // This is for generating +-INF. return x / y; } REAL_T a68_nan (void) { return a68_fdiv (0.0, 0.0); } REAL_T a68_posinf (void) { return a68_fdiv (+1.0, 0.0); } REAL_T a68_neginf (void) { return a68_fdiv (-1.0, 0.0); } // REAL infinity void genie_infinity_real (NODE_T * p) { PUSH_VALUE (p, a68_posinf (), A68_REAL); } // REAL minus infinity void genie_minus_infinity_real (NODE_T * p) { PUSH_VALUE (p, a68_neginf (), A68_REAL); } int a68_finite (REAL_T x) { #if defined (HAVE_ISFINITE) return isfinite (x); #elif defined (HAVE_FINITE) return finite (x); #else (void) x; return A68_TRUE; #endif } int a68_isnan (REAL_T x) { #if defined (HAVE_ISNAN) return isnan (x); #elif defined (HAVE_IEEE_COMPARISONS) int status = (x != x); return status; #else return A68_FALSE; #endif } int a68_isinf (REAL_T x) { #if defined (HAVE_ISINF) if (isinf (x)) { return (x > 0) ? 1 : -1; } else { return 0; } #else if (!a68_finite (x) && !a68_isnan (x)) { return (x > 0 ? 1 : -1); } else { return 0; } #endif } // INT operators INT_T a68_add_int (INT_T j, INT_T k) { if (j >= 0) { A68_OVERFLOW (A68_MAX_INT - j < k); } else { A68_OVERFLOW (k < (-A68_MAX_INT) - j); } return j + k; } INT_T a68_sub_int (INT_T j, INT_T k) { return a68_add_int (j, -k); } INT_T a68_mul_int (INT_T j, INT_T k) { if (j == 0 || k == 0) { return 0; } else { INT_T u = (j > 0 ? j : -j), v = (k > 0 ? k : -k); A68_OVERFLOW (u > A68_MAX_INT / v); return j * k; } } INT_T a68_over_int (INT_T j, INT_T k) { A68_INVALID (k == 0); return j / k; } INT_T a68_mod_int (INT_T j, INT_T k) { A68_INVALID (k == 0); INT_T r = j % k; return (r < 0 ? (k > 0 ? r + k : r - k) : r); } // OP ** = (INT, INT) INT INT_T a68_m_up_n (INT_T m, INT_T n) { // Only positive n. A68_INVALID (n < 0); // Special cases. if (m == 0 || m == 1) { return m; } else if (m == -1) { return (EVEN (n) ? 1 : -1); } // General case with overflow check. UNSIGNED_T bit = 1; INT_T M = m, P = 1; do { if (n & bit) { P = a68_mul_int (P, M); } bit <<= 1; if (bit <= n) { M = a68_mul_int (M, M); } } while (bit <= n); return P; } // OP ** = (REAL, INT) REAL REAL_T a68_x_up_n (REAL_T x, INT_T n) { // Only positive n. if (n < 0) { return 1 / a68_x_up_n (x, -n); } // Special cases. if (x == 0 || x == 1) { return x; } else if (x == -1) { return (EVEN (n) ? 1 : -1); } // General case. UNSIGNED_T bit = 1; REAL_T M = x, P = 1; do { if (n & bit) { P *= M; } bit <<= 1; if (bit <= n) { M *= M; } } while (bit <= n); A68_OVERFLOW (!finite (P)); return P; } REAL_T a68_div_int (INT_T j, INT_T k) { A68_INVALID (k == 0); return (REAL_T) j / (REAL_T) k; } // Sqrt (x^2 + y^2) that does not needlessly overflow. REAL_T a68_hypot (REAL_T x, REAL_T y) { REAL_T xabs = ABS (x), yabs = ABS (y), min, max; if (xabs < yabs) { min = xabs; max = yabs; } else { min = yabs; max = xabs; } if (min == 0) { return max; } else { REAL_T u = min / max; return max * sqrt (1 + u * u); } } //! @brief Compute Chebyshev series to requested accuracy. REAL_T a68_chebyshev (REAL_T x, const REAL_T c[], REAL_T acc) { // Iteratively compute the recursive Chebyshev series. // c[1..N] are coefficients, c[0] is N, and acc is relative accuracy. acc *= MATH_EPSILON; if (acc < c[1]) { diagnostic (A68_MATH_WARNING, A68 (f_entry), WARNING_MATH_ACCURACY, NULL); } INT_T i, N = a68_round (c[0]); REAL_T err = 0, z = 2 * x, u = 0, v = 0, w = 0; for (i = 1; i <= N; i++) { if (err > acc) { w = v; v = u; u = z * v - w + c[i]; } err += a68_abs (c[i]); } return 0.5 * (u - w); } // Compute ln (1 + x) accurately. // Some C99 platforms implement this incorrectly. REAL_T a68_ln1p (REAL_T x) { // Based on GNU GSL's gsl_sf_log_1plusx_e. A68_INVALID (x <= -1); if (a68_abs (x) < pow (DBL_EPSILON, 1 / 6.0)) { const REAL_T c1 = -0.5, c2 = 1 / 3.0, c3 = -1 / 4.0, c4 = 1 / 5.0, c5 = -1 / 6.0, c6 = 1 / 7.0, c7 = -1 / 8.0, c8 = 1 / 9.0, c9 = -1 / 10.0; const REAL_T t = c5 + x * (c6 + x * (c7 + x * (c8 + x * c9))); return x * (1 + x * (c1 + x * (c2 + x * (c3 + x * (c4 + x * t))))); } else if (a68_abs (x) < 0.5) { REAL_T t = (8 * x + 1) / (x + 2) / 2; return x * a68_chebyshev (t, c_ln1p, 0.1); } else { return ln (1 + x); } } // Compute ln (x), if possible accurately when x ~ 1. REAL_T a68_ln (REAL_T x) { A68_INVALID (x <= 0); #if (A68_LEVEL >= 3) if (a68_abs (x - 1) < 0.375) { // Double precision x-1 mitigates cancellation error. return a68_ln1p (DBLEQ (x) - 1.0q); } else { return ln (x); } #else return ln (x); #endif } // PROC (REAL) REAL exp REAL_T a68_exp (REAL_T x) { A68_INVALID (x < LOG_DBL_MIN || x > LOG_DBL_MAX); return exp (x); } // OP ** = (REAL, REAL) REAL REAL_T a68_x_up_y (REAL_T x, REAL_T y) { return a68_exp (y * a68_ln (x)); } // PROC (REAL) REAL csc REAL_T a68_csc (REAL_T x) { REAL_T z = sin (x); A68_OVERFLOW (z == 0); return 1 / z; } // PROC (REAL) REAL acsc REAL_T a68_acsc (REAL_T x) { A68_OVERFLOW (x == 0); return asin (1 / x); } // PROC (REAL) REAL sec REAL_T a68_sec (REAL_T x) { REAL_T z = cos (x); A68_OVERFLOW (z == 0); return 1 / z; } // PROC (REAL) REAL asec REAL_T a68_asec (REAL_T x) { A68_OVERFLOW (x == 0); return acos (1 / x); } // PROC (REAL) REAL cot REAL_T a68_cot (REAL_T x) { REAL_T z = sin (x); A68_OVERFLOW (z == 0); return cos (x) / z; } // PROC (REAL) REAL acot REAL_T a68_acot (REAL_T x) { A68_OVERFLOW (x == 0); return atan (1 / x); } // PROC atan2 (REAL, REAL) REAL REAL_T a68_atan2 (REAL_T x, REAL_T y) { if (x == 0) { A68_INVALID (y == 0); return (y > 0 ? CONST_PI_2 : -CONST_PI_2); } else { REAL_T z = atan (ABS (y / x)); if (x < 0) { z = CONST_PI - z; } return (y >= 0 ? z : -z); } } //! brief PROC (REAL) REAL sindg REAL_T a68_sindg (REAL_T x) { return sin (x * CONST_PI_OVER_180); } //! brief PROC (REAL) REAL cosdg REAL_T a68_cosdg (REAL_T x) { return cos (x * CONST_PI_OVER_180); } //! brief PROC (REAL) REAL tandg REAL_T a68_tandg (REAL_T x) { return tan (x * CONST_PI_OVER_180); } //! brief PROC (REAL) REAL asindg REAL_T a68_asindg (REAL_T x) { return asin (x) * CONST_180_OVER_PI; } //! brief PROC (REAL) REAL acosdg REAL_T a68_acosdg (REAL_T x) { return acos (x) * CONST_180_OVER_PI; } //! brief PROC (REAL) REAL atandg REAL_T a68_atandg (REAL_T x) { return atan (x) * CONST_180_OVER_PI; } // PROC (REAL) REAL cotdg REAL_T a68_cotdg (REAL_T x) { REAL_T z = a68_sindg (x); A68_OVERFLOW (z == 0); return a68_cosdg (x) / z; } // PROC (REAL) REAL acotdg REAL_T a68_acotdg (REAL_T z) { A68_OVERFLOW (z == 0); return a68_atandg (1 / z); } // @brief PROC (REAL) REAL sinpi REAL_T a68_sinpi (REAL_T x) { x = fmod (x, 2); if (x <= -1) { x += 2; } else if (x > 1) { x -= 2; } // x in <-1, 1]. if (x == 0 || x == 1) { return 0; } else if (x == 0.5) { return 1; } if (x == -0.5) { return -1; } else { return sin (CONST_PI * x); } } // @brief PROC (REAL) REAL cospi REAL_T a68_cospi (REAL_T x) { x = fmod (fabs (x), 2); // x in [0, 2>. if (x == 0.5 || x == 1.5) { return 0; } else if (x == 0) { return 1; } else if (x == 1) { return -1; } else { return cos (CONST_PI * x); } } // @brief PROC (REAL) REAL tanpi REAL_T a68_tanpi (REAL_T x) { x = fmod (x, 1); if (x <= -0.5) { x += 1; } else if (x > 0.5) { x -= 1; } // x in <-1/2, 1/2]. A68_OVERFLOW (x == 0.5); if (x == -0.25) { return -1; } else if (x == 0) { return 0; } else if (x == 0.25) { return 1; } else { return a68_sinpi (x) / a68_cospi (x); } } // @brief PROC (REAL) REAL cotpi REAL_T a68_cotpi (REAL_T x) { x = fmod (x, 1); if (x <= -0.5) { x += 1; } else if (x > 0.5) { x -= 1; } // x in <-1/2, 1/2]. A68_OVERFLOW (x == 0); if (x == -0.25) { return -1; } else if (x == 0.25) { return 1; } else if (x == 0.5) { return 0; } else { return a68_cospi (x) / a68_sinpi (x); } } // @brief PROC (REAL) REAL asinh REAL_T a68_asinh (REAL_T x) { REAL_T a = ABS (x), s = (x < 0 ? -1.0 : 1); if (a > 1 / sqrt (DBL_EPSILON)) { return (s * (a68_ln (a) + a68_ln (2))); } else if (a > 2) { return (s * a68_ln (2 * a + 1 / (a + sqrt (a * a + 1)))); } else if (a > sqrt (DBL_EPSILON)) { REAL_T a2 = a * a; return (s * a68_ln1p (a + a2 / (1 + sqrt (1 + a2)))); } else { return (x); } } // @brief PROC (REAL) REAL acosh REAL_T a68_acosh (REAL_T x) { if (x > 1 / sqrt (DBL_EPSILON)) { return (a68_ln (x) + a68_ln (2)); } else if (x > 2) { return (a68_ln (2 * x - 1 / (sqrt (x * x - 1) + x))); } else if (x > 1) { REAL_T t = x - 1; return (a68_ln1p (t + sqrt (2 * t + t * t))); } else if (x == 1) { return (0); } else { A68_INVALID (A68_TRUE); } } // @brief PROC (REAL) REAL atanh REAL_T a68_atanh (REAL_T x) { REAL_T a = ABS (x); A68_INVALID (a >= 1); REAL_T s = (x < 0 ? -1 : 1); if (a >= 0.5) { return (s * 0.5 * a68_ln1p (2 * a / (1 - a))); } else if (a > DBL_EPSILON) { return (s * 0.5 * a68_ln1p (2 * a + 2 * a * a / (1 - a))); } else { return (x); } } //! @brief Inverse complementary error function. REAL_T a68_inverfc (REAL_T y) { A68_INVALID (y < 0 || y > 2); if (y == 0) { return DBL_MAX; } else if (y == 1) { return 0; } else if (y == 2) { return -DBL_MAX; } else { // Next is based on code that originally contained following statement: // Copyright (c) 1996 Takuya Ooura. You may use, copy, modify this // code for any purpose and without fee. REAL_T s, t, u, v, x, z; z = (y <= 1 ? y : 2 - y); v = c_inverfc[0] - a68_ln (z); u = sqrt (v); s = (a68_ln (u) + c_inverfc[1]) / v; t = 1 / (u + c_inverfc[2]); x = u * (1 - s * (s * c_inverfc[3] + 0.5)) - ((((c_inverfc[4] * t + c_inverfc[5]) * t + c_inverfc[6]) * t + c_inverfc[7]) * t + c_inverfc[8]) * t; t = c_inverfc[9] / (x + c_inverfc[9]); u = t - 0.5; s = (((((((((c_inverfc[10] * u + c_inverfc[11]) * u - c_inverfc[12]) * u - c_inverfc[13]) * u + c_inverfc[14]) * u + c_inverfc[15]) * u - c_inverfc[16]) * u - c_inverfc[17]) * u + c_inverfc[18]) * u + c_inverfc[19]) * u + c_inverfc[20]; s = ((((((((((((s * u - c_inverfc[21]) * u - c_inverfc[22]) * u + c_inverfc[23]) * u + c_inverfc[24]) * u + c_inverfc[25]) * u + c_inverfc[26]) * u + c_inverfc[27]) * u + c_inverfc[28]) * u + c_inverfc[29]) * u + c_inverfc[30]) * u + c_inverfc[31]) * u + c_inverfc[32]) * t - z * a68_exp (x * x - c_inverfc[33]); x += s * (x * s + 1); return (y <= 1 ? x : -x); } } //! @brief Inverse error function. REAL_T a68_inverf (REAL_T y) { return a68_inverfc (1 - y); } //! @brief PROC (REAL, REAL) REAL ln beta REAL_T a68_ln_beta (REAL_T a, REAL_T b) { return lgamma (a) + lgamma (b) - lgamma (a + b); } //! @brief PROC (REAL, REAL) REAL beta REAL_T a68_beta (REAL_T a, REAL_T b) { return a68_exp (a68_ln_beta (a, b)); } //! brief PROC (INT) REAL fact REAL_T a68_fact (INT_T n) { A68_INVALID (n < 0 || n > A68_MAX_FAC); return factable[n]; } //! brief PROC (INT) REAL ln fact REAL_T a68_ln_fact (INT_T n) { A68_INVALID (n < 0); if (n <= A68_MAX_FAC) { return ln_factable[n]; } else { return lgamma (n + 1); } } //! @brief PROC choose = (INT n, m) REAL REAL_T a68_choose (INT_T n, INT_T m) { A68_INVALID (n < m); return factable[n] / (factable[m] * factable[n - m]); } //! @brief PROC ln choose = (INT n, m) REAL REAL_T a68_ln_choose (INT_T n, INT_T m) { A68_INVALID (n < m); return a68_ln_fact (n) - (a68_ln_fact (m) + a68_ln_fact (n - m)); } REAL_T a68_beta_inc (REAL_T s, REAL_T t, REAL_T x) { // Incomplete beta function I{x}(s, t). // Continued fraction, see dlmf.nist.gov/8.17; Lentz's algorithm. if (x < 0 || x > 1) { errno = ERANGE; return -1; } else { const INT_T lim = 16 * sizeof (REAL_T); BOOL_T cont = A68_TRUE; // Rapid convergence when x <= (s+1)/(s+t+2) or else recursion. if (x > (s + 1) / (s + t + 2)) { // B{x}(s, t) = 1 - B{1-x}(t, s) return 1 - a68_beta_inc (s, t, 1 - x); } // Lentz's algorithm for continued fraction. REAL_T W = 1, F = 1, c = 1, d = 0; INT_T N, m; for (N = 0, m = 0; cont && N < lim; N++) { REAL_T T; if (N == 0) { T = 1; } else if (N % 2 == 0) { // d{2m} := x m(t-m)/((s+2m-1)(s+2m)) T = x * m * (t - m) / (s + 2 * m - 1) / (s + 2 * m); } else { // d{2m+1} := -x (s+m)(s+t+m)/((s+2m+1)(s+2m)) T = -x * (s + m) * (s + t + m) / (s + 2 * m + 1) / (s + 2 * m); m++; } d = 1 / (T * d + 1); c = T / c + 1; F *= c * d; if (F == W) { cont = A68_FALSE; } else { W = F; } } // I{x}(s,t)=x^s(1-x)^t / s / B(s,t) F REAL_T beta = a68_exp (lgamma (s) + lgamma (t) - lgamma (s + t)); return a68_x_up_y (x, s) * a68_x_up_y (1 - x, t) / s / beta * (F - 1); } } algol68g-3.1.2/src/a68g/prelude-bits.c0000644000175000017500000000764114361065320014170 00000000000000//! @file prelude-bits.c //! @author J. Marcel van der Veer // //! @section Copyright // // This file is part of Algol68G - an Algol 68 compiler-interpreter. // Copyright 2001-2023 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 (A68_LEVEL <= 2) #include "a68g-optimiser.h" #include "a68g-prelude.h" #include "a68g-transput.h" #include "a68g-mp.h" #include "a68g-parser.h" #include "a68g-physics.h" #include "a68g-double.h" #define A68_STD A68_TRUE #define A68_EXT A68_FALSE void stand_longlong_bits (void) { MOID_T *m; // LONG LONG BITS in software, vintage a68_mode (2, "BITS", &M_LONG_LONG_BITS); // REF LONG LONG BITS MODE (REF_LONG_LONG_BITS) = add_mode (&TOP_MOID (&A68_JOB), REF_SYMBOL, 0, NO_NODE, M_LONG_LONG_BITS, NO_PACK); // [] LONG LONG BITS M_ROW_LONG_LONG_BITS = add_mode (&TOP_MOID (&A68_JOB), ROW_SYMBOL, 1, NO_NODE, M_LONG_LONG_BITS, NO_PACK); HAS_ROWS (M_ROW_LONG_LONG_BITS) = A68_TRUE; SLICE (M_ROW_LONG_LONG_BITS) = M_LONG_LONG_BITS; // a68_idf (A68_STD, "longlongbitswidth", M_INT, genie_long_mp_bits_width); a68_idf (A68_STD, "longlongmaxbits", M_LONG_LONG_BITS, genie_long_mp_max_bits); // m = a68_proc (M_LONG_LONG_BITS, M_ROW_BOOL, NO_MOID); a68_idf (A68_STD, "longlongbitspack", m, genie_long_bits_pack); A68C_DEFIO (longlongbits, long_mp_bits, LONG_LONG_BITS); // m = a68_proc (M_LONG_LONG_BITS, M_LONG_LONG_BITS, NO_MOID); a68_op (A68_STD, "LENG", m, genie_idle); m = a68_proc (M_LONG_LONG_BITS, M_LONG_BITS, NO_MOID); a68_op (A68_STD, "LENG", m, genie_lengthen_mp_to_long_mp); m = a68_proc (M_LONG_LONG_INT, M_LONG_LONG_BITS, NO_MOID); a68_op (A68_STD, "ABS", m, genie_idle); m = a68_proc (M_LONG_LONG_BITS, M_LONG_LONG_INT, NO_MOID); a68_op (A68_STD, "BIN", m, genie_bin_mp); m = a68_proc (M_LONG_LONG_BITS, M_LONG_LONG_BITS, NO_MOID); a68_op (A68_STD, "NOT", m, genie_not_mp); a68_op (A68_STD, "~", m, genie_not_mp); m = a68_proc (M_LONG_BITS, M_LONG_LONG_BITS, NO_MOID); a68_op (A68_STD, "SHORTEN", m, genie_shorten_long_mp_to_mp); m = a68_proc (M_BOOL, M_LONG_LONG_BITS, M_LONG_LONG_BITS, NO_MOID); a68_op (A68_STD, "=", m, genie_eq_mp); a68_op (A68_STD, "EQ", m, genie_eq_mp); a68_op (A68_STD, "/=", m, genie_ne_mp); a68_op (A68_STD, "~=", m, genie_ne_mp); a68_op (A68_STD, "^=", m, genie_ne_mp); a68_op (A68_STD, "NE", m, genie_ne_mp); a68_op (A68_STD, "<=", m, genie_le_mp); a68_op (A68_STD, "LE", m, genie_le_mp); a68_op (A68_STD, ">=", m, genie_ge_mp); a68_op (A68_STD, "GE", m, genie_ge_mp); m = a68_proc (M_LONG_LONG_BITS, M_LONG_LONG_BITS, M_LONG_LONG_BITS, NO_MOID); a68_op (A68_STD, "AND", m, genie_and_mp); a68_op (A68_STD, "&", m, genie_and_mp); a68_op (A68_STD, "OR", m, genie_or_mp); a68_op (A68_EXT, "XOR", m, genie_xor_mp); m = a68_proc (M_LONG_LONG_BITS, M_LONG_LONG_BITS, M_INT, NO_MOID); a68_op (A68_STD, "SHL", m, genie_shl_mp); a68_op (A68_STD, "UP", m, genie_shl_mp); a68_op (A68_STD, "SHR", m, genie_shr_mp); a68_op (A68_STD, "DOWN", m, genie_shr_mp); m = a68_proc (M_BOOL, M_INT, M_LONG_LONG_BITS, NO_MOID); a68_op (A68_STD, "ELEM", m, genie_elem_long_mp_bits); m = a68_proc (M_LONG_LONG_BITS, M_INT, M_LONG_LONG_BITS, NO_MOID); a68_op (A68_STD, "SET", m, genie_set_long_mp_bits); a68_op (A68_STD, "CLEAR", m, genie_clear_long_mp_bits); } #endif algol68g-3.1.2/src/a68g/io.c0000644000175000017500000001425014361065320012172 00000000000000//! @file io.c //! @author J. Marcel van der Veer // //! @section Copyright // // This file is part of Algol68G - an Algol 68 compiler-interpreter. // Copyright 2001-2023 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" #include "a68g-prelude.h" //! @brief Initialise output to STDOUT. void init_tty (void) { A68 (chars_in_tty_line) = 0; A68 (halt_typing) = A68_FALSE; change_masks (TOP_NODE (&A68_JOB), BREAKPOINT_INTERRUPT_MASK, A68_FALSE); } //! @brief Terminate current line on STDOUT. void io_close_tty_line (void) { if (A68 (chars_in_tty_line) > 0) { io_write_string (STDOUT_FILENO, NEWLINE_STRING); } } //! @brief Get a char from STDIN. char get_stdin_char (void) { ssize_t j; char ch[4]; errno = 0; j = io_read_conv (STDIN_FILENO, &(ch[0]), 1); ABEND (j < 0, ERROR_ACTION, __func__); return (char) (j == 1 ? ch[0] : EOF_CHAR); } //! @brief Read string from STDIN, until NEWLINE_STRING. 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 (A68 (input_line), line, BUFFER_SIZE); A68 (chars_in_tty_line) = (int) strlen (A68 (input_line)); a68_free (line); return A68 (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) { A68 (input_line)[0] = EOF_CHAR; A68 (input_line)[1] = NULL_CHAR; A68 (chars_in_tty_line) = 1; return A68 (input_line); } else { A68 (input_line)[k++] = (char) ch; ch = get_stdin_char (); } } A68 (input_line)[k] = NULL_CHAR; n = (int) strlen (A68 (input_line)); A68 (chars_in_tty_line) = (ch == NEWLINE_CHAR ? 0 : (n > 0 ? n : 1)); return A68 (input_line); #endif } //! @brief Write string to file. void io_write_string (FILE_T f, const char *z) { ssize_t j; errno = 0; if (f != STDOUT_FILENO && f != STDERR_FILENO) { // Writing to file. j = io_write_conv (f, z, strlen (z)); ABEND (j < 0, ERROR_ACTION, __func__); } 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, ERROR_ACTION, __func__); A68 (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, ERROR_ACTION, __func__); A68 (chars_in_tty_line) = 0; } } while (z[k] != NULL_CHAR); } } //! @brief Read bytes from file into buffer. 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 (BUILD_WIN32) int bytes_read; #else ssize_t bytes_read; #endif errno = 0; bytes_read = read (fd, z, to_do); if (bytes_read < 0) { if (errno == EINTR) { // interrupt, retry. bytes_read = 0; if (restarts++ > MAX_RESTART) { return -1; } } else { // read error. return -1; } } else if (bytes_read == 0) { 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. 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; errno = 0; 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. 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 (BUILD_WIN32) int bytes_read; #else ssize_t bytes_read; #endif errno = 0; bytes_read = read (fd, z, to_do); if (bytes_read < 0) { if (errno == EINTR) { // interrupt, retry. bytes_read = 0; if (restarts++ > MAX_RESTART) { return -1; } } else { // read error. return -1; } } else if (bytes_read == 0) { 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. 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; errno = 0; 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; } algol68g-3.1.2/src/a68g/apropos.c0000644000175000017500000002033314361065320013245 00000000000000//! @file apropos.c //! @author J. Marcel van der Veer // //! @section Copyright // // This file is part of Algol68G - an Algol 68 compiler-interpreter. // Copyright 2001-2023 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" #include "a68g-prelude.h" #include "a68g-mp.h" #include "a68g-genie.h" // 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. void print_info (FILE_T f, char *prompt, int k) { if (prompt != NO_TEXT) { ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "%s %s: %s.", prompt, TERM (&info_text[k]), DEF (&info_text[k])) >= 0); } else { ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "%s: %s.", TERM (&info_text[k]), DEF (&info_text[k])) >= 0); } WRITE (f, A68 (output_line)); WRITELN (f, ""); } //! @brief Apropos. void apropos (FILE_T f, char *prompt, char *item) { int k, n = 0; io_close_tty_line (); 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++; } } } algol68g-3.1.2/src/a68g/genie.c0000644000175000017500000024740714361065320012666 00000000000000//! @file genie.c //! @author J. Marcel van der Veer // //! @section Copyright // // This file is part of Algol68G - an Algol 68 compiler-interpreter. // Copyright 2001-2023 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" #include "a68g-genie.h" #include "a68g-frames.h" #include "a68g-prelude.h" #include "a68g-mp.h" #include "a68g-double.h" #include "a68g-parser.h" #include "a68g-transput.h" //! @brief Nop for the genie, for instance '+' for INT or REAL. void genie_idle (NODE_T * p) { (void) p; } //! @brief Unimplemented feature handler. void genie_unimplemented (NODE_T * p) { diagnostic (A68_RUNTIME_ERROR, p, ERROR_UNIMPLEMENTED); exit_genie (p, A68_RUNTIME_ERROR); } //! @brief PROC sleep = (INT) INT void genie_sleep (NODE_T * p) { A68_INT secs; int wait; POP_OBJECT (p, &secs, A68_INT); wait = VALUE (&secs); PRELUDE_ERROR (wait < 0, p, ERROR_INVALID_ARGUMENT, M_INT); while (wait > 0) { wait = (int) sleep ((unt) wait); } PUSH_VALUE (p, (INT_T) 0, A68_INT); } //! @brief PROC system = (STRING) INT 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), M_STRING); size = 1 + a68_string_size (p, cmd); ref_z = heap_generator (p, M_C_STRING, 1 + size); sys_ret_code = system (a_to_c_string (p, DEREF (char, &ref_z), cmd)); PUSH_VALUE (p, sys_ret_code, A68_INT); } //! @brief Set flags throughout tree. void change_masks (NODE_T * p, unt 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. void exit_genie (NODE_T * p, int ret) { #if defined (HAVE_CURSES) genie_curses_end (p); #endif A68 (close_tty_on_exit) = A68_TRUE; if (!A68 (in_execution)) { return; } if (ret == A68_RUNTIME_ERROR && A68 (in_monitor)) { return; } else if (ret == A68_RUNTIME_ERROR && OPTION_DEBUG (&A68_JOB)) { diagnostics_to_terminal (TOP_LINE (&A68_JOB), A68_RUNTIME_ERROR); single_step (p, (unt) BREAKPOINT_ERROR_MASK); A68 (in_execution) = A68_FALSE; A68 (ret_line_number) = LINE_NUMBER (p); A68 (ret_code) = ret; longjmp (A68 (genie_exit_label), 1); } else { if ((ret & A68_FORCE_QUIT) != NULL_MASK) { ret &= ~A68_FORCE_QUIT; } #if defined (BUILD_PARALLEL_CLAUSE) if (!is_main_thread ()) { genie_set_exit_from_threads (ret); } else { A68 (in_execution) = A68_FALSE; A68 (ret_line_number) = LINE_NUMBER (p); A68 (ret_code) = ret; longjmp (A68 (genie_exit_label), 1); } #else A68 (in_execution) = A68_FALSE; A68 (ret_line_number) = LINE_NUMBER (p); A68 (ret_code) = ret; longjmp (A68 (genie_exit_label), 1); #endif } } //! @brief Genie init rng. void genie_init_rng (void) { time_t t; if (time (&t) != -1) { init_rng ((unt) t); } } //! @brief Tie label to the clause it is defined in. 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. 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. 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. int mode_attribute (MOID_T * p) { if (IS_REF (p)) { return REF_SYMBOL; } else if (IS (p, PROC_SYMBOL)) { return PROC_SYMBOL; } else if (IS_UNION (p)) { return UNION_SYMBOL; } else if (p == M_INT) { return MODE_INT; } else if (p == M_LONG_INT) { return MODE_LONG_INT; } else if (p == M_LONG_LONG_INT) { return MODE_LONG_LONG_INT; } else if (p == M_REAL) { return MODE_REAL; } else if (p == M_LONG_REAL) { return MODE_LONG_REAL; } else if (p == M_LONG_LONG_REAL) { return MODE_LONG_LONG_REAL; } else if (p == M_COMPLEX) { return MODE_COMPLEX; } else if (p == M_LONG_COMPLEX) { return MODE_LONG_COMPLEX; } else if (p == M_LONG_LONG_COMPLEX) { return MODE_LONG_LONG_COMPLEX; } else if (p == M_BOOL) { return MODE_BOOL; } else if (p == M_CHAR) { return MODE_CHAR; } else if (p == M_BITS) { return MODE_BITS; } else if (p == M_LONG_BITS) { return MODE_LONG_BITS; } else if (p == M_LONG_LONG_BITS) { return MODE_LONG_LONG_BITS; } else if (p == M_BYTES) { return MODE_BYTES; } else if (p == M_LONG_BYTES) { return MODE_LONG_BYTES; } else if (p == M_FILE) { return MODE_FILE; } else if (p == M_FORMAT) { return MODE_FORMAT; } else if (p == M_PIPE) { return MODE_PIPE; } else if (p == M_SOUND) { return MODE_SOUND; } else { return MODE_NO_CHECK; } } //! @brief Perform tasks before interpretation. void genie_preprocess (NODE_T * p, int *max_lev, void *compile_lib) { #if defined (BUILD_A68_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 (BUILD_A68_COMPILER) if (OPTION_OPT_LEVEL (&A68_JOB) > 0 && COMPILE_NAME (GINFO (p)) != NO_TEXT && compile_lib != NULL) { if (COMPILE_NAME (GINFO (p)) == last_compile_name) { // We copy. UNIT (&GPROP (p)) = last_compile_unit; } else { // We look up. // Next line may provoke a warning even with this POSIX workaround. Tant pis. *(void **) &(UNIT (&GPROP (p))) = dlsym (compile_lib, COMPILE_NAME (GINFO (p))); ABEND (UNIT (&GPROP (p)) == NULL, ERROR_INTERNAL_CONSISTENCY, 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_REF (MOID (p))) { 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)) = &(A68_STACK[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)) = &(A68_STACK[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. 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) < A68 (global_level)) { A68 (global_level) = LEX_LEVEL (p); } } get_global_level (SUB (p)); } } //! @brief Driver for the interpreter. void genie (void *compile_lib) { MOID_T *m; // Fill in final info for modes. for (m = TOP_MOID (&A68_JOB); m != NO_MOID; FORWARD (m)) { SIZE (m) = moid_size (m); DIGITS (m) = moid_digits (m); SHORT_ID (m) = mode_attribute (m); } // Preprocessing. A68 (max_lex_lvl) = 0; // genie_lex_levels (TOP_NODE (&A68_JOB), 1);. genie_preprocess (TOP_NODE (&A68_JOB), &A68 (max_lex_lvl), compile_lib); change_masks (TOP_NODE (&A68_JOB), BREAKPOINT_INTERRUPT_MASK, A68_FALSE); A68_MON (watchpoint_expression) = NO_TEXT; A68 (frame_stack_limit) = A68 (frame_end) - A68 (storage_overhead); A68 (expr_stack_limit) = A68 (stack_end) - A68 (storage_overhead); if (OPTION_REGRESSION_TEST (&A68_JOB)) { init_rng (1); } else { genie_init_rng (); } io_close_tty_line (); if (OPTION_TRACE (&A68_JOB)) { ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "genie: frame stack %uk, expression stack %uk, heap %uk, handles %uk\n", A68 (frame_stack_size) / KILOBYTE, A68 (expr_stack_size) / KILOBYTE, A68 (heap_size) / KILOBYTE, A68 (handle_pool_size) / KILOBYTE) >= 0); WRITE (STDOUT_FILENO, A68 (output_line)); } install_signal_handlers (); set_default_event_procedure (&A68 (on_gc_event)); A68 (do_confirm_exit) = A68_TRUE; #if defined (BUILD_PARALLEL_CLAUSE) ASSERT (pthread_mutex_init (&A68_PAR (unit_sema), NULL) == 0); #endif // Dive into the program. if (setjmp (A68 (genie_exit_label)) == 0) { NODE_T *p = SUB (TOP_NODE (&A68_JOB)); // If we are to stop in the monitor, set a breakpoint on the first unit. if (OPTION_DEBUG (&A68_JOB)) { change_masks (TOP_NODE (&A68_JOB), BREAKPOINT_TEMPORARY_MASK, A68_TRUE); WRITE (STDOUT_FILENO, "Execution begins ..."); } errno = 0; A68 (ret_code) = 0; A68 (global_level) = INT_MAX; A68_GLOBALS = 0; get_global_level (p); A68_FP = A68 (frame_start); A68_SP = A68 (stack_start); FRAME_DYNAMIC_LINK (A68_FP) = 0; FRAME_DNS (A68_FP) = 0; FRAME_STATIC_LINK (A68_FP) = 0; FRAME_NUMBER (A68_FP) = 0; FRAME_TREE (A68_FP) = (NODE_T *) p; FRAME_LEXICAL_LEVEL (A68_FP) = LEX_LEVEL (p); FRAME_PARAMETER_LEVEL (A68_FP) = LEX_LEVEL (p); FRAME_PARAMETERS (A68_FP) = A68_FP; initialise_frame (p); genie_init_heap (p); genie_init_transput (TOP_NODE (&A68_JOB)); A68 (cputime_0) = seconds (); // Here we go ... A68 (in_execution) = A68_TRUE; A68 (f_entry) = TOP_NODE (&A68_JOB); #if defined (BUILD_UNIX) (void) alarm (1); #endif if (OPTION_TRACE (&A68_JOB)) { WIS (TOP_NODE (&A68_JOB)); } (void) genie_enclosed (TOP_NODE (&A68_JOB)); } else { // Here we have jumped out of the interpreter. What happened?. if (OPTION_DEBUG (&A68_JOB)) { WRITE (STDOUT_FILENO, "Execution discontinued"); } if (A68 (ret_code) == A68_RERUN) { diagnostics_to_terminal (TOP_LINE (&A68_JOB), A68_RUNTIME_ERROR); genie (compile_lib); } else if (A68 (ret_code) == A68_RUNTIME_ERROR) { if (OPTION_BACKTRACE (&A68_JOB)) { int printed = 0; ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "\nStack backtrace") >= 0); WRITE (STDOUT_FILENO, A68 (output_line)); stack_dump (STDOUT_FILENO, A68_FP, 16, &printed); WRITE (STDOUT_FILENO, NEWLINE_STRING); } if (FILE_LISTING_OPENED (&A68_JOB)) { int printed = 0; ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "\nStack backtrace") >= 0); WRITE (FILE_LISTING_FD (&A68_JOB), A68 (output_line)); stack_dump (FILE_LISTING_FD (&A68_JOB), A68_FP, 32, &printed); } } } A68 (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. 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. 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. 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. 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_; if (SEQUENCE (TABLE (p)) == NO_NODE) { int count = 0; genie_find_proc_op (p, &count); PROC_OPS (TABLE (p)) = (BOOL_T) (count > 0); } 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. 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_ALIGNED (A68_REAL)); CHECK_INIT (p, INITIALISED (r), q); CHECK_INIT (p, INITIALISED (i), q); return; } #if (A68_LEVEL >= 3) case MODE_LONG_INT: case MODE_LONG_REAL: case MODE_LONG_BITS: { A68_DOUBLE *z = (A68_DOUBLE *) w; CHECK_INIT (p, INITIALISED (z), q); return; } case MODE_LONG_COMPLEX: { A68_LONG_REAL *r = (A68_LONG_REAL *) w; A68_LONG_REAL *i = (A68_LONG_REAL *) (w + SIZE_ALIGNED (A68_LONG_REAL)); CHECK_INIT (p, INITIALISED (r), q); CHECK_INIT (p, INITIALISED (i), q); return; } case MODE_LONG_LONG_INT: case MODE_LONG_LONG_REAL: case MODE_LONG_LONG_BITS: { MP_T *z = (MP_T *) w; CHECK_INIT (p, (unt) MP_STATUS (z) & INIT_MASK, q); return; } #else case MODE_LONG_INT: case MODE_LONG_LONG_INT: case MODE_LONG_REAL: case MODE_LONG_LONG_REAL: case MODE_LONG_BITS: case MODE_LONG_LONG_BITS: { MP_T *z = (MP_T *) w; CHECK_INIT (p, (unt) MP_STATUS (z) & INIT_MASK, q); return; } case MODE_LONG_COMPLEX: { MP_T *r = (MP_T *) w; MP_T *i = (MP_T *) (w + size_mp ()); CHECK_INIT (p, (unt) r[0] & INIT_MASK, q); CHECK_INIT (p, (unt) i[0] & INIT_MASK, q); return; } #endif case MODE_LONG_LONG_COMPLEX: { MP_T *r = (MP_T *) w; MP_T *i = (MP_T *) (w + size_long_mp ()); CHECK_INIT (p, (unt) r[0] & INIT_MASK, q); CHECK_INIT (p, (unt) 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. PROP_T genie_constant (NODE_T * p) { PUSH (p, CONSTANT (GINFO (p)), SIZE (GINFO (p))); return GPROP (p); } //! @brief Push argument units. 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), A68_FP); SEQUENCE (*seq) = p; (*seq) = p; return; } else if (IS (p, TRIMMER)) { return; } else { genie_argument (SUB (p), seq); } } } //! @brief Evaluate partial call. 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 (M_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 (M_BOOL) + SIZE (MOID (s))]); FORWARD (s); } if (u != NULL && MOID (t) == M_VOID) { // Move to next field in locale. voids++; u = &(u[SIZE (M_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 (M_BOOL)]), v, SIZE (MOID (t))); u = &(u[SIZE (M_BOOL) + SIZE (MOID (s))]); v = &(v[SIZE (MOID (t))]); FORWARD (s); } } A68_SP = pop_sp; LOCALE (&z) = loc; // Is closure complete?. if (voids == 0) { // Closure is complete. Push locale onto the stack and call procedure body. A68_SP = pop_sp; u = POINTER (loc); v = STACK_ADDRESS (A68_SP); s = PACK (pr_mode); for (; s != NO_PACK; FORWARD (s)) { int size = SIZE (MOID (s)); COPY (v, &u[SIZE (M_BOOL)], size); u = &(u[SIZE (M_BOOL) + size]); v = &(v[SIZE (MOID (s))]); INCREMENT_STACK_POINTER (p, size); } genie_call_procedure (p, pr_mode, pproc, M_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. 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 != M_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) { A68_SP = 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 (A68_FP) = 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; } A68_SP = 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 (A68_FP == A68_MON (finish_frame_pointer)) { change_masks (TOP_NODE (&A68_JOB), BREAKPOINT_INTERRUPT_MASK, A68_TRUE); } CLOSE_FRAME; STACK_DNS (p, SUB (pr_mode), A68_FP); } else { OPEN_PROC_FRAME (body, ENVIRON (z)); INIT_STATIC_FRAME (body); FRAME_DNS (A68_FP) = pop_fp; EXECUTE_UNIT_TRACE (body); if (A68_FP == A68_MON (finish_frame_pointer)) { change_masks (TOP_NODE (&A68_JOB), BREAKPOINT_INTERRUPT_MASK, A68_TRUE); } CLOSE_FRAME; STACK_DNS (p, SUB (pr_mode), A68_FP); } } } //! @brief Call event routine. 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. 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), A68_FP); } (void) ((*(PROCEDURE (proc))) (p)); return GPROP (p); } //! @brief Call PROC with arguments and push result. PROP_T genie_call_quick (NODE_T * p) { A68_PROCEDURE z; NODE_T *proc = SUB (p); ADDR_T pop_sp = A68_SP, pop_fp = A68_FP; // 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), A68_FP); } } 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. PROP_T genie_call (NODE_T * p) { PROP_T self; A68_PROCEDURE z; NODE_T *proc = SUB (p); ADDR_T pop_sp = A68_SP, pop_fp = A68_FP; 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)) != M_VOID && MOID (&z) != PARTIAL_LOCALE (GINFO (proc))) { ; } else if (STATUS (&z) & STANDENV_PROC_MASK) { if (UNIT (&GPROP (proc)) == genie_identifier_standenv_proc) { UNIT (&self) = genie_call_standenv_quick; } } return self; } //! @brief Push value of denotation. PROP_T genie_denotation (NODE_T * p) { MOID_T *moid = MOID (p); PROP_T self; UNIT (&self) = genie_denotation; SOURCE (&self) = p; if (moid == M_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 (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 (M_INT)); SIZE (GINFO (p)) = SIZE (M_INT); COPY (CONSTANT (GINFO (p)), &z, SIZE (M_INT)); PUSH_VALUE (p, VALUE ((A68_INT *) (CONSTANT (GINFO (p)))), A68_INT); return self; } if (moid == M_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 (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_ALIGNED (A68_REAL)); SIZE (GINFO (p)) = SIZE_ALIGNED (A68_REAL); COPY (CONSTANT (GINFO (p)), &z, SIZE_ALIGNED (A68_REAL)); PUSH_VALUE (p, VALUE ((A68_REAL *) (CONSTANT (GINFO (p)))), A68_REAL); return self; } #if (A68_LEVEL >= 3) if (moid == M_LONG_INT) { // LONG INT denotation. A68_LONG_INT z; size_t len = (size_t) SIZE_ALIGNED (A68_LONG_INT); NODE_T *s = IS (SUB (p), LONGETY) ? NEXT_SUB (p) : SUB (p); if (genie_string_to_value_internal (p, moid, NSYMBOL (s), (BYTE_T *) & z) == A68_FALSE) { diagnostic (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) len); SIZE (GINFO (p)) = len; COPY (CONSTANT (GINFO (p)), &z, len); PUSH_VALUE (p, VALUE ((A68_LONG_INT *) (CONSTANT (GINFO (p)))), A68_LONG_INT); return self; } if (moid == M_LONG_REAL) { // LONG REAL denotation. A68_LONG_REAL z; NODE_T *s = IS (SUB (p), LONGETY) ? NEXT_SUB (p) : SUB (p); if (genie_string_to_value_internal (p, moid, NSYMBOL (s), (BYTE_T *) & z) == A68_FALSE) { diagnostic (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_ALIGNED (A68_LONG_REAL)); SIZE (GINFO (p)) = SIZE_ALIGNED (A68_LONG_REAL); COPY (CONSTANT (GINFO (p)), &z, SIZE_ALIGNED (A68_LONG_REAL)); PUSH_VALUE (p, VALUE ((A68_LONG_REAL *) (CONSTANT (GINFO (p)))), A68_LONG_REAL); return self; } // LONG BITS denotation. if (moid == M_LONG_BITS) { A68_LONG_BITS z; NODE_T *s = IS (SUB (p), LONGETY) ? NEXT_SUB (p) : SUB (p); if (genie_string_to_value_internal (p, moid, NSYMBOL (s), (BYTE_T *) & z) == A68_FALSE) { diagnostic (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_ALIGNED (A68_LONG_BITS)); SIZE (GINFO (p)) = SIZE_ALIGNED (A68_LONG_BITS); COPY (CONSTANT (GINFO (p)), &z, SIZE_ALIGNED (A68_LONG_BITS)); PUSH_VALUE (p, VALUE ((A68_LONG_BITS *) (CONSTANT (GINFO (p)))), A68_LONG_BITS); return self; } #endif if (moid == M_LONG_INT || moid == M_LONG_LONG_INT) { // [LONG] LONG INT denotation. int digits = DIGITS (moid); int size = SIZE (moid); NODE_T *number; if (IS (SUB (p), SHORTETY) || IS (SUB (p), LONGETY)) { number = NEXT_SUB (p); } else { number = SUB (p); } MP_T *z = nil_mp (p, digits); if (genie_string_to_value_internal (p, moid, NSYMBOL (number), (BYTE_T *) z) == A68_FALSE) { diagnostic (A68_RUNTIME_ERROR, p, ERROR_IN_DENOTATION, moid); exit_genie (p, A68_RUNTIME_ERROR); } MP_STATUS (z) = (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); return self; } if (moid == M_LONG_REAL || moid == M_LONG_LONG_REAL) { // [LONG] LONG REAL denotation. int digits = DIGITS (moid); int size = SIZE (moid); NODE_T *number; if (IS (SUB (p), SHORTETY) || IS (SUB (p), LONGETY)) { number = NEXT_SUB (p); } else { number = SUB (p); } MP_T *z = nil_mp (p, digits); if (genie_string_to_value_internal (p, moid, NSYMBOL (number), (BYTE_T *) z) == A68_FALSE) { diagnostic (A68_RUNTIME_ERROR, p, ERROR_IN_DENOTATION, moid); exit_genie (p, A68_RUNTIME_ERROR); } MP_STATUS (z) = (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); return self; } if (moid == M_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 (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_ALIGNED (A68_BITS)); SIZE (GINFO (p)) = SIZE_ALIGNED (A68_BITS); COPY (CONSTANT (GINFO (p)), &z, SIZE_ALIGNED (A68_BITS)); PUSH_VALUE (p, VALUE ((A68_BITS *) (CONSTANT (GINFO (p)))), A68_BITS); } if (moid == M_LONG_BITS || moid == M_LONG_LONG_BITS) { // [LONG] LONG BITS denotation. int digits = DIGITS (moid); int size = SIZE (moid); NODE_T *number; if (IS (SUB (p), SHORTETY) || IS (SUB (p), LONGETY)) { number = NEXT_SUB (p); } else { number = SUB (p); } MP_T *z = nil_mp (p, digits); if (genie_string_to_value_internal (p, moid, NSYMBOL (number), (BYTE_T *) z) == A68_FALSE) { diagnostic (A68_RUNTIME_ERROR, p, ERROR_IN_DENOTATION, moid); exit_genie (p, A68_RUNTIME_ERROR); } MP_STATUS (z) = (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); return self; } if (moid == M_BOOL) { // BOOL denotation. A68_BOOL z; ASSERT (genie_string_to_value_internal (p, M_BOOL, NSYMBOL (p), (BYTE_T *) & z) == A68_TRUE); PUSH_VALUE (p, VALUE (&z), A68_BOOL); return self; } else if (moid == M_CHAR) { // CHAR denotation. PUSH_VALUE (p, TO_UCHAR (NSYMBOL (p)[0]), A68_CHAR); return self; } else if (moid == M_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)))); (void) tup; return self; } if (moid == M_VOID) { // VOID denotation: EMPTY. return self; } // ?. return self; } //! @brief Push a local identifier. 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. PROP_T genie_identifier_standenv_proc (NODE_T * p) { A68_PROCEDURE z; TAG_T *q = TAX (p); STATUS (&z) = (STATUS_MASK_T) (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 PROP_T genie_identifier_standenv (NODE_T * p) { (void) ((*(PROCEDURE (TAX (p)))) (p)); return GPROP (p); } //! @brief Push identifier onto the stack. PROP_T genie_identifier (NODE_T * p) { static PROP_T self; TAG_T *q = TAX (p); SOURCE (&self) = p; if (A68_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). 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. 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 (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. 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 Call operator. void genie_call_operator (NODE_T * p, ADDR_T pop_sp) { A68_PROCEDURE *z; ADDR_T pop_fp = A68_FP; 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), A68_FP); } //! @brief Push result of monadic formula OP "u". PROP_T genie_monadic (NODE_T * p) { NODE_T *op = SUB (p); NODE_T *u = NEXT (op); PROP_T self; ADDR_T sp = A68_SP; EXECUTE_UNIT (u); STACK_DNS (u, MOID (u), A68_FP); 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. 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), A68_FP); EXECUTE_UNIT (v); STACK_DNS (v, MOID (v), A68_FP); (void) ((*(PROCEDURE (TAX (op)))) (op)); return GPROP (p); } //! @brief Push result of formula. 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 = A68_SP; EXECUTE_UNIT (u); STACK_DNS (u, MOID (u), A68_FP); EXECUTE_UNIT (v); STACK_DNS (v, MOID (v), A68_FP); 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. 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 = A68_SP; UNIT (&self) = genie_formula; SOURCE (&self) = p; EXECUTE_UNIT_2 (u, lhs); STACK_DNS (u, MOID (u), A68_FP); if (op != NO_NODE) { NODE_T *v = NEXT (op); GPROC *proc = PROCEDURE (TAX (op)); EXECUTE_UNIT_2 (v, rhs); STACK_DNS (v, MOID (v), A68_FP); 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; } (void) rhs; return self; } //! @brief Push NIL. 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. 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 = A68_SP; 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))); A68_SP = pop_sp; return self; } //! @brief Assign a value to a name and voiden. 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 = A68_SP, pop_fp = FRAME_DNS (A68_FP); A68_REF z; PROP_T self; UNIT (&self) = genie_voiding_assignation; SOURCE (&self) = p; EXECUTE_UNIT (dst); POP_OBJECT (p, &z, A68_REF); CHECK_REF (p, z, MOID (p)); FRAME_DNS (A68_FP) = REF_SCOPE (&z); EXECUTE_UNIT (src); STACK_DNS (src, src_mode, REF_SCOPE (&z)); FRAME_DNS (A68_FP) = pop_fp; A68_SP = 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)); } return self; } //! @brief Assign a value to a name and push the name. 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. 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 (A68_FP); A68_REF *z = (A68_REF *) STACK_TOP; EXECUTE_UNIT (dst); CHECK_REF (p, *z, MOID (p)); FRAME_DNS (A68_FP) = REF_SCOPE (z); EXECUTE_UNIT (src); STACK_DNS (src, src_mode, REF_SCOPE (z)); FRAME_DNS (A68_FP) = 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. 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 (A68_FP); A68_REF *z = (A68_REF *) STACK_TOP; EXECUTE_UNIT (dst); CHECK_REF (p, *z, MOID (p)); FRAME_DNS (A68_FP) = REF_SCOPE (z); EXECUTE_UNIT_2 (src, srp); STACK_DNS (src, src_mode, REF_SCOPE (z)); FRAME_DNS (A68_FP) = pop_fp; DECREMENT_STACK_POINTER (p, size); if (HAS_ROWS (src_mode)) { genie_clone_stack (p, src_mode, z, z); UNIT (&self) = genie_assignation; } 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. 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_VALUE (p, (BOOL_T) (ADDRESS (&x) == ADDRESS (&y)), A68_BOOL); } else { PUSH_VALUE (p, (BOOL_T) (ADDRESS (&x) != ADDRESS (&y)), A68_BOOL); } return self; } //! @brief Push result of ANDF. 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_VALUE (p, A68_FALSE, A68_BOOL); } UNIT (&self) = genie_and_function; SOURCE (&self) = p; return self; } //! @brief Push result of ORF. 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_VALUE (p, A68_TRUE, A68_BOOL); } UNIT (&self) = genie_or_function; SOURCE (&self) = p; return self; } //! @brief Push routine text. 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. void genie_push_undefined (NODE_T * p, MOID_T * u) { // For primitive modes we push an initialised value. if (u == M_VOID) { ; } else if (u == M_INT) { PUSH_VALUE (p, 1, A68_INT); // Because users write [~] INT ! } else if (u == M_REAL) { PUSH_VALUE (p, (a68_unif_rand ()), A68_REAL); } else if (u == M_BOOL) { PUSH_VALUE (p, (BOOL_T) (a68_unif_rand () < 0.5), A68_BOOL); } else if (u == M_CHAR) { PUSH_VALUE (p, (char) (32 + 96 * a68_unif_rand ()), A68_CHAR); } else if (u == M_BITS) { PUSH_VALUE (p, (UNSIGNED_T) (a68_unif_rand () * A68_MAX_BITS), A68_BITS); } else if (u == M_COMPLEX) { PUSH_COMPLEX (p, a68_unif_rand (), a68_unif_rand ()); } else if (u == M_BYTES) { PUSH_BYTES (p, "SKIP"); } else if (u == M_LONG_BYTES) { PUSH_LONG_BYTES (p, "SKIP"); } else if (u == M_STRING) { PUSH_REF (p, empty_string (p)); } else if (u == M_LONG_INT) { #if (A68_LEVEL >= 3) QUAD_WORD_T w; set_lw (w, 1); PUSH_VALUE (p, w, A68_LONG_INT); // Because users write [~] INT ! #else (void) nil_mp (p, DIGITS (u)); #endif } else if (u == M_LONG_REAL) { #if (A68_LEVEL >= 3) genie_next_random_real_16 (p); #else (void) nil_mp (p, DIGITS (u)); #endif } else if (u == M_LONG_BITS) { #if (A68_LEVEL >= 3) QUAD_WORD_T w; set_lw (w, 1); PUSH_VALUE (p, w, A68_LONG_BITS); // Because users write [~] INT ! #else (void) nil_mp (p, DIGITS (u)); #endif } else if (u == M_LONG_LONG_INT) { (void) nil_mp (p, DIGITS (u)); } else if (u == M_LONG_LONG_REAL) { (void) nil_mp (p, DIGITS (u)); } else if (u == M_LONG_LONG_BITS) { (void) nil_mp (p, DIGITS (u)); } else if (u == M_LONG_COMPLEX) { #if (A68_LEVEL >= 3) genie_next_random_real_16 (p); genie_next_random_real_16 (p); #else (void) nil_mp (p, DIGITSC (u)); (void) nil_mp (p, DIGITSC (u)); #endif } else if (u == M_LONG_LONG_COMPLEX) { (void) nil_mp (p, DIGITSC (u)); (void) nil_mp (p, DIGITSC (u)); } else if (IS_REF (u)) { // All REFs are NIL. PUSH_REF (p, nil_ref); } else if (IS_ROW (u) || IS_FLEX (u)) { // [] AMODE or FLEX [] AMODE. A68_REF er = empty_row (p, u); STATUS (&er) |= SKIP_ROW_MASK; PUSH_REF (p, er); } else if (IS_STRUCT (u)) { // STRUCT. PACK_T *v; for (v = PACK (u); v != NO_PACK; FORWARD (v)) { genie_push_undefined (p, MOID (v)); } } else if (IS_UNION (u)) { // UNION. ADDR_T sp = A68_SP; PUSH_UNION (p, MOID (PACK (u))); genie_push_undefined (p, MOID (PACK (u))); A68_SP = sp + SIZE (u); } else if (IS (u, PROC_SYMBOL)) { // PROC. A68_PROCEDURE z; STATUS (&z) = (STATUS_MASK_T) (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 == M_FORMAT) { // FORMAT etc. - what arbitrary FORMAT could mean anything at all?. A68_FORMAT z; STATUS (&z) = (STATUS_MASK_T) (INIT_MASK | SKIP_FORMAT_MASK); BODY (&z) = NO_NODE; ENVIRON (&z) = 0; PUSH_FORMAT (p, z); } else if (u == M_SIMPLOUT) { ADDR_T sp = A68_SP; PUSH_UNION (p, M_STRING); PUSH_REF (p, c_to_a_string (p, "SKIP", DEFAULT_WIDTH)); A68_SP = sp + SIZE (u); } else if (u == M_SIMPLIN) { ADDR_T sp = A68_SP; PUSH_UNION (p, M_REF_STRING); genie_push_undefined (p, M_REF_STRING); A68_SP = sp + SIZE (u); } else if (u == M_REF_FILE) { PUSH_REF (p, A68 (skip_file)); } else if (u == M_FILE) { A68_REF *z = (A68_REF *) STACK_TOP; int size = SIZE (M_FILE); ADDR_T pop_sp = A68_SP; PUSH_REF (p, A68 (skip_file)); A68_SP = pop_sp; PUSH (p, ADDRESS (z), size); } else if (u == M_CHANNEL) { PUSH_OBJECT (p, A68 (skip_channel), A68_CHANNEL); } else if (u == M_PIPE) { genie_push_undefined (p, M_REF_FILE); genie_push_undefined (p, M_REF_FILE); genie_push_undefined (p, M_INT); } else if (u == M_SOUND) { A68_SOUND *z = (A68_SOUND *) STACK_TOP; int size = SIZE (M_SOUND); INCREMENT_STACK_POINTER (p, size); FILL (z, 0, size); STATUS (z) = INIT_MASK; } else { BYTE_T *_sp_ = STACK_TOP; int size = SIZE_ALIGNED (u); INCREMENT_STACK_POINTER (p, size); FILL (_sp_, 0, size); } } //! @brief Push an undefined value of the required mode. PROP_T genie_skip (NODE_T * p) { PROP_T self; if (MOID (p) != M_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. 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 = A68_FP; 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 (BUILD_PARALLEL_CLAUSE) { pthread_t target_id = FRAME_THREAD_ID (target_frame_pointer); if (SAME_THREAD (target_id, pthread_self ())) { jump_stat = FRAME_JUMP_STAT (target_frame_pointer); JUMP_TO (TAG_TABLE (TAX (label))) = UNIT (TAX (label)); longjmp (*(jump_stat), 1); } else if (SAME_THREAD (target_id, A68_PAR (main_thread_id))) { // 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, ERROR_INTERNAL_CONSISTENCY, __func__); } else { diagnostic (A68_RUNTIME_ERROR, p, ERROR_PARALLEL_JUMP); 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. PROP_T genie_unit (NODE_T * p) { if (IS_COERCION (GINFO (p))) { GLOBAL_PROP (&A68_JOB) = genie_coercion (p); } else { switch (ATTRIBUTE (p)) { case DECLARATION_LIST: { genie_declaration (SUB (p)); UNIT (&GLOBAL_PROP (&A68_JOB)) = genie_unit; SOURCE (&GLOBAL_PROP (&A68_JOB)) = p; break; } case UNIT: { EXECUTE_UNIT_2 (SUB (p), GLOBAL_PROP (&A68_JOB)); break; } case TERTIARY: case SECONDARY: case PRIMARY: { GLOBAL_PROP (&A68_JOB) = genie_unit (SUB (p)); break; } // Ex primary. case ENCLOSED_CLAUSE: { GLOBAL_PROP (&A68_JOB) = genie_enclosed ((volatile NODE_T *) p); break; } case IDENTIFIER: { GLOBAL_PROP (&A68_JOB) = genie_identifier (p); break; } case CALL: { GLOBAL_PROP (&A68_JOB) = genie_call (p); break; } case SLICE: { GLOBAL_PROP (&A68_JOB) = genie_slice (p); break; } case DENOTATION: { GLOBAL_PROP (&A68_JOB) = genie_denotation (p); break; } case CAST: { GLOBAL_PROP (&A68_JOB) = genie_cast (p); break; } case FORMAT_TEXT: { GLOBAL_PROP (&A68_JOB) = genie_format_text (p); break; } // Ex secondary. case GENERATOR: { GLOBAL_PROP (&A68_JOB) = genie_generator (p); break; } case SELECTION: { GLOBAL_PROP (&A68_JOB) = genie_selection (p); break; } // Ex tertiary. case FORMULA: { GLOBAL_PROP (&A68_JOB) = genie_formula (p); break; } case MONADIC_FORMULA: { GLOBAL_PROP (&A68_JOB) = genie_monadic (p); break; } case NIHIL: { GLOBAL_PROP (&A68_JOB) = genie_nihil (p); break; } case DIAGONAL_FUNCTION: { GLOBAL_PROP (&A68_JOB) = genie_diagonal_function (p); break; } case TRANSPOSE_FUNCTION: { GLOBAL_PROP (&A68_JOB) = genie_transpose_function (p); break; } case ROW_FUNCTION: { GLOBAL_PROP (&A68_JOB) = genie_row_function (p); break; } case COLUMN_FUNCTION: { GLOBAL_PROP (&A68_JOB) = genie_column_function (p); break; } // Ex unit. case ASSIGNATION: { GLOBAL_PROP (&A68_JOB) = genie_assignation (p); break; } case IDENTITY_RELATION: { GLOBAL_PROP (&A68_JOB) = genie_identity_relation (p); break; } case ROUTINE_TEXT: { GLOBAL_PROP (&A68_JOB) = genie_routine_text (p); break; } case SKIP: { GLOBAL_PROP (&A68_JOB) = genie_skip (p); break; } case JUMP: { UNIT (&GLOBAL_PROP (&A68_JOB)) = genie_unit; SOURCE (&GLOBAL_PROP (&A68_JOB)) = p; genie_jump (p); break; } case AND_FUNCTION: { GLOBAL_PROP (&A68_JOB) = genie_and_function (p); break; } case OR_FUNCTION: { GLOBAL_PROP (&A68_JOB) = genie_or_function (p); break; } case ASSERTION: { GLOBAL_PROP (&A68_JOB) = genie_assertion (p); break; } case CODE_CLAUSE: { diagnostic (A68_RUNTIME_ERROR, p, ERROR_CODE); exit_genie (p, A68_RUNTIME_ERROR); break; } } } return GPROP (p) = GLOBAL_PROP (&A68_JOB); } //! @brief Execution of serial clause without labels. void genie_serial_units_no_label (NODE_T * p, ADDR_T 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. A68_SP = 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. void genie_serial_units (NODE_T * p, NODE_T ** jump_to, jmp_buf * exit_buf, ADDR_T 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. A68_SP = pop_sp; } break; } default: { genie_serial_units (SUB (p), jump_to, exit_buf, pop_sp); break; } } } } //! @brief Execute serial clause. 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), A68_SP, &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 = A68_SP; 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: { A68_SP = pop_sp; break; } } } } } else { // Labels in this clause. jmp_buf jump_stat; ADDR_T pop_sp = A68_SP, pop_fp = A68_FP; ADDR_T pop_dns = FRAME_DNS (A68_FP); FRAME_JUMP_STAT (A68_FP) = &jump_stat; if (!setjmp (jump_stat)) { NODE_T *jump_to = NO_NODE; genie_serial_units (SUB (p), &jump_to, exit_buf, A68_SP); } else { // HIjol! Restore state and look for indicated unit. NODE_T *jump_to = JUMP_TO (TABLE (p)); A68_SP = pop_sp; A68_FP = pop_fp; FRAME_DNS (A68_FP) = pop_dns; genie_serial_units (SUB (p), &jump_to, exit_buf, A68_SP); } } } //! @brief Execute enquiry clause. 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), A68_SP, &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 = A68_SP; 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: { A68_SP = pop_sp; break; } } } } } //! @brief Execute collateral units. 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 (A68_FP)); (*count)++; return; } else { genie_collateral_units (SUB (p), count); } } } //! @brief Execute collateral clause. PROP_T genie_collateral (NODE_T * p) { PROP_T self; // VOID clause and STRUCT display. if (MOID (p) == M_VOID || IS_STRUCT (MOID (p))) { int count = 0; genie_collateral_units (SUB (p), &count); } else { // Row display. A68_REF new_display; int count = 0; ADDR_T sp = A68_SP; MOID_T *m = MOID (p); genie_collateral_units (SUB (p), &count); // [] AMODE vacuum. if (count == 0) { A68_SP = sp; INCREMENT_STACK_POINTER (p, A68_REF_SIZE); *(A68_REF *) STACK_ADDRESS (sp) = empty_row (p, m); } else if (DIM (DEFLEX (m)) == 1) { // [] AMODE display. new_display = genie_make_row (p, SLICE (DEFLEX (m)), count, sp); A68_SP = 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); A68_SP = 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. 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. 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_UNION (spec_moid)) { 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_UNION (spec_moid)) { 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. 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); unt size = (unt) SIZE (src_mode); BYTE_T *stack_top = STACK_TOP; ADDR_T pop_sp = A68_SP; ADDR_T pop_dns = FRAME_DNS (A68_FP); FRAME_DNS (A68_FP) = A68_FP; EXECUTE_UNIT_TRACE (src); genie_check_initialisation (src, stack_top, src_mode); STACK_DNS (src, src_mode, A68_FP); FRAME_DNS (A68_FP) = pop_dns; // Make a temporary REF to the object in the frame. STATUS (&loc) = (STATUS_MASK_T) (INIT_MASK | IN_FRAME_MASK); REF_HANDLE (&loc) = (A68_HANDLE *) & nil_handle; OFFSET (&loc) = A68_FP + FRAME_INFO_SIZE + OFFSET (TAX (p)); REF_SCOPE (&loc) = A68_FP; ABEND (ADDRESS (&loc) != FRAME_OBJECT (OFFSET (TAX (p))), ERROR_INTERNAL_CONSISTENCY, __func__); // Initialise the tag, value is in the stack. if (HAS_ROWS (src_mode)) { A68_SP = pop_sp; genie_clone_stack (p, src_mode, &loc, (A68_REF *) & 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. 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); LEAP_T leap = (HEAP (tag) == LOC_SYMBOL ? LOC_SYMBOL : HEAP_SYMBOL); A68_REF *z; MOID_T *src_mode = SUB_MOID (p); 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); ADDR_T pop_sp = A68_SP; ADDR_T pop_dns = FRAME_DNS (A68_FP); FRAME_DNS (A68_FP) = A68_FP; EXECUTE_UNIT_TRACE (src); STACK_DNS (src, src_mode, A68_FP); FRAME_DNS (A68_FP) = pop_dns; A68_SP = pop_sp; if (HAS_ROWS (src_mode)) { genie_clone_stack (p, src_mode, z, z); } else { MOVE (ADDRESS (z), STACK_TOP, (unt) SIZE (src_mode)); } } } } } } //! @brief Execute PROC variable declaration. 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 = A68_SP; MOID_T *ref_mode = MOID (p); TAG_T *tag = TAX (p); LEAP_T 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, A68_SP); 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 = A68_SP; ADDR_T pop_dns = FRAME_DNS (A68_FP); FRAME_DNS (A68_FP) = A68_FP; EXECUTE_UNIT_TRACE (NEXT_NEXT (p)); STACK_DNS (p, SUB (ref_mode), A68_FP); FRAME_DNS (A68_FP) = pop_dns; A68_SP = pop_sp; MOVE (ADDRESS (z), STACK_TOP, (unt) SIZE (src_mode)); } A68_SP = sp_for_voiding; // Voiding return; } default: { genie_proc_variable_dec (SUB (p)); break; } } } } //! @brief Execute operator declaration. 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 (A68_FP); FRAME_DNS (A68_FP) = A68_FP; EXECUTE_UNIT_TRACE (NEXT_NEXT (p)); STACK_DNS (p, MOID (p), A68_FP); FRAME_DNS (A68_FP) = pop_dns; POP_PROCEDURE (p, z); return; } default: { genie_operator_dec (SUB (p)); break; } } } } //! @brief Execute declaration. 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 = A68_SP; genie_variable_dec (SUB (p), &declarer, A68_SP); // Voiding to remove garbage from declarers. A68_SP = pop_sp; break; } case PROCEDURE_VARIABLE_DECLARATION: { ADDR_T pop_sp = A68_SP; genie_proc_variable_dec (SUB (p)); A68_SP = pop_sp; break; } default: { genie_declaration (SUB (p)); break; } } } } #define LABEL_FREE(_p_) {\ NODE_T *_m_q; ADDR_T pop_sp_lf = A68_SP;\ 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) {\ A68_SP = pop_sp_lf;\ _m_q = SEQUENCE (_m_q);\ }\ }} #define SERIAL_CLAUSE(_p_)\ genie_preemptive_gc_heap ((NODE_T *) (_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_)\ genie_preemptive_gc_heap ((NODE_T *) (_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. 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 != M_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. 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 = A68_SP; ENQUIRY_CLAUSE (NEXT_SUB (q)); A68_SP = 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 != M_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. PROP_T genie_conditional (volatile NODE_T * p) { volatile ADDR_T pop_sp = A68_SP; 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)); A68_SP = 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 != M_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. // This is less relevant using 64-bit integers. #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. PROP_T genie_loop (volatile NODE_T * p) { volatile ADDR_T pop_sp = A68_SP; volatile INT_T from, by, to, counter; volatile BOOL_T siga, conditional; 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)); A68_SP = 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)); A68_SP = 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)); A68_SP = 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; } A68_SP = pop_sp; if (IS (p, WHILE_PART)) { ENQUIRY_CLAUSE (q); A68_SP = pop_sp; siga = (BOOL_T) (VALUE ((A68_BOOL *) STACK_TOP) != A68_FALSE); } if (siga) { 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 (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); A68_SP = pop_sp; ENQUIRY_CLAUSE (v); A68_SP = 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; } A68_SP = pop_sp; SERIAL_CLAUSE (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; A68_SP = pop_sp; return GPROP (p); } #undef INCREMENT_COUNTER #undef LOOP_OVERFLOW //! @brief Execute closed clause. 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. 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 (BUILD_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; } //! @brief Propagator_name. 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 (BUILD_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_widen) { return "genie_widen"; } if (p == genie_widen_int_to_real) { return "genie_widen_int_to_real"; } return NO_TEXT; } algol68g-3.1.2/src/a68g/moid-size.c0000644000175000017500000001676014361065320013473 00000000000000//! @file moid-size.c //! @author J. Marcel van der Veer // //! @section Copyright // // This file is part of Algol68G - an Algol 68 compiler-interpreter. // Copyright 2001-2023 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" #include "a68g-prelude.h" #include "a68g-mp.h" #include "a68g-genie.h" #include "a68g-postulates.h" #include "a68g-parser.h" #include "a68g-options.h" #include "a68g-optimiser.h" #include "a68g-listing.h" // Next are routines to calculate the size of a mode. //! @brief Max unitings to simplout. void max_unitings_to_simplout (NODE_T * p, int *max) { for (; p != NO_NODE; FORWARD (p)) { if (IS (p, UNITING) && MOID (p) == M_SIMPLOUT) { MOID_T *q = MOID (SUB (p)); if (q != M_SIMPLOUT) { int size = moid_size (q); MAXIMISE (*max, size); } } max_unitings_to_simplout (SUB (p), max); } } //! @brief Get max simplout size. void get_max_simplout_size (NODE_T * p) { A68 (max_simplout_size) = A68_REF_SIZE; // For anonymous SKIP max_unitings_to_simplout (p, &A68 (max_simplout_size)); } //! @brief Set moid sizes. 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. #if (A68_LEVEL >= 3) SIZE (M_LONG_REAL) = moid_size (M_LONG_REAL); DIGITS (M_LONG_REAL) = 0; #else SIZE (M_LONG_REAL) = moid_size (M_LONG_REAL); DIGITS (M_LONG_REAL) = moid_digits (M_LONG_REAL); #endif SIZE (M_LONG_LONG_REAL) = moid_size (M_LONG_LONG_REAL); DIGITS (M_LONG_LONG_REAL) = moid_digits (M_LONG_LONG_REAL); SIZEC (M_LONG_COMPLEX) = SIZE (M_LONG_REAL); SIZEC (M_REF_LONG_COMPLEX) = SIZE (M_LONG_REAL); DIGITSC (M_LONG_COMPLEX) = DIGITS (M_LONG_REAL); DIGITSC (M_REF_LONG_COMPLEX) = DIGITS (M_LONG_REAL); SIZEC (M_LONG_LONG_COMPLEX) = SIZE (M_LONG_LONG_REAL); SIZEC (M_REF_LONG_LONG_COMPLEX) = SIZE (M_LONG_LONG_REAL); DIGITSC (M_LONG_LONG_COMPLEX) = DIGITS (M_LONG_LONG_REAL); DIGITSC (M_REF_LONG_LONG_COMPLEX) = DIGITS (M_LONG_LONG_REAL); } //! @brief Moid size 2. 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 == M_HIP) { return 0; } else if (p == M_VOID) { return 0; } else if (p == M_INT) { return SIZE_ALIGNED (A68_INT); } else if (p == M_LONG_LONG_INT) { return (int) size_long_mp (); } else if (p == M_REAL) { return SIZE_ALIGNED (A68_REAL); } else if (p == M_LONG_INT) { #if (A68_LEVEL >= 3) return SIZE_ALIGNED (A68_LONG_INT); #else return (int) size_mp (); #endif } else if (p == M_LONG_REAL) { #if (A68_LEVEL >= 3) return SIZE_ALIGNED (A68_LONG_REAL); #else return (int) size_mp (); #endif } else if (p == M_LONG_BITS) { #if (A68_LEVEL >= 3) return SIZE_ALIGNED (A68_LONG_BITS); #else return (int) size_mp (); #endif } else if (p == M_LONG_LONG_REAL) { return (int) size_long_mp (); } else if (p == M_BOOL) { return SIZE_ALIGNED (A68_BOOL); } else if (p == M_CHAR) { return SIZE_ALIGNED (A68_CHAR); } else if (p == M_ROW_CHAR) { return A68_REF_SIZE; } else if (p == M_BITS) { return SIZE_ALIGNED (A68_BITS); } else if (p == M_LONG_LONG_BITS) { return (int) size_long_mp (); } else if (p == M_BYTES) { return SIZE_ALIGNED (A68_BYTES); } else if (p == M_LONG_BYTES) { return SIZE_ALIGNED (A68_LONG_BYTES); } else if (p == M_FILE) { return SIZE_ALIGNED (A68_FILE); } else if (p == M_CHANNEL) { return SIZE_ALIGNED (A68_CHANNEL); } else if (p == M_FORMAT) { return SIZE_ALIGNED (A68_FORMAT); } else if (p == M_SEMA) { return A68_REF_SIZE; } else if (p == M_SOUND) { return SIZE_ALIGNED (A68_SOUND); } else if (p == M_COLLITEM) { return SIZE_ALIGNED (A68_COLLITEM); } else if (p == M_HEX_NUMBER) { int k = 0; MAXIMISE (k, SIZE_ALIGNED (A68_BOOL)); MAXIMISE (k, SIZE_ALIGNED (A68_CHAR)); MAXIMISE (k, SIZE_ALIGNED (A68_INT)); MAXIMISE (k, SIZE_ALIGNED (A68_REAL)); MAXIMISE (k, SIZE_ALIGNED (A68_BITS)); #if (A68_LEVEL >= 3) MAXIMISE (k, SIZE_ALIGNED (A68_LONG_INT)); MAXIMISE (k, SIZE_ALIGNED (A68_LONG_REAL)); MAXIMISE (k, SIZE_ALIGNED (A68_LONG_BITS)); #endif return SIZE_ALIGNED (A68_UNION) + k; } else if (p == M_NUMBER) { int k = 0; MAXIMISE (k, A68_REF_SIZE); MAXIMISE (k, SIZE_ALIGNED (A68_INT)); MAXIMISE (k, SIZE_ALIGNED (A68_REAL)); MAXIMISE (k, (int) size_long_mp ()); #if (A68_LEVEL >= 3) MAXIMISE (k, SIZE_ALIGNED (A68_LONG_INT)); MAXIMISE (k, SIZE_ALIGNED (A68_LONG_REAL)); #else MAXIMISE (k, (int) size_mp ()); #endif return SIZE_ALIGNED (A68_UNION) + k; } else if (p == M_SIMPLIN) { int k = 0; MAXIMISE (k, A68_REF_SIZE); MAXIMISE (k, SIZE_ALIGNED (A68_FORMAT)); MAXIMISE (k, SIZE_ALIGNED (A68_PROCEDURE)); MAXIMISE (k, SIZE_ALIGNED (A68_SOUND)); return SIZE_ALIGNED (A68_UNION) + k; } else if (p == M_SIMPLOUT) { return SIZE_ALIGNED (A68_UNION) + A68 (max_simplout_size); } else if (IS_REF (p)) { return A68_REF_SIZE; } else if (IS (p, PROC_SYMBOL)) { return SIZE_ALIGNED (A68_PROCEDURE); } else if (IS_ROW (p) && p != M_ROWS) { return A68_REF_SIZE; } else if (p == M_ROWS) { return SIZE_ALIGNED (A68_UNION) + A68_REF_SIZE; } else if (IS_FLEX (p)) { return moid_size (SUB (p)); } else if (IS_STRUCT (p)) { PACK_T *z = PACK (p); int size = 0; for (; z != NO_PACK; FORWARD (z)) { size += moid_size (MOID (z)); } return size; } else if (IS_UNION (p)) { 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_ALIGNED (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. int moid_digits_2 (MOID_T * p) { if (p == NO_MOID) { return 0; } if (EQUIVALENT (p) != NO_MOID) { return moid_digits_2 (EQUIVALENT (p)); } if (p == M_LONG_INT) { #if (A68_LEVEL >= 3) return 0; #else return (int) mp_digits (); #endif } if (p == M_LONG_LONG_INT) { return (int) long_mp_digits (); } if (p == M_LONG_REAL) { return (int) mp_digits (); } if (p == M_LONG_LONG_REAL) { return (int) long_mp_digits (); } if (p == M_LONG_BITS) { #if (A68_LEVEL >= 3) return 0; #else return (int) mp_digits (); #endif } if (p == M_LONG_LONG_BITS) { return (int) long_mp_digits (); } else { return 0; } } //! @brief Moid size. int moid_size (MOID_T * p) { SIZE (p) = A68_ALIGN (moid_size_2 (p)); return SIZE (p); } //! @brief Moid digits. int moid_digits (MOID_T * p) { DIGITS (p) = moid_digits_2 (p); return DIGITS (p); } algol68g-3.1.2/src/a68g/extract.c0000644000175000017500000004347114361065320013244 00000000000000//! @file extract.c //! @author J. Marcel van der Veer // //! @section Copyright // // This file is part of Algol68G - an Algol 68 compiler-interpreter. // Copyright 2001-2023 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" #include "a68g-parser.h" // This is part of the bottom-up parser. // // Here is a set of routines that gather definitions from phrases. // This way we can apply tags before defining them. // These routines do not look very elegant as they have to scan through all // kind of symbols to find a pattern that they recognise. //! @brief Insert alt equals symbol. 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 (&A68 (top_token), "=")); NEXT (p) = q; PREVIOUS (q) = p; if (NEXT (q) != NO_NODE) { PREVIOUS (NEXT (q)) = q; } } //! @brief Detect redefined keyword. void detect_redefined_keyword (NODE_T * p, int construct) { if (p != NO_NODE && whether (p, KEYWORD, EQUALS_SYMBOL, STOP)) { diagnostic (A68_SYNTAX_ERROR, p, ERROR_REDEFINED_KEYWORD, NSYMBOL (p), construct); } } //! @brief Skip anything until a comma, semicolon or EXIT is found. 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. 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. 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 (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. 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. 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 (&A68_JOB), 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)\ errno=0;\ (k) = atoi (NSYMBOL (q));\ if (errno != 0) {\ diagnostic (A68_SYNTAX_ERROR, (q), ERROR_INVALID_PRIORITY);\ (k) = MAX_PRIORITY;\ } else if ((k) < 1 || (k) > MAX_PRIORITY) {\ diagnostic (A68_SYNTAX_ERROR, (q), ERROR_INVALID_PRIORITY);\ (k) = MAX_PRIORITY;\ } //! @brief Search PRIO X = .., Y = .. and store priorities. 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 (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 (&A68 (top_token), sym)); if (len > 2 && NSYMBOL (q)[len - 2] == ':' && NSYMBOL (q)[len - 3] != '=') { diagnostic (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. void extract_operators (NODE_T * p) { NODE_T *q = p; while (q != NO_NODE) { if (!IS (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 (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 (&A68 (top_token), sym)); if (len > 2 && NSYMBOL (q)[len - 2] == ':' && NSYMBOL (q)[len - 3] != '=') { diagnostic (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. 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. 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 (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. 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 (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. 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 (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. 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 (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. 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 (A68_SYNTAX_ERROR, q, ERROR_UNDECLARED_TAG); PRIO (INFO (q)) = 1; } } } } algol68g-3.1.2/src/a68g/compiler-gen.c0000644000175000017500000017617314361065320014161 00000000000000//! @file compiler.c //! @author J. Marcel van der Veer // //! @section Copyright // // This file is part of Algol68G - an Algol 68 compiler-interpreter. // Copyright 2001-2023 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" #include "a68g-prelude.h" #include "a68g-genie.h" #include "a68g-listing.h" #include "a68g-mp.h" #include "a68g-optimiser.h" #include "a68g-compiler.h" #include "a68g-parser.h" #include "a68g-transput.h" //! @brief Compile code clause. 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 (A68 (edit_line), SNPRINTF_SIZE, "%s\n", NSYMBOL (p))); } embed_code_clause (SUB (p), out); } } //! @brief Compile push. void gen_push (NODE_T * p, FILE_T out) { if (primitive_mode (MOID (p))) { indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "PUSH_VALUE (p, ")); inline_unit (p, out, L_YIELD); undentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, ", %s);\n", inline_mode (MOID (p)))); } else if (basic_mode (MOID (p))) { indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "MOVE ((void *) STACK_TOP, (void *) ")); inline_unit (p, out, L_YIELD); undentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, ", %d);\n", SIZE (MOID (p)))); indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "A68_SP += %d;\n", SIZE (MOID (p)))); } else { ABEND (A68_TRUE, ERROR_INTERNAL_CONSISTENCY, moid_to_string (MOID (p), 80, NO_NODE)); } } //! @brief Compile assign (C source to C destination). void gen_assign (NODE_T * p, FILE_T out, char *dst) { if (primitive_mode (MOID (p))) { indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "_STATUS_ (%s) = INIT_MASK;\n", dst)); indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "_VALUE_ (%s) = ", dst)); inline_unit (p, out, L_YIELD); undent (out, ";\n"); } else if (basic_mode (MOID (p))) { indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "MOVE ((void *) %s, (void *) ", dst)); inline_unit (p, out, L_YIELD); undentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, ", %d);\n", SIZE (MOID (p)))); } else { ABEND (A68_TRUE, ERROR_INTERNAL_CONSISTENCY, moid_to_string (MOID (p), 80, NO_NODE)); } } //! @brief Compile denotation. char *gen_denotation (NODE_T * p, FILE_T out, int compose_fun) { if (primitive_mode (MOID (p))) { if (compose_fun == A68_MAKE_FUNCTION) { return compile_denotation (p, out); } else { static char fn[NAME_SIZE]; comment_source (p, out); (void) make_name (fn, moid_with_name ("", MOID (p), "_denotation"), "", NUMBER (p)); A68_OPT (root_idf) = NO_DEC; inline_unit (p, out, L_DECLARE); print_declarations (out, A68_OPT (root_idf)); inline_unit (p, out, L_EXECUTE); if (primitive_mode (MOID (p))) { indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "PUSH_VALUE (p, ")); inline_unit (p, out, L_YIELD); undentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, ", %s);\n", inline_mode (MOID (p)))); } else { indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "PUSH (p, ")); inline_unit (p, out, L_YIELD); undentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, ", %d);\n", SIZE (MOID (p)))); } return fn; } } else { return NO_TEXT; } } //! @brief Compile cast. char *gen_cast (NODE_T * p, FILE_T out, int compose_fun) { if (compose_fun == A68_MAKE_FUNCTION) { return compile_cast (p, out); } else if (basic_unit (p)) { static char fn[NAME_SIZE]; comment_source (p, out); (void) make_name (fn, moid_with_name ("", MOID (p), "_cast"), "", NUMBER (p)); A68_OPT (root_idf) = NO_DEC; inline_unit (NEXT_SUB (p), out, L_DECLARE); print_declarations (out, A68_OPT (root_idf)); inline_unit (NEXT_SUB (p), out, L_EXECUTE); gen_push (NEXT_SUB (p), out); return fn; } else { return NO_TEXT; } } //! @brief Compile identifier. char *gen_identifier (NODE_T * p, FILE_T out, int compose_fun) { if (compose_fun == A68_MAKE_FUNCTION) { return compile_identifier (p, out); } else if (basic_mode (MOID (p))) { static char fn[NAME_SIZE]; (void) make_name (fn, moid_with_name ("deref_REF_", MOID (p), "_identifier"), "", NUMBER (p)); comment_source (p, out); A68_OPT (root_idf) = NO_DEC; inline_unit (p, out, L_DECLARE); print_declarations (out, A68_OPT (root_idf)); inline_unit (p, out, L_EXECUTE); gen_push (p, out); return fn; } else { return NO_TEXT; } } //! @brief Compile dereference identifier. char *gen_dereference_identifier (NODE_T * p, FILE_T out, int compose_fun) { if (compose_fun == A68_MAKE_FUNCTION) { return compile_dereference_identifier (p, out); } else if (basic_mode (MOID (p))) { static char fn[NAME_SIZE]; comment_source (p, out); (void) make_name (fn, moid_with_name ("deref_REF_", MOID (p), "_identifier"), "", NUMBER (p)); A68_OPT (root_idf) = NO_DEC; inline_unit (p, out, L_DECLARE); print_declarations (out, A68_OPT (root_idf)); inline_unit (p, out, L_EXECUTE); gen_push (p, out); return fn; } else { return NO_TEXT; } } //! @brief Compile slice. char *gen_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, moid_with_name ("", MOID (p), "_slice"), "", NUMBER (p)); if (compose_fun == A68_MAKE_FUNCTION) { write_fun_prelude (p, out, fn); } A68_OPT (root_idf) = NO_DEC; inline_unit (p, out, L_DECLARE); print_declarations (out, A68_OPT (root_idf)); inline_unit (p, out, L_EXECUTE); gen_push (p, out); if (compose_fun == A68_MAKE_FUNCTION) { write_fun_postlude (p, out, fn); } return fn; } else { return NO_TEXT; } } //! @brief Compile slice. char *gen_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, moid_with_name ("deref_REF_", MOID (p), "_slice"), "", NUMBER (p)); if (compose_fun == A68_MAKE_FUNCTION) { write_fun_prelude (p, out, fn); } A68_OPT (root_idf) = NO_DEC; inline_unit (p, out, L_DECLARE); print_declarations (out, A68_OPT (root_idf)); inline_unit (p, out, L_EXECUTE); gen_push (p, out); if (compose_fun == A68_MAKE_FUNCTION) { write_fun_postlude (p, out, fn); } return fn; } else { return NO_TEXT; } } //! @brief Compile selection. char *gen_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, moid_with_name ("", MOID (p), "_select"), "", NUMBER (p)); if (compose_fun == A68_MAKE_FUNCTION) { write_fun_prelude (p, out, fn); } A68_OPT (root_idf) = NO_DEC; inline_unit (p, out, L_DECLARE); print_declarations (out, A68_OPT (root_idf)); inline_unit (p, out, L_EXECUTE); gen_push (p, out); if (compose_fun == A68_MAKE_FUNCTION) { write_fun_postlude (p, out, fn); } return fn; } else { return NO_TEXT; } } //! @brief Compile selection. char *gen_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, moid_with_name ("deref_REF_", MOID (p), "_select"), "", NUMBER (p)); if (compose_fun == A68_MAKE_FUNCTION) { write_fun_prelude (p, out, fn); } A68_OPT (root_idf) = NO_DEC; inline_unit (p, out, L_DECLARE); print_declarations (out, A68_OPT (root_idf)); inline_unit (p, out, L_EXECUTE); gen_push (p, out); if (compose_fun == A68_MAKE_FUNCTION) { write_fun_postlude (p, out, fn); } return fn; } else { return NO_TEXT; } } //! @brief Compile formula. char *gen_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, moid_with_name ("", MOID (p), "_formula"), "", NUMBER (p)); if (compose_fun == A68_MAKE_FUNCTION) { write_fun_prelude (p, out, fn); } A68_OPT (root_idf) = NO_DEC; inline_unit (p, out, L_DECLARE); print_declarations (out, A68_OPT (root_idf)); if (OPTION_COMPILE_CHECK (&A68_JOB) && !constant_unit (p)) { if (MOID (p) == M_REAL || MOID (p) == M_COMPLEX) { indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "errno = 0;\n")); } } inline_unit (p, out, L_EXECUTE); gen_push (p, out); if (OPTION_COMPILE_CHECK (&A68_JOB) && !constant_unit (p)) { if (MOID (p) == M_REAL) { indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "MATH_RTE (p, errno != 0, M_REAL, NO_TEXT);\n")); } if (MOID (p) == M_COMPLEX) { indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "MATH_RTE (p, errno != 0, M_COMPLEX, NO_TEXT);\n")); } } if (compose_fun == A68_MAKE_FUNCTION) { write_fun_postlude (p, out, fn); } return fn; } else { return NO_TEXT; } } //! @brief Compile voiding formula. char *gen_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, moid_with_name ("void_", MOID (p), "_formula"), "", NUMBER (p)); if (compose_fun == A68_MAKE_FUNCTION) { write_fun_prelude (p, out, fn); } A68_OPT (root_idf) = NO_DEC; (void) add_declaration (&A68_OPT (root_idf), "ADDR_T", 0, pop); inline_unit (p, out, L_DECLARE); print_declarations (out, A68_OPT (root_idf)); indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "%s = A68_SP;\n", pop)); inline_unit (p, out, L_EXECUTE); indent (out, "(void) ("); inline_unit (p, out, L_YIELD); undent (out, ");\n"); indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "A68_SP = %s;\n", pop)); if (compose_fun == A68_MAKE_FUNCTION) { write_fun_postlude (p, out, fn); } return fn; } else { return NO_TEXT; } } //! @brief Compile uniting. char *gen_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, moid_with_name ("", MOID (p), "_unite"), "", NUMBER (p)); if (compose_fun == A68_MAKE_FUNCTION) { write_fun_prelude (p, out, fn); } A68_OPT (root_idf) = NO_DEC; (void) add_declaration (&A68_OPT (root_idf), "ADDR_T", 0, pop0); inline_unit (q, out, L_DECLARE); print_declarations (out, A68_OPT (root_idf)); indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "%s = A68_SP;\n", pop0)); indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "PUSH_UNION (_NODE_ (%d), %s);\n", NUMBER (p), internal_mode (v))); inline_unit (q, out, L_EXECUTE); gen_push (q, out); indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "A68_SP = %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 deproceduring. char *gen_deproceduring (NODE_T * p, FILE_T out, int compose_fun) { NODE_T *idf = stems_from (SUB (p), IDENTIFIER); if (idf == NO_NODE) { return NO_TEXT; } else if (!(SUB_MOID (idf) == M_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, moid_with_name ("", MOID (p), "_deproc"), "", NUMBER (p)); if (compose_fun == A68_MAKE_FUNCTION) { write_fun_prelude (p, out, fn); } // Declare. A68_OPT (root_idf) = NO_DEC; (void) add_declaration (&A68_OPT (root_idf), "A68_PROCEDURE", 1, fun); (void) add_declaration (&A68_OPT (root_idf), "NODE_T", 1, "body"); print_declarations (out, A68_OPT (root_idf)); // Initialise. get_stack (idf, out, fun, "A68_PROCEDURE"); indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "body = SUB (NODE (&BODY (%s)));\n", fun)); indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "OPEN_PROC_FRAME (body, ENVIRON (%s));\n", fun)); indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "INIT_STATIC_FRAME (body);\n")); // Execute procedure. indent (out, "EXECUTE_UNIT_TRACE (NEXT_NEXT (body));\n"); indent (out, "if (A68_FP == A68_MON (finish_frame_pointer)) {\n"); A68_OPT (indentation)++; indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "change_masks (TOP_NODE (&A68_JOB), BREAKPOINT_INTERRUPT_MASK, A68_TRUE);\n")); A68_OPT (indentation)--; indent (out, "}\n"); indent (out, "CLOSE_FRAME;\n"); if (compose_fun == A68_MAKE_FUNCTION) { write_fun_postlude (p, out, fn); } return fn; } } //! @brief Compile deproceduring. char *gen_voiding_deproceduring (NODE_T * p, FILE_T out, int compose_fun) { NODE_T *idf = stems_from (SUB_SUB (p), IDENTIFIER); if (idf == NO_NODE) { return NO_TEXT; } else if (!(SUB_MOID (idf) == M_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, moid_with_name ("void_", MOID (p), "_deproc"), "", NUMBER (p)); if (compose_fun == A68_MAKE_FUNCTION) { write_fun_prelude (p, out, fn); } // Declare. A68_OPT (root_idf) = NO_DEC; (void) add_declaration (&A68_OPT (root_idf), "ADDR_T", 0, pop); (void) add_declaration (&A68_OPT (root_idf), "A68_PROCEDURE", 1, fun); (void) add_declaration (&A68_OPT (root_idf), "NODE_T", 1, "body"); print_declarations (out, A68_OPT (root_idf)); // Initialise. indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "%s = A68_SP;\n", pop)); if (compose_fun != A68_MAKE_NOTHING) { } get_stack (idf, out, fun, "A68_PROCEDURE"); indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "body = SUB (NODE (&BODY (%s)));\n", fun)); indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "OPEN_PROC_FRAME (body, ENVIRON (%s));\n", fun)); indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "INIT_STATIC_FRAME (body);\n")); // Execute procedure. indent (out, "EXECUTE_UNIT_TRACE (NEXT_NEXT (body));\n"); indent (out, "if (A68_FP == A68_MON (finish_frame_pointer)) {\n"); A68_OPT (indentation)++; indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "change_masks (TOP_NODE (&A68_JOB), BREAKPOINT_INTERRUPT_MASK, A68_TRUE);\n")); A68_OPT (indentation)--; indent (out, "}\n"); indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "A68_SP = %s;\n", pop)); indent (out, "CLOSE_FRAME;\n"); if (compose_fun == A68_MAKE_FUNCTION) { write_fun_postlude (p, out, fn); } return fn; } } //! @brief Compile call. char *gen_call (NODE_T * p, FILE_T out, int compose_fun) { NODE_T *proc = SUB (p); NODE_T *args = NEXT (proc); NODE_T *idf = stems_from (proc, IDENTIFIER); if (idf == NO_NODE) { return NO_TEXT; } else if (!(SUB_MOID (proc) == M_VOID || basic_mode (SUB_MOID (proc)))) { return NO_TEXT; } else if (DIM (MOID (proc)) == 0) { return NO_TEXT; } else if (A68_STANDENV_PROC (TAX (idf))) { if (basic_call (p)) { static char fun[NAME_SIZE]; comment_source (p, out); (void) make_name (fun, moid_with_name ("", SUB_MOID (proc), "_call"), "", NUMBER (p)); if (compose_fun == A68_MAKE_FUNCTION) { write_fun_prelude (p, out, fun); } A68_OPT (root_idf) = NO_DEC; inline_unit (p, out, L_DECLARE); print_declarations (out, A68_OPT (root_idf)); inline_unit (p, out, L_EXECUTE); gen_push (p, out); if (compose_fun == A68_MAKE_FUNCTION) { write_fun_postlude (p, out, fun); } return fun; } 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 fun[NAME_SIZE]; char body[NAME_SIZE], pop[NAME_SIZE]; int size; // Declare. (void) make_name (body, FUN, "", NUMBER (proc)); (void) make_name (pop, PUP, "", NUMBER (p)); comment_source (p, out); (void) make_name (fun, moid_with_name ("", SUB_MOID (proc), "_call"), "", NUMBER (p)); if (compose_fun == A68_MAKE_FUNCTION) { write_fun_prelude (p, out, fun); } // Compute arguments. size = 0; A68_OPT (root_idf) = NO_DEC; inline_arguments (args, out, L_DECLARE, &size); (void) add_declaration (&A68_OPT (root_idf), "ADDR_T", 0, pop); (void) add_declaration (&A68_OPT (root_idf), "A68_PROCEDURE", 1, body); (void) add_declaration (&A68_OPT (root_idf), "NODE_T", 1, "body"); print_declarations (out, A68_OPT (root_idf)); // Initialise. indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "%s = A68_SP;\n", pop)); inline_arguments (args, out, L_INITIALISE, &size); get_stack (idf, out, body, "A68_PROCEDURE"); indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "body = SUB (NODE (&BODY (%s)));\n", body)); indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "OPEN_PROC_FRAME (body, ENVIRON (%s));\n", body)); indentf (out, snprintf (A68 (edit_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 (A68 (edit_line), SNPRINTF_SIZE, "A68_SP = %s;\n", pop)); indent (out, "EXECUTE_UNIT_TRACE (NEXT_NEXT_NEXT (body));\n"); indent (out, "if (A68_FP == A68_MON (finish_frame_pointer)) {\n"); A68_OPT (indentation)++; indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "change_masks (TOP_NODE (&A68_JOB), BREAKPOINT_INTERRUPT_MASK, A68_TRUE);\n")); A68_OPT (indentation)--; indent (out, "}\n"); indent (out, "CLOSE_FRAME;\n"); if (compose_fun == A68_MAKE_FUNCTION) { write_fun_postlude (p, out, fun); } return fun; } } //! @brief Compile call. char *gen_voiding_call (NODE_T * p, FILE_T out, int compose_fun) { NODE_T *proc = SUB (stems_from (p, CALL)); NODE_T *args = NEXT (proc); NODE_T *idf = stems_from (proc, IDENTIFIER); if (idf == NO_NODE) { return NO_TEXT; } else if (!(SUB_MOID (proc) == M_VOID || basic_mode (SUB_MOID (proc)))) { return NO_TEXT; } else if (DIM (MOID (proc)) == 0) { return NO_TEXT; } else if (A68_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 fun[NAME_SIZE]; char body[NAME_SIZE], pop[NAME_SIZE]; int size; // Declare. (void) make_name (body, FUN, "", NUMBER (proc)); (void) make_name (pop, PUP, "", NUMBER (p)); comment_source (p, out); (void) make_name (fun, moid_with_name ("void_", SUB_MOID (proc), "_call"), "", NUMBER (p)); if (compose_fun == A68_MAKE_FUNCTION) { write_fun_prelude (p, out, fun); } // Compute arguments. size = 0; A68_OPT (root_idf) = NO_DEC; inline_arguments (args, out, L_DECLARE, &size); (void) add_declaration (&A68_OPT (root_idf), "ADDR_T", 0, pop); (void) add_declaration (&A68_OPT (root_idf), "A68_PROCEDURE", 1, body); (void) add_declaration (&A68_OPT (root_idf), "NODE_T", 1, "body"); print_declarations (out, A68_OPT (root_idf)); // Initialise. indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "%s = A68_SP;\n", pop)); inline_arguments (args, out, L_INITIALISE, &size); get_stack (idf, out, body, "A68_PROCEDURE"); indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "body = SUB (NODE (&BODY (%s)));\n", body)); indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "OPEN_PROC_FRAME (body, ENVIRON (%s));\n", body)); indentf (out, snprintf (A68 (edit_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 (A68 (edit_line), SNPRINTF_SIZE, "A68_SP = %s;\n", pop)); indent (out, "EXECUTE_UNIT_TRACE (NEXT_NEXT_NEXT (body));\n"); indent (out, "if (A68_FP == A68_MON (finish_frame_pointer)) {\n"); A68_OPT (indentation)++; indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "change_masks (TOP_NODE (&A68_JOB), BREAKPOINT_INTERRUPT_MASK, A68_TRUE);\n")); A68_OPT (indentation)--; indent (out, "}\n"); indent (out, "CLOSE_FRAME;\n"); indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "A68_SP = %s;\n", pop)); if (compose_fun == A68_MAKE_FUNCTION) { write_fun_postlude (p, out, fun); } return fun; } } //! @brief Compile voiding assignation. char *gen_voiding_assignation_selection (NODE_T * p, FILE_T out, int compose_fun) { NODE_T *dst = SUB (stems_from (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 (stems_from (dst, SELECTION)); NODE_T *sec = NEXT (field); NODE_T *idf = stems_from (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, moid_with_name ("void_", MOID (SUB (p)), "_assign"), "", NUMBER (p)); if (compose_fun == A68_MAKE_FUNCTION) { write_fun_prelude (p, out, fn); } // Declare. A68_OPT (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 (A68 (edit_line), SNPRINTF_SIZE, "A68_REF * %s; /* %s */\n", ref, NSYMBOL (idf))); indentf (out, snprintf (A68 (edit_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 (&A68_OPT (root_idf), "ADDR_T", 0, pop); print_declarations (out, A68_OPT (root_idf)); indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "%s = A68_SP;\n", pop)); // Initialise. if (signed_in (BOOK_DECL, L_EXECUTE, NSYMBOL (idf)) == NO_BOOK) { get_stack (idf, out, ref, "A68_REF"); indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "%s = (%s *) & (ADDRESS (%s)[" A68_LU "]);\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. gen_assign (src, out, sel); indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "A68_SP = %s;\n", pop)); if (compose_fun == A68_MAKE_FUNCTION) { write_fun_postlude (p, out, fn); } return fn; } else { return NO_TEXT; } } //! @brief Compile voiding assignation. char *gen_voiding_assignation_slice (NODE_T * p, FILE_T out, int compose_fun) { NODE_T *dst = SUB (stems_from (p, ASSIGNATION)); NODE_T *src = NEXT_NEXT (dst); NODE_T *slice = stems_from (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_T k; comment_source (p, out); (void) make_name (pop, PUP, "", NUMBER (p)); (void) make_name (fn, moid_with_name ("void_", MOID (SUB (p)), "_assign"), "", NUMBER (p)); if (compose_fun == A68_MAKE_FUNCTION) { write_fun_prelude (p, out, fn); } // Declare. A68_OPT (root_idf) = NO_DEC; (void) add_declaration (&A68_OPT (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 (&A68_OPT (root_idf), "A68_REF", 1, idf); (void) add_declaration (&A68_OPT (root_idf), "A68_REF", 0, elm); (void) add_declaration (&A68_OPT (root_idf), "A68_ARRAY", 1, arr); (void) add_declaration (&A68_OPT (root_idf), "A68_TUPLE", 1, tup); (void) add_declaration (&A68_OPT (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, A68_OPT (root_idf)); // Initialise. indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "%s = A68_SP;\n", pop)); if (signed_in (BOOK_DECL, L_EXECUTE, symbol) == NO_BOOK) { NODE_T *pidf = stems_from (prim, IDENTIFIER); get_stack (pidf, out, idf, "A68_REF"); indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "GET_DESCRIPTOR (%s, %s, DEREF (A68_ROW, %s));\n", arr, tup, idf)); indentf (out, snprintf (A68 (edit_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 (A68 (edit_line), SNPRINTF_SIZE, "OFFSET (& %s) += ROW_ELEMENT (%s, ", elm, arr)); k = 0; inline_indexer (indx, out, L_YIELD, &k, tup); undentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, ");\n")); indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "%s = DEREF (%s, & %s);\n", drf, inline_mode (mode), elm)); inline_unit (src, out, L_EXECUTE); // Generate. gen_assign (src, out, drf); indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "A68_SP = %s;\n", pop)); if (compose_fun == A68_MAKE_FUNCTION) { write_fun_postlude (p, out, fn); } return fn; } else { return NO_TEXT; } } //! @brief Compile voiding assignation. char *gen_voiding_assignation_identifier (NODE_T * p, FILE_T out, int compose_fun) { NODE_T *dst = SUB (stems_from (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 = stems_from (dst, IDENTIFIER); // Declare. (void) make_name (pop, PUP, "", NUMBER (p)); comment_source (p, out); (void) make_name (fn, moid_with_name ("void_", MOID (SUB (p)), "_assign"), "", NUMBER (p)); if (compose_fun == A68_MAKE_FUNCTION) { write_fun_prelude (p, out, fn); } A68_OPT (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 (&A68_OPT (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 (&A68_OPT (root_idf), "ADDR_T", 0, pop); print_declarations (out, A68_OPT (root_idf)); // Initialise. indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "%s = A68_SP;\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 (A68 (edit_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 (A68 (edit_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); gen_assign (src, out, idf); indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "A68_SP = %s;\n", pop)); if (compose_fun == A68_MAKE_FUNCTION) { write_fun_postlude (p, out, fn); } return fn; } else { return NO_TEXT; } } //! @brief Compile identity-relation. char *gen_identity_relation (NODE_T * p, FILE_T out, int compose_fun) { #define GOOD(p) (stems_from (p, IDENTIFIER) != NO_NODE && IS (MOID (stems_from ((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, moid_with_name ("", MOID (p), "_identity"), "", NUMBER (p)); if (compose_fun == A68_MAKE_FUNCTION) { write_fun_prelude (p, out, fn); } A68_OPT (root_idf) = NO_DEC; inline_identity_relation (p, out, L_DECLARE); print_declarations (out, A68_OPT (root_idf)); inline_identity_relation (p, out, L_EXECUTE); indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "PUSH_VALUE (p, ")); inline_identity_relation (p, out, L_YIELD); undentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, ", A68_BOOL);\n")); if (compose_fun == A68_MAKE_FUNCTION) { write_fun_postlude (p, out, fn); } return fn; } else if (GOOD (lhs) && stems_from (rhs, NIHIL) != NO_NODE) { static char fn[NAME_SIZE]; comment_source (p, out); (void) make_name (fn, moid_with_name ("", MOID (p), "_identity"), "", NUMBER (p)); if (compose_fun == A68_MAKE_FUNCTION) { write_fun_prelude (p, out, fn); } A68_OPT (root_idf) = NO_DEC; inline_identity_relation (p, out, L_DECLARE); print_declarations (out, A68_OPT (root_idf)); inline_identity_relation (p, out, L_EXECUTE); indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "PUSH_VALUE (p, ")); inline_identity_relation (p, out, L_YIELD); undentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, ", A68_BOOL);\n")); if (compose_fun == A68_MAKE_FUNCTION) { write_fun_postlude (p, out, fn); } return fn; } else { return NO_TEXT; } #undef GOOD } //! @brief Compile closed clause. void gen_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 (A68 (edit_line), SNPRINTF_SIZE, "genie_operator_dec (_NODE_ (%d));", NUMBER (SUB (p)))); inline_comment_source (p, out); undent (out, NEWLINE_STRING); (*decs)++; break; } case IDENTITY_DECLARATION: { indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "genie_identity_dec (_NODE_ (%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); A68_OPT (indentation)++; indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "NODE_T *%s = NO_NODE;\n", declarer)); indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "genie_variable_dec (_NODE_ (%d), &%s, A68_SP);\n", NUMBER (SUB (p)), declarer)); indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "A68_SP = %s;\n", pop)); A68_OPT (indentation)--; indent (out, "}\n"); (*decs)++; break; } case PROCEDURE_VARIABLE_DECLARATION: { indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "genie_proc_variable_dec (_NODE_ (%d));", NUMBER (SUB (p)))); inline_comment_source (p, out); undent (out, NEWLINE_STRING); indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "A68_SP = %s;\n", pop)); (*decs)++; break; } default: { gen_declaration_list (SUB (p), out, decs, pop); break; } } } } //! @brief Compile closed clause. void gen_serial_clause (NODE_T * p, FILE_T out, NODE_T ** last, int *units, int *decs, char *pop, int compose_fun) { for (; p != NO_NODE && A68_OPT (code_errors) == 0; 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 (gen_unit (p, out, A68_MAKE_FUNCTION) == NO_TEXT) { if (IS (p, UNIT) && IS (SUB (p), TERTIARY)) { gen_units (SUB_SUB (p), out); } else { gen_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))); a68_free (COMPILE_NAME (GINFO (p))); COMPILE_NAME (GINFO (p)) = new_string (COMPILE_NAME (GINFO (SUB (p))), NO_TEXT); } return; } else { gen_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) == M_VOID) { break; } else if (IS (*last, DECLARATION_LIST)) { break; } else { indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "A68_SP = %s;\n", pop)); } break; } case DECLARATION_LIST: { (*last) = p; gen_declaration_list (SUB (p), out, decs, pop); break; } default: { gen_serial_clause (SUB (p), out, last, units, decs, pop, compose_fun); break; } } } } //! @brief Embed serial clause. 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 (A68 (edit_line), SNPRINTF_SIZE, "OPEN_STATIC_FRAME (_NODE_ (%d));\n", NUMBER (p))); init_static_frame (out, p); gen_serial_clause (p, out, &last, &units, &decs, pop, A68_MAKE_FUNCTION); indent (out, "CLOSE_FRAME;\n"); } //! @brief Compile code clause. char *gen_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. char *gen_closed_clause (NODE_T * p, FILE_T out, int compose_fun) { NODE_T *sc = NEXT_SUB (p); if (MOID (p) == M_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; gen_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); } A68_OPT (root_idf) = NO_DEC; (void) add_declaration (&A68_OPT (root_idf), "ADDR_T", 0, pop); print_declarations (out, A68_OPT (root_idf)); indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "%s = A68_SP;\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. char *gen_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); } A68_OPT (root_idf) = NO_DEC; inline_collateral_units (NEXT_SUB (p), out, L_DECLARE); print_declarations (out, A68_OPT (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. char *gen_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) == M_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)) { A68_OPT (root_idf) = NO_DEC; inline_unit (SUB (NEXT_SUB (p)), out, L_DECLARE); print_declarations (out, A68_OPT (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"); A68_OPT (indentation)++; } else { ABEND (A68_TRUE, ERROR_INTERNAL_CONSISTENCY, __func__); } FORWARD (p); if (IS (p, THEN_PART) || IS (p, CHOICE)) { int pop = A68_OPT (cse_pointer); (void) gen_unit (SUB (NEXT_SUB (p)), out, A68_MAKE_NOTHING); A68_OPT (indentation)--; A68_OPT (cse_pointer) = pop; } else { ABEND (A68_TRUE, ERROR_INTERNAL_CONSISTENCY, __func__); } FORWARD (p); if (IS (p, ELSE_PART) || IS (p, CHOICE)) { int pop = A68_OPT (cse_pointer); indent (out, "} else {\n"); A68_OPT (indentation)++; (void) gen_unit (SUB (NEXT_SUB (p)), out, A68_MAKE_NOTHING); A68_OPT (indentation)--; A68_OPT (cse_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. char *gen_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) != M_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, STOP)) { 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; gen_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, STOP)) { 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); } A68_OPT (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, STOP)) { FORWARD (q); } } (void) add_declaration (&A68_OPT (root_idf), "ADDR_T", 0, pop); print_declarations (out, A68_OPT (root_idf)); // Generate the function body. indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "%s = A68_SP;\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, STOP)) { 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"); } A68_OPT (indentation)++; embed_serial_clause (NEXT_SUB (q), out, pop); A68_OPT (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, STOP)) { 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. BOOL_T gen_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 (A68 (edit_line), SNPRINTF_SIZE, "case %d: {\n", k)); A68_OPT (indentation)++; indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "OPEN_STATIC_FRAME (_NODE_ (%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"); A68_OPT (indentation)--; indent (out, "}\n"); } else if (compose_fun == A68_MAKE_OTHERS) { if (gen_unit (p, out, A68_MAKE_FUNCTION) == NO_TEXT) { if (IS (p, UNIT) && IS (SUB (p), TERTIARY)) { gen_units (SUB_SUB (p), out); } else { gen_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))); a68_free (COMPILE_NAME (GINFO (p))); COMPILE_NAME (GINFO (p)) = new_string (COMPILE_NAME (GINFO (SUB (p))), NO_TEXT); } } return A68_TRUE; } else { (*count)++; return A68_FALSE; } } else { if (gen_int_case_units (SUB (p), out, sym, k, count, compose_fun)) { return A68_TRUE; } else { return gen_int_case_units (NEXT (p), out, sym, k, count, compose_fun); } } } } //! @brief Compile integral-case-clause. char *gen_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) != M_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, STOP)) { 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 (gen_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; gen_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); } A68_OPT (root_idf) = NO_DEC; q = SUB (p); inline_unit (SUB (NEXT_SUB (q)), out, L_DECLARE); (void) add_declaration (&A68_OPT (root_idf), "ADDR_T", 0, pop); print_declarations (out, A68_OPT (root_idf)); // Generate the function body. indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "%s = A68_SP;\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"); A68_OPT (indentation)++; FORWARD (q); k = 0; do { count = 1; k++; } while (gen_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"); A68_OPT (indentation)++; embed_serial_clause (NEXT_SUB (q), out, pop); indent (out, "break;\n"); A68_OPT (indentation)--; indent (out, "}\n"); } A68_OPT (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. char *gen_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; gen_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); } A68_OPT (root_idf) = NO_DEC; (void) make_name (idf, "k", "", NUMBER (p)); (void) add_declaration (&A68_OPT (root_idf), "INT_T", 0, idf); if (for_part != NO_NODE) { (void) make_name (z, "z", "", NUMBER (p)); (void) add_declaration (&A68_OPT (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 (&A68_OPT (root_idf), "ADDR_T", 0, pop); print_declarations (out, A68_OPT (root_idf)); indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "%s = A68_SP;\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 (A68 (edit_line), SNPRINTF_SIZE, "OPEN_STATIC_FRAME (_NODE_ (%d));\n", NUMBER (sc))); init_static_frame (out, sc); if (for_part != NO_NODE) { indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "%s = (A68_INT *) (FRAME_OBJECT (OFFSET (TAX (_NODE_ (%d)))));\n", z, NUMBER (for_part))); } // The loop in C. // Initialisation. indentf (out, snprintf (A68 (edit_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"); A68_OPT (indentation)++; if (gc) { indent (out, "// genie_preemptive_gc_heap (p);\n"); } if (for_part != NO_NODE) { indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "_STATUS_ (%s) = INIT_MASK;\n", z)); indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "_VALUE_ (%s) = %s;\n", z, idf)); } units = decs = 0; gen_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"); A68_OPT (indentation)++; if (AP_INCREMENT (TABLE (sc)) > 0) { #if (A68_LEVEL >= 3) indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "FRAME_CLEAR (%llu);\n", AP_INCREMENT (TABLE (sc)))); #else indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "FRAME_CLEAR (%u);\n", AP_INCREMENT (TABLE (sc)))); #endif } if (need_initialise_frame (sc)) { indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "initialise_frame (_NODE_ (%d));\n", NUMBER (sc))); } A68_OPT (indentation)--; indent (out, "}\n"); } // End of loop. A68_OPT (indentation)--; indent (out, "}\n"); indent (out, "CLOSE_FRAME;\n"); indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "A68_SP = %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 Optimise units. char *gen_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) >= NAME_SIZE, ERROR_INTERNAL_CONSISTENCY, __func__);\ 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 (COMPILE_NAME (GINFO (p)) != NO_TEXT) { return NO_TEXT; } else if (is_one_of (p, UNIT, TERTIARY, SECONDARY, PRIMARY, ENCLOSED_CLAUSE, STOP)) { COMPILE (SUB (p), out, gen_unit, compose_fun); } if (A68_OPT (OPTION_CODE_LEVEL) >= 3) { // Control structure. if (IS (p, CLOSED_CLAUSE)) { COMPILE (p, out, gen_closed_clause, compose_fun); } else if (IS (p, COLLATERAL_CLAUSE)) { COMPILE (p, out, gen_collateral_clause, compose_fun); } else if (IS (p, CONDITIONAL_CLAUSE)) { char *fn2 = gen_basic_conditional (p, out, compose_fun); if (compose_fun == A68_MAKE_FUNCTION && fn2 != NO_TEXT) { ABEND (strlen (fn2) >= NAME_SIZE, ERROR_INTERNAL_CONSISTENCY, __func__); 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, gen_conditional_clause, compose_fun); } } else if (IS (p, CASE_CLAUSE)) { COMPILE (p, out, gen_int_case_clause, compose_fun); } else if (IS (p, LOOP_CLAUSE)) { COMPILE (p, out, gen_loop_clause, compose_fun); } } if (A68_OPT (OPTION_CODE_LEVEL) >= 2) { // Simple constructions. if (IS (p, VOIDING) && IS (SUB (p), ASSIGNATION) && stems_from (SUB_SUB (p), IDENTIFIER) != NO_NODE) { COMPILE (p, out, gen_voiding_assignation_identifier, compose_fun); } else if (IS (p, VOIDING) && IS (SUB (p), ASSIGNATION) && stems_from (SUB_SUB (p), SLICE) != NO_NODE) { COMPILE (p, out, gen_voiding_assignation_slice, compose_fun); } else if (IS (p, VOIDING) && IS (SUB (p), ASSIGNATION) && stems_from (SUB_SUB (p), SELECTION) != NO_NODE) { COMPILE (p, out, gen_voiding_assignation_selection, compose_fun); } else if (IS (p, SLICE)) { COMPILE (p, out, gen_slice, compose_fun); } else if (IS (p, DEREFERENCING) && stems_from (SUB (p), SLICE) != NO_NODE) { COMPILE (p, out, gen_dereference_slice, compose_fun); } else if (IS (p, SELECTION)) { COMPILE (p, out, gen_selection, compose_fun); } else if (IS (p, DEREFERENCING) && stems_from (SUB (p), SELECTION) != NO_NODE) { COMPILE (p, out, gen_dereference_selection, compose_fun); } else if (IS (p, VOIDING) && IS (SUB (p), FORMULA)) { COMPILE (SUB (p), out, gen_voiding_formula, compose_fun); } else if (IS (p, VOIDING) && IS (SUB (p), MONADIC_FORMULA)) { COMPILE (SUB (p), out, gen_voiding_formula, compose_fun); } else if (IS (p, DEPROCEDURING)) { COMPILE (p, out, gen_deproceduring, compose_fun); } else if (IS (p, VOIDING) && IS (SUB (p), DEPROCEDURING)) { COMPILE (p, out, gen_voiding_deproceduring, compose_fun); } else if (IS (p, VOIDING) && IS (SUB (p), CALL)) { COMPILE (p, out, gen_voiding_call, compose_fun); } else if (IS (p, IDENTITY_RELATION)) { COMPILE (p, out, gen_identity_relation, compose_fun); } else if (IS (p, UNITING)) { COMPILE (p, out, gen_uniting, compose_fun); } } if (A68_OPT (OPTION_CODE_LEVEL) >= 1) { // Most basic stuff. if (IS (p, VOIDING)) { COMPILE (SUB (p), out, gen_unit, compose_fun); } else if (IS (p, DENOTATION)) { COMPILE (p, out, gen_denotation, compose_fun); } else if (IS (p, CAST)) { COMPILE (p, out, gen_cast, compose_fun); } else if (IS (p, IDENTIFIER)) { COMPILE (p, out, gen_identifier, compose_fun); } else if (IS (p, DEREFERENCING) && stems_from (SUB (p), IDENTIFIER) != NO_NODE) { COMPILE (p, out, gen_dereference_identifier, compose_fun); } else if (IS (p, MONADIC_FORMULA)) { COMPILE (p, out, gen_formula, compose_fun); } else if (IS (p, FORMULA)) { COMPILE (p, out, gen_formula, compose_fun); } else if (IS (p, CALL)) { COMPILE (p, out, gen_call, compose_fun); } } if (IS (p, CODE_CLAUSE)) { COMPILE (p, out, gen_code_clause, compose_fun); } return NO_TEXT; #undef COMPILE } //! @brief Compile unit. char *gen_basic (NODE_T * p, FILE_T out) { #define COMPILE(p, out, fun) {\ char * fn = (fun) (p, out);\ if (fn != NO_TEXT) {\ ABEND (strlen (fn) >= NAME_SIZE, ERROR_INTERNAL_CONSISTENCY, __func__);\ 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 (COMPILE_NAME (GINFO (p)) != NO_TEXT) { return NO_TEXT; } else if (is_one_of (p, UNIT, TERTIARY, SECONDARY, PRIMARY, ENCLOSED_CLAUSE, STOP)) { COMPILE (SUB (p), out, gen_basic); } // Most basic stuff. if (IS (p, VOIDING)) { COMPILE (SUB (p), out, gen_basic); } else if (IS (p, DENOTATION)) { COMPILE (p, out, compile_denotation); } else if (IS (p, CAST)) { COMPILE (p, out, compile_cast); } else if (IS (p, IDENTIFIER)) { COMPILE (p, out, compile_identifier); } else if (IS (p, DEREFERENCING) && stems_from (SUB (p), IDENTIFIER) != NO_NODE) { COMPILE (p, out, compile_dereference_identifier); } else if (IS (p, FORMULA)) { COMPILE (p, out, compile_formula); } else if (IS (p, CALL)) { COMPILE (p, out, compile_call); } return NO_TEXT; #undef COMPILE } //! @brief Optimise units. void gen_units (NODE_T * p, FILE_T out) { for (; p != NO_NODE; FORWARD (p)) { if (IS (p, UNIT) || IS (p, CODE_CLAUSE)) { if (gen_unit (p, out, A68_MAKE_FUNCTION) == NO_TEXT) { gen_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)) = new_string (COMPILE_NAME (GINFO (SUB (p))), NO_TEXT); } } else { gen_units (SUB (p), out); } } } //! @brief Compile units. void gen_basics (NODE_T * p, FILE_T out) { for (; p != NO_NODE; FORWARD (p)) { if (IS (p, UNIT) || IS (p, CODE_CLAUSE)) { if (gen_basic (p, out) == NO_TEXT) { gen_basics (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)) = new_string (COMPILE_NAME (GINFO (SUB (p))), NO_TEXT); } } else { gen_basics (SUB (p), out); } } } algol68g-3.1.2/Makefile.in0000644000175000017500000071454014361065447012153 00000000000000# Makefile.in generated by automake 1.16.3 from Makefile.am. # @configure_input@ # Copyright (C) 1994-2020 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@ am__is_gnu_make = { \ if test -z '$(MAKELEVEL)'; then \ false; \ elif test -n '$(MAKE_HOST)'; then \ true; \ elif test -n '$(MAKE_VERSION)' && test -n '$(CURDIR)'; then \ true; \ else \ false; \ fi; \ } am__make_running_with_option = \ case $${target_option-} in \ ?) ;; \ *) echo "am__make_running_with_option: internal error: invalid" \ "target option '$${target_option-}' specified" >&2; \ exit 1;; \ esac; \ has_opt=no; \ sane_makeflags=$$MAKEFLAGS; \ if $(am__is_gnu_make); then \ sane_makeflags=$$MFLAGS; \ else \ case $$MAKEFLAGS in \ *\\[\ \ ]*) \ bs=\\; \ sane_makeflags=`printf '%s\n' "$$MAKEFLAGS" \ | sed "s/$$bs$$bs[$$bs $$bs ]*//g"`;; \ esac; \ fi; \ skip_next=no; \ strip_trailopt () \ { \ flg=`printf '%s\n' "$$flg" | sed "s/$$1.*$$//"`; \ }; \ for flg in $$sane_makeflags; do \ test $$skip_next = yes && { skip_next=no; continue; }; \ case $$flg in \ *=*|--*) continue;; \ -*I) strip_trailopt 'I'; skip_next=yes;; \ -*I?*) strip_trailopt 'I';; \ -*O) strip_trailopt 'O'; skip_next=yes;; \ -*O?*) strip_trailopt 'O';; \ -*l) strip_trailopt 'l'; skip_next=yes;; \ -*l?*) strip_trailopt 'l';; \ -[dEDm]) skip_next=yes;; \ -[JT]) skip_next=yes;; \ esac; \ case $$flg in \ *$$target_option*) has_opt=yes; break;; \ esac; \ done; \ test $$has_opt = yes am__make_dryrun = (target_option=n; $(am__make_running_with_option)) am__make_keepgoing = (target_option=k; $(am__make_running_with_option)) pkgdatadir = $(datadir)/@PACKAGE@ pkgincludedir = $(includedir)/@PACKAGE@ pkglibdir = $(libdir)/@PACKAGE@ pkglibexecdir = $(libexecdir)/@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 = . 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) DIST_COMMON = $(srcdir)/Makefile.am $(top_srcdir)/configure \ $(am__configure_deps) $(pkginclude_HEADERS) $(am__DIST_COMMON) am__CONFIG_DISTCLEAN_FILES = config.status config.cache config.log \ configure.lineno config.status.lineno mkinstalldirs = $(install_sh) -d CONFIG_HEADER = a68g-config.h CONFIG_CLEAN_FILES = CONFIG_CLEAN_VPATH_FILES = am__installdirs = "$(DESTDIR)$(bindir)" "$(DESTDIR)$(man1dir)" \ "$(DESTDIR)$(docdir)" "$(DESTDIR)$(pkgincludedir)" PROGRAMS = $(bin_PROGRAMS) am__dirstamp = $(am__leading_dot)dirstamp am_a68g_OBJECTS = ./src/a68g/a68g-a68g.$(OBJEXT) \ ./src/a68g/a68g-a68glib.$(OBJEXT) \ ./src/a68g/a68g-apropos.$(OBJEXT) \ ./src/a68g/a68g-bits.$(OBJEXT) ./src/a68g/a68g-bool.$(OBJEXT) \ ./src/a68g/a68g-bottom-up.$(OBJEXT) \ ./src/a68g/a68g-brackets.$(OBJEXT) \ ./src/a68g/a68g-char.$(OBJEXT) \ ./src/a68g/a68g-compiler-basic.$(OBJEXT) \ ./src/a68g/a68g-compiler.$(OBJEXT) \ ./src/a68g/a68g-compiler-folder.$(OBJEXT) \ ./src/a68g/a68g-compiler-gen.$(OBJEXT) \ ./src/a68g/a68g-compiler-inline.$(OBJEXT) \ ./src/a68g/a68g-compiler-tables.$(OBJEXT) \ ./src/a68g/a68g-conversion.$(OBJEXT) \ ./src/a68g/a68g-curses.$(OBJEXT) \ ./src/a68g/a68g-diagnostics.$(OBJEXT) \ ./src/a68g/a68g-double.$(OBJEXT) \ ./src/a68g/a68g-double-gamic.$(OBJEXT) \ ./src/a68g/a68g-double-math.$(OBJEXT) \ ./src/a68g/a68g-enquiries.$(OBJEXT) \ ./src/a68g/a68g-environ.$(OBJEXT) \ ./src/a68g/a68g-equivalence.$(OBJEXT) \ ./src/a68g/a68g-extract.$(OBJEXT) \ ./src/a68g/a68g-fft.$(OBJEXT) ./src/a68g/a68g-format.$(OBJEXT) \ ./src/a68g/a68g-genie.$(OBJEXT) \ ./src/a68g/a68g-genie-coerce.$(OBJEXT) \ ./src/a68g/a68g-genie-stowed.$(OBJEXT) \ ./src/a68g/a68g-heap.$(OBJEXT) ./src/a68g/a68g-io.$(OBJEXT) \ ./src/a68g/a68g-keywords.$(OBJEXT) \ ./src/a68g/a68g-laplace.$(OBJEXT) \ ./src/a68g/a68g-listing.$(OBJEXT) \ ./src/a68g/a68g-mem.$(OBJEXT) ./src/a68g/a68g-modes.$(OBJEXT) \ ./src/a68g/a68g-moid-size.$(OBJEXT) \ ./src/a68g/a68g-moid-to-string.$(OBJEXT) \ ./src/a68g/a68g-monitor.$(OBJEXT) \ ./src/a68g/a68g-mp-bits.$(OBJEXT) ./src/a68g/a68g-mp.$(OBJEXT) \ ./src/a68g/a68g-mp-constant.$(OBJEXT) \ ./src/a68g/a68g-mp-gamic.$(OBJEXT) \ ./src/a68g/a68g-mp-gamma.$(OBJEXT) \ ./src/a68g/a68g-mp-genie.$(OBJEXT) \ ./src/a68g/a68g-mp-math.$(OBJEXT) \ ./src/a68g/a68g-mp-mpfr.$(OBJEXT) \ ./src/a68g/a68g-non-terminal.$(OBJEXT) \ ./src/a68g/a68g-options.$(OBJEXT) \ ./src/a68g/a68g-parallel.$(OBJEXT) \ ./src/a68g/a68g-parser.$(OBJEXT) \ ./src/a68g/a68g-physics.$(OBJEXT) \ ./src/a68g/a68g-plotutils.$(OBJEXT) \ ./src/a68g/a68g-postgresql.$(OBJEXT) \ ./src/a68g/a68g-postulates.$(OBJEXT) \ ./src/a68g/a68g-prelude-bits.$(OBJEXT) \ ./src/a68g/a68g-prelude.$(OBJEXT) \ ./src/a68g/a68g-prelude-gsl.$(OBJEXT) \ ./src/a68g/a68g-prelude-mathlib.$(OBJEXT) \ ./src/a68g/a68g-pretty.$(OBJEXT) \ ./src/a68g/a68g-refinement.$(OBJEXT) \ ./src/a68g/a68g-regex.$(OBJEXT) ./src/a68g/a68g-rows.$(OBJEXT) \ ./src/a68g/a68g-scanner.$(OBJEXT) \ ./src/a68g/a68g-scope.$(OBJEXT) \ ./src/a68g/a68g-script.$(OBJEXT) \ ./src/a68g/a68g-single.$(OBJEXT) \ ./src/a68g/a68g-single-gamic.$(OBJEXT) \ ./src/a68g/a68g-single-gsl.$(OBJEXT) \ ./src/a68g/a68g-single-math.$(OBJEXT) \ ./src/a68g/a68g-single-mathlib.$(OBJEXT) \ ./src/a68g/a68g-single-rnd.$(OBJEXT) \ ./src/a68g/a68g-socket.$(OBJEXT) \ ./src/a68g/a68g-sounds.$(OBJEXT) \ ./src/a68g/a68g-taxes.$(OBJEXT) \ ./src/a68g/a68g-top-down.$(OBJEXT) \ ./src/a68g/a68g-torrix.$(OBJEXT) \ ./src/a68g/a68g-transput.$(OBJEXT) \ ./src/a68g/a68g-unix.$(OBJEXT) \ ./src/a68g/a68g-victal.$(OBJEXT) a68g_OBJECTS = $(am_a68g_OBJECTS) a68g_LDADD = $(LDADD) a68g_LINK = $(CCLD) $(a68g_CFLAGS) $(CFLAGS) $(a68g_LDFLAGS) \ $(LDFLAGS) -o $@ AM_V_P = $(am__v_P_@AM_V@) am__v_P_ = $(am__v_P_@AM_DEFAULT_V@) am__v_P_0 = false am__v_P_1 = : AM_V_GEN = $(am__v_GEN_@AM_V@) am__v_GEN_ = $(am__v_GEN_@AM_DEFAULT_V@) am__v_GEN_0 = @echo " GEN " $@; am__v_GEN_1 = AM_V_at = $(am__v_at_@AM_V@) am__v_at_ = $(am__v_at_@AM_DEFAULT_V@) am__v_at_0 = @ am__v_at_1 = DEFAULT_INCLUDES = -I.@am__isrc@ depcomp = $(SHELL) $(top_srcdir)/depcomp am__maybe_remake_depfiles = depfiles am__depfiles_remade = ./src/a68g/$(DEPDIR)/a68g-a68g.Po \ ./src/a68g/$(DEPDIR)/a68g-a68glib.Po \ ./src/a68g/$(DEPDIR)/a68g-apropos.Po \ ./src/a68g/$(DEPDIR)/a68g-bits.Po \ ./src/a68g/$(DEPDIR)/a68g-bool.Po \ ./src/a68g/$(DEPDIR)/a68g-bottom-up.Po \ ./src/a68g/$(DEPDIR)/a68g-brackets.Po \ ./src/a68g/$(DEPDIR)/a68g-char.Po \ ./src/a68g/$(DEPDIR)/a68g-compiler-basic.Po \ ./src/a68g/$(DEPDIR)/a68g-compiler-folder.Po \ ./src/a68g/$(DEPDIR)/a68g-compiler-gen.Po \ ./src/a68g/$(DEPDIR)/a68g-compiler-inline.Po \ ./src/a68g/$(DEPDIR)/a68g-compiler-tables.Po \ ./src/a68g/$(DEPDIR)/a68g-compiler.Po \ ./src/a68g/$(DEPDIR)/a68g-conversion.Po \ ./src/a68g/$(DEPDIR)/a68g-curses.Po \ ./src/a68g/$(DEPDIR)/a68g-diagnostics.Po \ ./src/a68g/$(DEPDIR)/a68g-double-gamic.Po \ ./src/a68g/$(DEPDIR)/a68g-double-math.Po \ ./src/a68g/$(DEPDIR)/a68g-double.Po \ ./src/a68g/$(DEPDIR)/a68g-enquiries.Po \ ./src/a68g/$(DEPDIR)/a68g-environ.Po \ ./src/a68g/$(DEPDIR)/a68g-equivalence.Po \ ./src/a68g/$(DEPDIR)/a68g-extract.Po \ ./src/a68g/$(DEPDIR)/a68g-fft.Po \ ./src/a68g/$(DEPDIR)/a68g-format.Po \ ./src/a68g/$(DEPDIR)/a68g-genie-coerce.Po \ ./src/a68g/$(DEPDIR)/a68g-genie-stowed.Po \ ./src/a68g/$(DEPDIR)/a68g-genie.Po \ ./src/a68g/$(DEPDIR)/a68g-heap.Po \ ./src/a68g/$(DEPDIR)/a68g-io.Po \ ./src/a68g/$(DEPDIR)/a68g-keywords.Po \ ./src/a68g/$(DEPDIR)/a68g-laplace.Po \ ./src/a68g/$(DEPDIR)/a68g-listing.Po \ ./src/a68g/$(DEPDIR)/a68g-mem.Po \ ./src/a68g/$(DEPDIR)/a68g-modes.Po \ ./src/a68g/$(DEPDIR)/a68g-moid-size.Po \ ./src/a68g/$(DEPDIR)/a68g-moid-to-string.Po \ ./src/a68g/$(DEPDIR)/a68g-monitor.Po \ ./src/a68g/$(DEPDIR)/a68g-mp-bits.Po \ ./src/a68g/$(DEPDIR)/a68g-mp-constant.Po \ ./src/a68g/$(DEPDIR)/a68g-mp-gamic.Po \ ./src/a68g/$(DEPDIR)/a68g-mp-gamma.Po \ ./src/a68g/$(DEPDIR)/a68g-mp-genie.Po \ ./src/a68g/$(DEPDIR)/a68g-mp-math.Po \ ./src/a68g/$(DEPDIR)/a68g-mp-mpfr.Po \ ./src/a68g/$(DEPDIR)/a68g-mp.Po \ ./src/a68g/$(DEPDIR)/a68g-non-terminal.Po \ ./src/a68g/$(DEPDIR)/a68g-options.Po \ ./src/a68g/$(DEPDIR)/a68g-parallel.Po \ ./src/a68g/$(DEPDIR)/a68g-parser.Po \ ./src/a68g/$(DEPDIR)/a68g-physics.Po \ ./src/a68g/$(DEPDIR)/a68g-plotutils.Po \ ./src/a68g/$(DEPDIR)/a68g-postgresql.Po \ ./src/a68g/$(DEPDIR)/a68g-postulates.Po \ ./src/a68g/$(DEPDIR)/a68g-prelude-bits.Po \ ./src/a68g/$(DEPDIR)/a68g-prelude-gsl.Po \ ./src/a68g/$(DEPDIR)/a68g-prelude-mathlib.Po \ ./src/a68g/$(DEPDIR)/a68g-prelude.Po \ ./src/a68g/$(DEPDIR)/a68g-pretty.Po \ ./src/a68g/$(DEPDIR)/a68g-refinement.Po \ ./src/a68g/$(DEPDIR)/a68g-regex.Po \ ./src/a68g/$(DEPDIR)/a68g-rows.Po \ ./src/a68g/$(DEPDIR)/a68g-scanner.Po \ ./src/a68g/$(DEPDIR)/a68g-scope.Po \ ./src/a68g/$(DEPDIR)/a68g-script.Po \ ./src/a68g/$(DEPDIR)/a68g-single-gamic.Po \ ./src/a68g/$(DEPDIR)/a68g-single-gsl.Po \ ./src/a68g/$(DEPDIR)/a68g-single-math.Po \ ./src/a68g/$(DEPDIR)/a68g-single-mathlib.Po \ ./src/a68g/$(DEPDIR)/a68g-single-rnd.Po \ ./src/a68g/$(DEPDIR)/a68g-single.Po \ ./src/a68g/$(DEPDIR)/a68g-socket.Po \ ./src/a68g/$(DEPDIR)/a68g-sounds.Po \ ./src/a68g/$(DEPDIR)/a68g-taxes.Po \ ./src/a68g/$(DEPDIR)/a68g-top-down.Po \ ./src/a68g/$(DEPDIR)/a68g-torrix.Po \ ./src/a68g/$(DEPDIR)/a68g-transput.Po \ ./src/a68g/$(DEPDIR)/a68g-unix.Po \ ./src/a68g/$(DEPDIR)/a68g-victal.Po am__mv = mv -f AM_V_lt = $(am__v_lt_@AM_V@) am__v_lt_ = $(am__v_lt_@AM_DEFAULT_V@) am__v_lt_0 = --silent am__v_lt_1 = COMPILE = $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) \ $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) AM_V_CC = $(am__v_CC_@AM_V@) am__v_CC_ = $(am__v_CC_@AM_DEFAULT_V@) am__v_CC_0 = @echo " CC " $@; am__v_CC_1 = CCLD = $(CC) LINK = $(CCLD) $(AM_CFLAGS) $(CFLAGS) $(AM_LDFLAGS) $(LDFLAGS) -o $@ AM_V_CCLD = $(am__v_CCLD_@AM_V@) am__v_CCLD_ = $(am__v_CCLD_@AM_DEFAULT_V@) am__v_CCLD_0 = @echo " CCLD " $@; am__v_CCLD_1 = SOURCES = $(a68g_SOURCES) DIST_SOURCES = $(a68g_SOURCES) am__can_run_installinfo = \ case $$AM_UPDATE_INFO_DIR in \ n|no|NO) false;; \ *) (install-info --version) >/dev/null 2>&1;; \ esac 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 = f=`echo $$p | sed -e 's|^.*/||'`; am__install_max = 40 am__nobase_strip_setup = \ srcdirstrip=`echo "$(srcdir)" | sed 's/[].[^$$\\*|]/\\\\&/g'` am__nobase_strip = \ for p in $$list; do echo "$$p"; done | sed -e "s|$$srcdirstrip/||" am__nobase_list = $(am__nobase_strip_setup); \ for p in $$list; do echo "$$p $$p"; done | \ sed "s| $$srcdirstrip/| |;"' / .*\//!s/ .*/ ./; s,\( .*\)/[^/]*$$,\1,' | \ $(AWK) 'BEGIN { files["."] = "" } { files[$$2] = files[$$2] " " $$1; \ if (++n[$$2] == $(am__install_max)) \ { print $$2, files[$$2]; n[$$2] = 0; files[$$2] = "" } } \ END { for (dir in files) print dir, files[dir] }' am__base_list = \ sed '$$!N;$$!N;$$!N;$$!N;$$!N;$$!N;$$!N;s/\n/ /g' | \ sed '$$!N;$$!N;$$!N;$$!N;s/\n/ /g' am__uninstall_files_from_dir = { \ test -z "$$files" \ || { test ! -d "$$dir" && test ! -f "$$dir" && test ! -r "$$dir"; } \ || { echo " ( cd '$$dir' && rm -f" $$files ")"; \ $(am__cd) "$$dir" && rm -f $$files; }; \ } man1dir = $(mandir)/man1 NROFF = nroff MANS = $(man_MANS) DATA = $(doc_DATA) HEADERS = $(pkginclude_HEADERS) am__tagged_files = $(HEADERS) $(SOURCES) $(TAGS_FILES) $(LISP) \ a68g-config.h.in # Read a list of newline-separated strings from the standard input, # and print each of them once, without duplicates. Input order is # *not* preserved. am__uniquify_input = $(AWK) '\ BEGIN { nonempty = 0; } \ { items[$$0] = 1; nonempty = 1; } \ END { if (nonempty) { for (i in items) print i; }; } \ ' # Make sure the list of sources is unique. This is necessary because, # e.g., the same source file might be shared among _SOURCES variables # for different programs/libraries. am__define_uniq_tagged_files = \ list='$(am__tagged_files)'; \ unique=`for i in $$list; do \ if test -f "$$i"; then echo $$i; else echo $(srcdir)/$$i; fi; \ done | $(am__uniquify_input)` ETAGS = etags CTAGS = ctags CSCOPE = cscope AM_RECURSIVE_TARGETS = cscope am__tty_colors_dummy = \ mgn= red= grn= lgn= blu= brg= std=; \ am__color_tests=no am__tty_colors = { \ $(am__tty_colors_dummy); \ if test "X$(AM_COLOR_TESTS)" = Xno; then \ am__color_tests=no; \ elif test "X$(AM_COLOR_TESTS)" = Xalways; then \ am__color_tests=yes; \ elif test "X$$TERM" != Xdumb && { test -t 1; } 2>/dev/null; then \ am__color_tests=yes; \ fi; \ if test $$am__color_tests = yes; then \ red=''; \ grn=''; \ lgn=''; \ blu=''; \ mgn=''; \ brg=''; \ std=''; \ fi; \ } am__DIST_COMMON = $(srcdir)/Makefile.in $(srcdir)/a68g-config.h.in \ AUTHORS COPYING ChangeLog INSTALL NEWS README compile \ config.guess config.sub depcomp install-sh missing DISTFILES = $(DIST_COMMON) $(DIST_SOURCES) $(TEXINFOS) $(EXTRA_DIST) distdir = $(PACKAGE)-$(VERSION) top_distdir = $(distdir) am__remove_distdir = \ if test -d "$(distdir)"; then \ find "$(distdir)" -type d ! -perm -200 -exec chmod u+w {} ';' \ && rm -rf "$(distdir)" \ || { sleep 5 && rm -rf "$(distdir)"; }; \ else :; fi am__post_remove_distdir = $(am__remove_distdir) DIST_ARCHIVES = $(distdir).tar.gz GZIP_ENV = --best DIST_TARGETS = dist-gzip # Exists only to be overridden by the user if desired. AM_DISTCHECK_DVI_TARGET = dvi distuninstallcheck_listfiles = find . -type f -print am__distuninstallcheck_listfiles = $(distuninstallcheck_listfiles) \ | sed 's|^\./|$(prefix)/|' | grep -v '$(infodir)/dir$$' distcleancheck_listfiles = find . -type f -print ACLOCAL = @ACLOCAL@ AMTAR = @AMTAR@ AM_DEFAULT_VERBOSITY = @AM_DEFAULT_VERBOSITY@ 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@ GSL_CFLAGS = @GSL_CFLAGS@ GSL_CONFIG = @GSL_CONFIG@ GSL_LIBS = @GSL_LIBS@ 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_URL = @PACKAGE_URL@ 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@ runstatedir = @runstatedir@ 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@ a68g_SOURCES = \ ./src/a68g/a68g.c \ ./src/a68g/a68glib.c \ ./src/a68g/apropos.c \ ./src/a68g/bits.c \ ./src/a68g/bool.c \ ./src/a68g/bottom-up.c \ ./src/a68g/brackets.c \ ./src/a68g/char.c \ ./src/a68g/compiler-basic.c \ ./src/a68g/compiler.c \ ./src/a68g/compiler-folder.c \ ./src/a68g/compiler-gen.c \ ./src/a68g/compiler-inline.c \ ./src/a68g/compiler-tables.c \ ./src/a68g/conversion.c \ ./src/a68g/curses.c \ ./src/a68g/diagnostics.c \ ./src/a68g/double.c \ ./src/a68g/double-gamic.c \ ./src/a68g/double-math.c \ ./src/a68g/enquiries.c \ ./src/a68g/environ.c \ ./src/a68g/equivalence.c \ ./src/a68g/extract.c \ ./src/a68g/fft.c \ ./src/a68g/format.c \ ./src/a68g/genie.c \ ./src/a68g/genie-coerce.c \ ./src/a68g/genie-stowed.c \ ./src/a68g/heap.c \ ./src/a68g/io.c \ ./src/a68g/keywords.c \ ./src/a68g/laplace.c \ ./src/a68g/listing.c \ ./src/a68g/mem.c \ ./src/a68g/modes.c \ ./src/a68g/moid-size.c \ ./src/a68g/moid-to-string.c \ ./src/a68g/monitor.c \ ./src/a68g/mp-bits.c \ ./src/a68g/mp.c \ ./src/a68g/mp-constant.c \ ./src/a68g/mp-gamic.c \ ./src/a68g/mp-gamma.c \ ./src/a68g/mp-genie.c \ ./src/a68g/mp-math.c \ ./src/a68g/mp-mpfr.c \ ./src/a68g/non-terminal.c \ ./src/a68g/options.c \ ./src/a68g/parallel.c \ ./src/a68g/parser.c \ ./src/a68g/physics.c \ ./src/a68g/plotutils.c \ ./src/a68g/postgresql.c \ ./src/a68g/postulates.c \ ./src/a68g/prelude-bits.c \ ./src/a68g/prelude.c \ ./src/a68g/prelude-gsl.c \ ./src/a68g/prelude-mathlib.c \ ./src/a68g/pretty.c \ ./src/a68g/refinement.c \ ./src/a68g/regex.c \ ./src/a68g/rows.c \ ./src/a68g/scanner.c \ ./src/a68g/scope.c \ ./src/a68g/script.c \ ./src/a68g/single.c \ ./src/a68g/single-gamic.c \ ./src/a68g/single-gsl.c \ ./src/a68g/single-math.c \ ./src/a68g/single-mathlib.c \ ./src/a68g/single-rnd.c \ ./src/a68g/socket.c \ ./src/a68g/sounds.c \ ./src/a68g/taxes.c \ ./src/a68g/top-down.c \ ./src/a68g/torrix.c \ ./src/a68g/transput.c \ ./src/a68g/unix.c \ ./src/a68g/victal.c \ ./src/include/a68g-common.h \ ./src/include/a68g-compiler.h \ ./src/include/a68g-config.win32.h \ ./src/include/a68g-defines.h \ ./src/include/a68g-diagnostics.h \ ./src/include/a68g-double.h \ ./src/include/a68g-enums.h \ ./src/include/a68g-environ.h \ ./src/include/a68g-frames.h \ ./src/include/a68g-generic.h \ ./src/include/a68g-genie.h \ ./src/include/a68g.h \ ./src/include/a68g-includes.h \ ./src/include/a68g-level-3.h \ ./src/include/a68g-lib.h \ ./src/include/a68g-listing.h \ ./src/include/a68g-masks.h \ ./src/include/a68g-math.h \ ./src/include/a68g-mp.h \ ./src/include/a68g-nil.h \ ./src/include/a68g-numbers.h \ ./src/include/a68g-optimiser.h \ ./src/include/a68g-options.h \ ./src/include/a68g-parser.h \ ./src/include/a68g-physics.h \ ./src/include/a68g-platform.h \ ./src/include/a68g-postulates.h \ ./src/include/a68g-prelude-gsl.h \ ./src/include/a68g-prelude.h \ ./src/include/a68g-prelude-mathlib.h \ ./src/include/a68g-stack.h \ ./src/include/a68g-stddef.h \ ./src/include/a68g-transput.h \ ./src/include/a68g-types.h pkginclude_HEADERS = \ ./a68g-config.h \ ./src/include/a68g-common.h \ ./src/include/a68g-compiler.h \ ./src/include/a68g-config.win32.h \ ./src/include/a68g-defines.h \ ./src/include/a68g-diagnostics.h \ ./src/include/a68g-double.h \ ./src/include/a68g-enums.h \ ./src/include/a68g-environ.h \ ./src/include/a68g-frames.h \ ./src/include/a68g-generic.h \ ./src/include/a68g-genie.h \ ./src/include/a68g.h \ ./src/include/a68g-includes.h \ ./src/include/a68g-level-3.h \ ./src/include/a68g-lib.h \ ./src/include/a68g-listing.h \ ./src/include/a68g-masks.h \ ./src/include/a68g-math.h \ ./src/include/a68g-mp.h \ ./src/include/a68g-nil.h \ ./src/include/a68g-numbers.h \ ./src/include/a68g-optimiser.h \ ./src/include/a68g-options.h \ ./src/include/a68g-parser.h \ ./src/include/a68g-physics.h \ ./src/include/a68g-platform.h \ ./src/include/a68g-postulates.h \ ./src/include/a68g-prelude-gsl.h \ ./src/include/a68g-prelude.h \ ./src/include/a68g-prelude-mathlib.h \ ./src/include/a68g-stack.h \ ./src/include/a68g-stddef.h \ ./src/include/a68g-transput.h \ ./src/include/a68g-types.h a68g_CFLAGS = -DBINDIR='"$(bindir)"' -DINCLUDEDIR='"$(includedir)"' a68g_CPPFLAGS = -I$(top_srcdir)/src/include TESTS_ENVIRONMENT = ./a68g TESTS = \ test-set/01-chaos.a68\ test-set/02-decision.a68\ test-set/03-digits.a68\ test-set/04-end-of-time.a68\ test-set/05-fft.a68\ test-set/06-fibonacci-grammar.a68\ test-set/07-formula-manipulation.a68\ test-set/08-guldens.a68\ test-set/09-hamming.a68\ test-set/10-hilbert.a68\ test-set/11-lisp.a68\ test-set/12-mandelbrot.a68\ test-set/13-mastermind.a68\ test-set/14-math.a68\ test-set/15-mersenne.a68\ test-set/16-procedures.a68\ test-set/17-pseudo-switch.a68\ test-set/18-qgammainc.a68\ test-set/19-queens.a68\ test-set/20-quicksort.a68\ test-set/21-rationals.a68\ test-set/22-semana-santa.a68\ test-set/23-tukey.a68\ test-set/24-whetstones.a68 @EXPORT_DYNAMIC_FALSE@a68g_LDFLAGS = @EXPORT_DYNAMIC_TRUE@a68g_LDFLAGS = -Wl,--export-dynamic man_MANS = doc/a68g.1 doc_DATA = AUTHORS COPYING ChangeLog NEWS README EXTRA_DIST = $(man_MANS)\ $(TESTS) all: a68g-config.h $(MAKE) $(AM_MAKEFLAGS) all-am .SUFFIXES: .SUFFIXES: .c .o .obj am--refresh: Makefile @: $(srcdir)/Makefile.in: $(srcdir)/Makefile.am $(am__configure_deps) @for dep in $?; do \ case '$(am__configure_deps)' in \ *$$dep*) \ echo ' cd $(srcdir) && $(AUTOMAKE) --gnu'; \ $(am__cd) $(srcdir) && $(AUTOMAKE) --gnu \ && exit 0; \ exit 1;; \ esac; \ done; \ echo ' cd $(top_srcdir) && $(AUTOMAKE) --gnu Makefile'; \ $(am__cd) $(top_srcdir) && \ $(AUTOMAKE) --gnu 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__maybe_remake_depfiles)'; \ cd $(top_builddir) && $(SHELL) ./config.status $@ $(am__maybe_remake_depfiles);; \ esac; $(top_builddir)/config.status: $(top_srcdir)/configure $(CONFIG_STATUS_DEPENDENCIES) $(SHELL) ./config.status --recheck $(top_srcdir)/configure: $(am__configure_deps) $(am__cd) $(srcdir) && $(AUTOCONF) $(ACLOCAL_M4): $(am__aclocal_m4_deps) $(am__cd) $(srcdir) && $(ACLOCAL) $(ACLOCAL_AMFLAGS) $(am__aclocal_m4_deps): a68g-config.h: stamp-h1 @test -f $@ || rm -f stamp-h1 @test -f $@ || $(MAKE) $(AM_MAKEFLAGS) stamp-h1 stamp-h1: $(srcdir)/a68g-config.h.in $(top_builddir)/config.status @rm -f stamp-h1 cd $(top_builddir) && $(SHELL) ./config.status a68g-config.h $(srcdir)/a68g-config.h.in: $(am__configure_deps) ($(am__cd) $(top_srcdir) && $(AUTOHEADER)) rm -f stamp-h1 touch $@ distclean-hdr: -rm -f a68g-config.h stamp-h1 install-binPROGRAMS: $(bin_PROGRAMS) @$(NORMAL_INSTALL) @list='$(bin_PROGRAMS)'; test -n "$(bindir)" || list=; \ if test -n "$$list"; then \ echo " $(MKDIR_P) '$(DESTDIR)$(bindir)'"; \ $(MKDIR_P) "$(DESTDIR)$(bindir)" || exit 1; \ fi; \ for p in $$list; do echo "$$p $$p"; done | \ sed 's/$(EXEEXT)$$//' | \ while read p p1; do if test -f $$p \ ; then echo "$$p"; echo "$$p"; else :; fi; \ done | \ sed -e 'p;s,.*/,,;n;h' \ -e 's|.*|.|' \ -e 'p;x;s,.*/,,;s/$(EXEEXT)$$//;$(transform);s/$$/$(EXEEXT)/' | \ sed 'N;N;N;s,\n, ,g' | \ $(AWK) 'BEGIN { files["."] = ""; dirs["."] = 1 } \ { d=$$3; if (dirs[d] != 1) { print "d", d; dirs[d] = 1 } \ if ($$2 == $$4) files[d] = files[d] " " $$1; \ else { print "f", $$3 "/" $$4, $$1; } } \ END { for (d in files) print "f", d, files[d] }' | \ while read type dir files; do \ if test "$$dir" = .; then dir=; else dir=/$$dir; fi; \ test -z "$$files" || { \ echo " $(INSTALL_PROGRAM_ENV) $(INSTALL_PROGRAM) $$files '$(DESTDIR)$(bindir)$$dir'"; \ $(INSTALL_PROGRAM_ENV) $(INSTALL_PROGRAM) $$files "$(DESTDIR)$(bindir)$$dir" || exit $$?; \ } \ ; done uninstall-binPROGRAMS: @$(NORMAL_UNINSTALL) @list='$(bin_PROGRAMS)'; test -n "$(bindir)" || list=; \ files=`for p in $$list; do echo "$$p"; done | \ sed -e 'h;s,^.*/,,;s/$(EXEEXT)$$//;$(transform)' \ -e 's/$$/$(EXEEXT)/' \ `; \ test -n "$$list" || exit 0; \ echo " ( cd '$(DESTDIR)$(bindir)' && rm -f" $$files ")"; \ cd "$(DESTDIR)$(bindir)" && rm -f $$files clean-binPROGRAMS: -test -z "$(bin_PROGRAMS)" || rm -f $(bin_PROGRAMS) src/a68g/$(am__dirstamp): @$(MKDIR_P) ./src/a68g @: > src/a68g/$(am__dirstamp) src/a68g/$(DEPDIR)/$(am__dirstamp): @$(MKDIR_P) ./src/a68g/$(DEPDIR) @: > src/a68g/$(DEPDIR)/$(am__dirstamp) ./src/a68g/a68g-a68g.$(OBJEXT): src/a68g/$(am__dirstamp) \ src/a68g/$(DEPDIR)/$(am__dirstamp) ./src/a68g/a68g-a68glib.$(OBJEXT): src/a68g/$(am__dirstamp) \ src/a68g/$(DEPDIR)/$(am__dirstamp) ./src/a68g/a68g-apropos.$(OBJEXT): src/a68g/$(am__dirstamp) \ src/a68g/$(DEPDIR)/$(am__dirstamp) ./src/a68g/a68g-bits.$(OBJEXT): src/a68g/$(am__dirstamp) \ src/a68g/$(DEPDIR)/$(am__dirstamp) ./src/a68g/a68g-bool.$(OBJEXT): src/a68g/$(am__dirstamp) \ src/a68g/$(DEPDIR)/$(am__dirstamp) ./src/a68g/a68g-bottom-up.$(OBJEXT): src/a68g/$(am__dirstamp) \ src/a68g/$(DEPDIR)/$(am__dirstamp) ./src/a68g/a68g-brackets.$(OBJEXT): src/a68g/$(am__dirstamp) \ src/a68g/$(DEPDIR)/$(am__dirstamp) ./src/a68g/a68g-char.$(OBJEXT): src/a68g/$(am__dirstamp) \ src/a68g/$(DEPDIR)/$(am__dirstamp) ./src/a68g/a68g-compiler-basic.$(OBJEXT): src/a68g/$(am__dirstamp) \ src/a68g/$(DEPDIR)/$(am__dirstamp) ./src/a68g/a68g-compiler.$(OBJEXT): src/a68g/$(am__dirstamp) \ src/a68g/$(DEPDIR)/$(am__dirstamp) ./src/a68g/a68g-compiler-folder.$(OBJEXT): src/a68g/$(am__dirstamp) \ src/a68g/$(DEPDIR)/$(am__dirstamp) ./src/a68g/a68g-compiler-gen.$(OBJEXT): src/a68g/$(am__dirstamp) \ src/a68g/$(DEPDIR)/$(am__dirstamp) ./src/a68g/a68g-compiler-inline.$(OBJEXT): src/a68g/$(am__dirstamp) \ src/a68g/$(DEPDIR)/$(am__dirstamp) ./src/a68g/a68g-compiler-tables.$(OBJEXT): src/a68g/$(am__dirstamp) \ src/a68g/$(DEPDIR)/$(am__dirstamp) ./src/a68g/a68g-conversion.$(OBJEXT): src/a68g/$(am__dirstamp) \ src/a68g/$(DEPDIR)/$(am__dirstamp) ./src/a68g/a68g-curses.$(OBJEXT): src/a68g/$(am__dirstamp) \ src/a68g/$(DEPDIR)/$(am__dirstamp) ./src/a68g/a68g-diagnostics.$(OBJEXT): src/a68g/$(am__dirstamp) \ src/a68g/$(DEPDIR)/$(am__dirstamp) ./src/a68g/a68g-double.$(OBJEXT): src/a68g/$(am__dirstamp) \ src/a68g/$(DEPDIR)/$(am__dirstamp) ./src/a68g/a68g-double-gamic.$(OBJEXT): src/a68g/$(am__dirstamp) \ src/a68g/$(DEPDIR)/$(am__dirstamp) ./src/a68g/a68g-double-math.$(OBJEXT): src/a68g/$(am__dirstamp) \ src/a68g/$(DEPDIR)/$(am__dirstamp) ./src/a68g/a68g-enquiries.$(OBJEXT): src/a68g/$(am__dirstamp) \ src/a68g/$(DEPDIR)/$(am__dirstamp) ./src/a68g/a68g-environ.$(OBJEXT): src/a68g/$(am__dirstamp) \ src/a68g/$(DEPDIR)/$(am__dirstamp) ./src/a68g/a68g-equivalence.$(OBJEXT): src/a68g/$(am__dirstamp) \ src/a68g/$(DEPDIR)/$(am__dirstamp) ./src/a68g/a68g-extract.$(OBJEXT): src/a68g/$(am__dirstamp) \ src/a68g/$(DEPDIR)/$(am__dirstamp) ./src/a68g/a68g-fft.$(OBJEXT): src/a68g/$(am__dirstamp) \ src/a68g/$(DEPDIR)/$(am__dirstamp) ./src/a68g/a68g-format.$(OBJEXT): src/a68g/$(am__dirstamp) \ src/a68g/$(DEPDIR)/$(am__dirstamp) ./src/a68g/a68g-genie.$(OBJEXT): src/a68g/$(am__dirstamp) \ src/a68g/$(DEPDIR)/$(am__dirstamp) ./src/a68g/a68g-genie-coerce.$(OBJEXT): src/a68g/$(am__dirstamp) \ src/a68g/$(DEPDIR)/$(am__dirstamp) ./src/a68g/a68g-genie-stowed.$(OBJEXT): src/a68g/$(am__dirstamp) \ src/a68g/$(DEPDIR)/$(am__dirstamp) ./src/a68g/a68g-heap.$(OBJEXT): src/a68g/$(am__dirstamp) \ src/a68g/$(DEPDIR)/$(am__dirstamp) ./src/a68g/a68g-io.$(OBJEXT): src/a68g/$(am__dirstamp) \ src/a68g/$(DEPDIR)/$(am__dirstamp) ./src/a68g/a68g-keywords.$(OBJEXT): src/a68g/$(am__dirstamp) \ src/a68g/$(DEPDIR)/$(am__dirstamp) ./src/a68g/a68g-laplace.$(OBJEXT): src/a68g/$(am__dirstamp) \ src/a68g/$(DEPDIR)/$(am__dirstamp) ./src/a68g/a68g-listing.$(OBJEXT): src/a68g/$(am__dirstamp) \ src/a68g/$(DEPDIR)/$(am__dirstamp) ./src/a68g/a68g-mem.$(OBJEXT): src/a68g/$(am__dirstamp) \ src/a68g/$(DEPDIR)/$(am__dirstamp) ./src/a68g/a68g-modes.$(OBJEXT): src/a68g/$(am__dirstamp) \ src/a68g/$(DEPDIR)/$(am__dirstamp) ./src/a68g/a68g-moid-size.$(OBJEXT): src/a68g/$(am__dirstamp) \ src/a68g/$(DEPDIR)/$(am__dirstamp) ./src/a68g/a68g-moid-to-string.$(OBJEXT): src/a68g/$(am__dirstamp) \ src/a68g/$(DEPDIR)/$(am__dirstamp) ./src/a68g/a68g-monitor.$(OBJEXT): src/a68g/$(am__dirstamp) \ src/a68g/$(DEPDIR)/$(am__dirstamp) ./src/a68g/a68g-mp-bits.$(OBJEXT): src/a68g/$(am__dirstamp) \ src/a68g/$(DEPDIR)/$(am__dirstamp) ./src/a68g/a68g-mp.$(OBJEXT): src/a68g/$(am__dirstamp) \ src/a68g/$(DEPDIR)/$(am__dirstamp) ./src/a68g/a68g-mp-constant.$(OBJEXT): src/a68g/$(am__dirstamp) \ src/a68g/$(DEPDIR)/$(am__dirstamp) ./src/a68g/a68g-mp-gamic.$(OBJEXT): src/a68g/$(am__dirstamp) \ src/a68g/$(DEPDIR)/$(am__dirstamp) ./src/a68g/a68g-mp-gamma.$(OBJEXT): src/a68g/$(am__dirstamp) \ src/a68g/$(DEPDIR)/$(am__dirstamp) ./src/a68g/a68g-mp-genie.$(OBJEXT): src/a68g/$(am__dirstamp) \ src/a68g/$(DEPDIR)/$(am__dirstamp) ./src/a68g/a68g-mp-math.$(OBJEXT): src/a68g/$(am__dirstamp) \ src/a68g/$(DEPDIR)/$(am__dirstamp) ./src/a68g/a68g-mp-mpfr.$(OBJEXT): src/a68g/$(am__dirstamp) \ src/a68g/$(DEPDIR)/$(am__dirstamp) ./src/a68g/a68g-non-terminal.$(OBJEXT): src/a68g/$(am__dirstamp) \ src/a68g/$(DEPDIR)/$(am__dirstamp) ./src/a68g/a68g-options.$(OBJEXT): src/a68g/$(am__dirstamp) \ src/a68g/$(DEPDIR)/$(am__dirstamp) ./src/a68g/a68g-parallel.$(OBJEXT): src/a68g/$(am__dirstamp) \ src/a68g/$(DEPDIR)/$(am__dirstamp) ./src/a68g/a68g-parser.$(OBJEXT): src/a68g/$(am__dirstamp) \ src/a68g/$(DEPDIR)/$(am__dirstamp) ./src/a68g/a68g-physics.$(OBJEXT): src/a68g/$(am__dirstamp) \ src/a68g/$(DEPDIR)/$(am__dirstamp) ./src/a68g/a68g-plotutils.$(OBJEXT): src/a68g/$(am__dirstamp) \ src/a68g/$(DEPDIR)/$(am__dirstamp) ./src/a68g/a68g-postgresql.$(OBJEXT): src/a68g/$(am__dirstamp) \ src/a68g/$(DEPDIR)/$(am__dirstamp) ./src/a68g/a68g-postulates.$(OBJEXT): src/a68g/$(am__dirstamp) \ src/a68g/$(DEPDIR)/$(am__dirstamp) ./src/a68g/a68g-prelude-bits.$(OBJEXT): src/a68g/$(am__dirstamp) \ src/a68g/$(DEPDIR)/$(am__dirstamp) ./src/a68g/a68g-prelude.$(OBJEXT): src/a68g/$(am__dirstamp) \ src/a68g/$(DEPDIR)/$(am__dirstamp) ./src/a68g/a68g-prelude-gsl.$(OBJEXT): src/a68g/$(am__dirstamp) \ src/a68g/$(DEPDIR)/$(am__dirstamp) ./src/a68g/a68g-prelude-mathlib.$(OBJEXT): src/a68g/$(am__dirstamp) \ src/a68g/$(DEPDIR)/$(am__dirstamp) ./src/a68g/a68g-pretty.$(OBJEXT): src/a68g/$(am__dirstamp) \ src/a68g/$(DEPDIR)/$(am__dirstamp) ./src/a68g/a68g-refinement.$(OBJEXT): src/a68g/$(am__dirstamp) \ src/a68g/$(DEPDIR)/$(am__dirstamp) ./src/a68g/a68g-regex.$(OBJEXT): src/a68g/$(am__dirstamp) \ src/a68g/$(DEPDIR)/$(am__dirstamp) ./src/a68g/a68g-rows.$(OBJEXT): src/a68g/$(am__dirstamp) \ src/a68g/$(DEPDIR)/$(am__dirstamp) ./src/a68g/a68g-scanner.$(OBJEXT): src/a68g/$(am__dirstamp) \ src/a68g/$(DEPDIR)/$(am__dirstamp) ./src/a68g/a68g-scope.$(OBJEXT): src/a68g/$(am__dirstamp) \ src/a68g/$(DEPDIR)/$(am__dirstamp) ./src/a68g/a68g-script.$(OBJEXT): src/a68g/$(am__dirstamp) \ src/a68g/$(DEPDIR)/$(am__dirstamp) ./src/a68g/a68g-single.$(OBJEXT): src/a68g/$(am__dirstamp) \ src/a68g/$(DEPDIR)/$(am__dirstamp) ./src/a68g/a68g-single-gamic.$(OBJEXT): src/a68g/$(am__dirstamp) \ src/a68g/$(DEPDIR)/$(am__dirstamp) ./src/a68g/a68g-single-gsl.$(OBJEXT): src/a68g/$(am__dirstamp) \ src/a68g/$(DEPDIR)/$(am__dirstamp) ./src/a68g/a68g-single-math.$(OBJEXT): src/a68g/$(am__dirstamp) \ src/a68g/$(DEPDIR)/$(am__dirstamp) ./src/a68g/a68g-single-mathlib.$(OBJEXT): src/a68g/$(am__dirstamp) \ src/a68g/$(DEPDIR)/$(am__dirstamp) ./src/a68g/a68g-single-rnd.$(OBJEXT): src/a68g/$(am__dirstamp) \ src/a68g/$(DEPDIR)/$(am__dirstamp) ./src/a68g/a68g-socket.$(OBJEXT): src/a68g/$(am__dirstamp) \ src/a68g/$(DEPDIR)/$(am__dirstamp) ./src/a68g/a68g-sounds.$(OBJEXT): src/a68g/$(am__dirstamp) \ src/a68g/$(DEPDIR)/$(am__dirstamp) ./src/a68g/a68g-taxes.$(OBJEXT): src/a68g/$(am__dirstamp) \ src/a68g/$(DEPDIR)/$(am__dirstamp) ./src/a68g/a68g-top-down.$(OBJEXT): src/a68g/$(am__dirstamp) \ src/a68g/$(DEPDIR)/$(am__dirstamp) ./src/a68g/a68g-torrix.$(OBJEXT): src/a68g/$(am__dirstamp) \ src/a68g/$(DEPDIR)/$(am__dirstamp) ./src/a68g/a68g-transput.$(OBJEXT): src/a68g/$(am__dirstamp) \ src/a68g/$(DEPDIR)/$(am__dirstamp) ./src/a68g/a68g-unix.$(OBJEXT): src/a68g/$(am__dirstamp) \ src/a68g/$(DEPDIR)/$(am__dirstamp) ./src/a68g/a68g-victal.$(OBJEXT): src/a68g/$(am__dirstamp) \ src/a68g/$(DEPDIR)/$(am__dirstamp) a68g$(EXEEXT): $(a68g_OBJECTS) $(a68g_DEPENDENCIES) $(EXTRA_a68g_DEPENDENCIES) @rm -f a68g$(EXEEXT) $(AM_V_CCLD)$(a68g_LINK) $(a68g_OBJECTS) $(a68g_LDADD) $(LIBS) mostlyclean-compile: -rm -f *.$(OBJEXT) -rm -f ./src/a68g/*.$(OBJEXT) distclean-compile: -rm -f *.tab.c @AMDEP_TRUE@@am__include@ @am__quote@./src/a68g/$(DEPDIR)/a68g-a68g.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@./src/a68g/$(DEPDIR)/a68g-a68glib.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@./src/a68g/$(DEPDIR)/a68g-apropos.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@./src/a68g/$(DEPDIR)/a68g-bits.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@./src/a68g/$(DEPDIR)/a68g-bool.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@./src/a68g/$(DEPDIR)/a68g-bottom-up.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@./src/a68g/$(DEPDIR)/a68g-brackets.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@./src/a68g/$(DEPDIR)/a68g-char.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@./src/a68g/$(DEPDIR)/a68g-compiler-basic.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@./src/a68g/$(DEPDIR)/a68g-compiler-folder.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@./src/a68g/$(DEPDIR)/a68g-compiler-gen.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@./src/a68g/$(DEPDIR)/a68g-compiler-inline.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@./src/a68g/$(DEPDIR)/a68g-compiler-tables.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@./src/a68g/$(DEPDIR)/a68g-compiler.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@./src/a68g/$(DEPDIR)/a68g-conversion.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@./src/a68g/$(DEPDIR)/a68g-curses.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@./src/a68g/$(DEPDIR)/a68g-diagnostics.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@./src/a68g/$(DEPDIR)/a68g-double-gamic.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@./src/a68g/$(DEPDIR)/a68g-double-math.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@./src/a68g/$(DEPDIR)/a68g-double.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@./src/a68g/$(DEPDIR)/a68g-enquiries.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@./src/a68g/$(DEPDIR)/a68g-environ.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@./src/a68g/$(DEPDIR)/a68g-equivalence.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@./src/a68g/$(DEPDIR)/a68g-extract.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@./src/a68g/$(DEPDIR)/a68g-fft.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@./src/a68g/$(DEPDIR)/a68g-format.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@./src/a68g/$(DEPDIR)/a68g-genie-coerce.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@./src/a68g/$(DEPDIR)/a68g-genie-stowed.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@./src/a68g/$(DEPDIR)/a68g-genie.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@./src/a68g/$(DEPDIR)/a68g-heap.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@./src/a68g/$(DEPDIR)/a68g-io.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@./src/a68g/$(DEPDIR)/a68g-keywords.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@./src/a68g/$(DEPDIR)/a68g-laplace.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@./src/a68g/$(DEPDIR)/a68g-listing.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@./src/a68g/$(DEPDIR)/a68g-mem.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@./src/a68g/$(DEPDIR)/a68g-modes.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@./src/a68g/$(DEPDIR)/a68g-moid-size.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@./src/a68g/$(DEPDIR)/a68g-moid-to-string.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@./src/a68g/$(DEPDIR)/a68g-monitor.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@./src/a68g/$(DEPDIR)/a68g-mp-bits.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@./src/a68g/$(DEPDIR)/a68g-mp-constant.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@./src/a68g/$(DEPDIR)/a68g-mp-gamic.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@./src/a68g/$(DEPDIR)/a68g-mp-gamma.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@./src/a68g/$(DEPDIR)/a68g-mp-genie.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@./src/a68g/$(DEPDIR)/a68g-mp-math.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@./src/a68g/$(DEPDIR)/a68g-mp-mpfr.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@./src/a68g/$(DEPDIR)/a68g-mp.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@./src/a68g/$(DEPDIR)/a68g-non-terminal.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@./src/a68g/$(DEPDIR)/a68g-options.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@./src/a68g/$(DEPDIR)/a68g-parallel.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@./src/a68g/$(DEPDIR)/a68g-parser.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@./src/a68g/$(DEPDIR)/a68g-physics.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@./src/a68g/$(DEPDIR)/a68g-plotutils.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@./src/a68g/$(DEPDIR)/a68g-postgresql.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@./src/a68g/$(DEPDIR)/a68g-postulates.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@./src/a68g/$(DEPDIR)/a68g-prelude-bits.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@./src/a68g/$(DEPDIR)/a68g-prelude-gsl.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@./src/a68g/$(DEPDIR)/a68g-prelude-mathlib.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@./src/a68g/$(DEPDIR)/a68g-prelude.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@./src/a68g/$(DEPDIR)/a68g-pretty.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@./src/a68g/$(DEPDIR)/a68g-refinement.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@./src/a68g/$(DEPDIR)/a68g-regex.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@./src/a68g/$(DEPDIR)/a68g-rows.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@./src/a68g/$(DEPDIR)/a68g-scanner.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@./src/a68g/$(DEPDIR)/a68g-scope.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@./src/a68g/$(DEPDIR)/a68g-script.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@./src/a68g/$(DEPDIR)/a68g-single-gamic.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@./src/a68g/$(DEPDIR)/a68g-single-gsl.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@./src/a68g/$(DEPDIR)/a68g-single-math.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@./src/a68g/$(DEPDIR)/a68g-single-mathlib.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@./src/a68g/$(DEPDIR)/a68g-single-rnd.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@./src/a68g/$(DEPDIR)/a68g-single.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@./src/a68g/$(DEPDIR)/a68g-socket.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@./src/a68g/$(DEPDIR)/a68g-sounds.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@./src/a68g/$(DEPDIR)/a68g-taxes.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@./src/a68g/$(DEPDIR)/a68g-top-down.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@./src/a68g/$(DEPDIR)/a68g-torrix.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@./src/a68g/$(DEPDIR)/a68g-transput.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@./src/a68g/$(DEPDIR)/a68g-unix.Po@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@./src/a68g/$(DEPDIR)/a68g-victal.Po@am__quote@ # am--include-marker $(am__depfiles_remade): @$(MKDIR_P) $(@D) @echo '# dummy' >$@-t && $(am__mv) $@-t $@ am--depfiles: $(am__depfiles_remade) .c.o: @am__fastdepCC_TRUE@ $(AM_V_CC)depbase=`echo $@ | sed 's|[^/]*$$|$(DEPDIR)/&|;s|\.o$$||'`;\ @am__fastdepCC_TRUE@ $(COMPILE) -MT $@ -MD -MP -MF $$depbase.Tpo -c -o $@ $< &&\ @am__fastdepCC_TRUE@ $(am__mv) $$depbase.Tpo $$depbase.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='$<' object='$@' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(COMPILE) -c -o $@ $< .c.obj: @am__fastdepCC_TRUE@ $(AM_V_CC)depbase=`echo $@ | sed 's|[^/]*$$|$(DEPDIR)/&|;s|\.obj$$||'`;\ @am__fastdepCC_TRUE@ $(COMPILE) -MT $@ -MD -MP -MF $$depbase.Tpo -c -o $@ `$(CYGPATH_W) '$<'` &&\ @am__fastdepCC_TRUE@ $(am__mv) $$depbase.Tpo $$depbase.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='$<' object='$@' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(COMPILE) -c -o $@ `$(CYGPATH_W) '$<'` ./src/a68g/a68g-a68g.o: ./src/a68g/a68g.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT ./src/a68g/a68g-a68g.o -MD -MP -MF ./src/a68g/$(DEPDIR)/a68g-a68g.Tpo -c -o ./src/a68g/a68g-a68g.o `test -f './src/a68g/a68g.c' || echo '$(srcdir)/'`./src/a68g/a68g.c @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) ./src/a68g/$(DEPDIR)/a68g-a68g.Tpo ./src/a68g/$(DEPDIR)/a68g-a68g.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='./src/a68g/a68g.c' object='./src/a68g/a68g-a68g.o' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o ./src/a68g/a68g-a68g.o `test -f './src/a68g/a68g.c' || echo '$(srcdir)/'`./src/a68g/a68g.c ./src/a68g/a68g-a68g.obj: ./src/a68g/a68g.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT ./src/a68g/a68g-a68g.obj -MD -MP -MF ./src/a68g/$(DEPDIR)/a68g-a68g.Tpo -c -o ./src/a68g/a68g-a68g.obj `if test -f './src/a68g/a68g.c'; then $(CYGPATH_W) './src/a68g/a68g.c'; else $(CYGPATH_W) '$(srcdir)/./src/a68g/a68g.c'; fi` @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) ./src/a68g/$(DEPDIR)/a68g-a68g.Tpo ./src/a68g/$(DEPDIR)/a68g-a68g.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='./src/a68g/a68g.c' object='./src/a68g/a68g-a68g.obj' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o ./src/a68g/a68g-a68g.obj `if test -f './src/a68g/a68g.c'; then $(CYGPATH_W) './src/a68g/a68g.c'; else $(CYGPATH_W) '$(srcdir)/./src/a68g/a68g.c'; fi` ./src/a68g/a68g-a68glib.o: ./src/a68g/a68glib.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT ./src/a68g/a68g-a68glib.o -MD -MP -MF ./src/a68g/$(DEPDIR)/a68g-a68glib.Tpo -c -o ./src/a68g/a68g-a68glib.o `test -f './src/a68g/a68glib.c' || echo '$(srcdir)/'`./src/a68g/a68glib.c @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) ./src/a68g/$(DEPDIR)/a68g-a68glib.Tpo ./src/a68g/$(DEPDIR)/a68g-a68glib.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='./src/a68g/a68glib.c' object='./src/a68g/a68g-a68glib.o' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o ./src/a68g/a68g-a68glib.o `test -f './src/a68g/a68glib.c' || echo '$(srcdir)/'`./src/a68g/a68glib.c ./src/a68g/a68g-a68glib.obj: ./src/a68g/a68glib.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT ./src/a68g/a68g-a68glib.obj -MD -MP -MF ./src/a68g/$(DEPDIR)/a68g-a68glib.Tpo -c -o ./src/a68g/a68g-a68glib.obj `if test -f './src/a68g/a68glib.c'; then $(CYGPATH_W) './src/a68g/a68glib.c'; else $(CYGPATH_W) '$(srcdir)/./src/a68g/a68glib.c'; fi` @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) ./src/a68g/$(DEPDIR)/a68g-a68glib.Tpo ./src/a68g/$(DEPDIR)/a68g-a68glib.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='./src/a68g/a68glib.c' object='./src/a68g/a68g-a68glib.obj' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o ./src/a68g/a68g-a68glib.obj `if test -f './src/a68g/a68glib.c'; then $(CYGPATH_W) './src/a68g/a68glib.c'; else $(CYGPATH_W) '$(srcdir)/./src/a68g/a68glib.c'; fi` ./src/a68g/a68g-apropos.o: ./src/a68g/apropos.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT ./src/a68g/a68g-apropos.o -MD -MP -MF ./src/a68g/$(DEPDIR)/a68g-apropos.Tpo -c -o ./src/a68g/a68g-apropos.o `test -f './src/a68g/apropos.c' || echo '$(srcdir)/'`./src/a68g/apropos.c @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) ./src/a68g/$(DEPDIR)/a68g-apropos.Tpo ./src/a68g/$(DEPDIR)/a68g-apropos.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='./src/a68g/apropos.c' object='./src/a68g/a68g-apropos.o' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o ./src/a68g/a68g-apropos.o `test -f './src/a68g/apropos.c' || echo '$(srcdir)/'`./src/a68g/apropos.c ./src/a68g/a68g-apropos.obj: ./src/a68g/apropos.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT ./src/a68g/a68g-apropos.obj -MD -MP -MF ./src/a68g/$(DEPDIR)/a68g-apropos.Tpo -c -o ./src/a68g/a68g-apropos.obj `if test -f './src/a68g/apropos.c'; then $(CYGPATH_W) './src/a68g/apropos.c'; else $(CYGPATH_W) '$(srcdir)/./src/a68g/apropos.c'; fi` @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) ./src/a68g/$(DEPDIR)/a68g-apropos.Tpo ./src/a68g/$(DEPDIR)/a68g-apropos.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='./src/a68g/apropos.c' object='./src/a68g/a68g-apropos.obj' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o ./src/a68g/a68g-apropos.obj `if test -f './src/a68g/apropos.c'; then $(CYGPATH_W) './src/a68g/apropos.c'; else $(CYGPATH_W) '$(srcdir)/./src/a68g/apropos.c'; fi` ./src/a68g/a68g-bits.o: ./src/a68g/bits.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT ./src/a68g/a68g-bits.o -MD -MP -MF ./src/a68g/$(DEPDIR)/a68g-bits.Tpo -c -o ./src/a68g/a68g-bits.o `test -f './src/a68g/bits.c' || echo '$(srcdir)/'`./src/a68g/bits.c @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) ./src/a68g/$(DEPDIR)/a68g-bits.Tpo ./src/a68g/$(DEPDIR)/a68g-bits.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='./src/a68g/bits.c' object='./src/a68g/a68g-bits.o' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o ./src/a68g/a68g-bits.o `test -f './src/a68g/bits.c' || echo '$(srcdir)/'`./src/a68g/bits.c ./src/a68g/a68g-bits.obj: ./src/a68g/bits.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT ./src/a68g/a68g-bits.obj -MD -MP -MF ./src/a68g/$(DEPDIR)/a68g-bits.Tpo -c -o ./src/a68g/a68g-bits.obj `if test -f './src/a68g/bits.c'; then $(CYGPATH_W) './src/a68g/bits.c'; else $(CYGPATH_W) '$(srcdir)/./src/a68g/bits.c'; fi` @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) ./src/a68g/$(DEPDIR)/a68g-bits.Tpo ./src/a68g/$(DEPDIR)/a68g-bits.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='./src/a68g/bits.c' object='./src/a68g/a68g-bits.obj' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o ./src/a68g/a68g-bits.obj `if test -f './src/a68g/bits.c'; then $(CYGPATH_W) './src/a68g/bits.c'; else $(CYGPATH_W) '$(srcdir)/./src/a68g/bits.c'; fi` ./src/a68g/a68g-bool.o: ./src/a68g/bool.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT ./src/a68g/a68g-bool.o -MD -MP -MF ./src/a68g/$(DEPDIR)/a68g-bool.Tpo -c -o ./src/a68g/a68g-bool.o `test -f './src/a68g/bool.c' || echo '$(srcdir)/'`./src/a68g/bool.c @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) ./src/a68g/$(DEPDIR)/a68g-bool.Tpo ./src/a68g/$(DEPDIR)/a68g-bool.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='./src/a68g/bool.c' object='./src/a68g/a68g-bool.o' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o ./src/a68g/a68g-bool.o `test -f './src/a68g/bool.c' || echo '$(srcdir)/'`./src/a68g/bool.c ./src/a68g/a68g-bool.obj: ./src/a68g/bool.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT ./src/a68g/a68g-bool.obj -MD -MP -MF ./src/a68g/$(DEPDIR)/a68g-bool.Tpo -c -o ./src/a68g/a68g-bool.obj `if test -f './src/a68g/bool.c'; then $(CYGPATH_W) './src/a68g/bool.c'; else $(CYGPATH_W) '$(srcdir)/./src/a68g/bool.c'; fi` @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) ./src/a68g/$(DEPDIR)/a68g-bool.Tpo ./src/a68g/$(DEPDIR)/a68g-bool.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='./src/a68g/bool.c' object='./src/a68g/a68g-bool.obj' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o ./src/a68g/a68g-bool.obj `if test -f './src/a68g/bool.c'; then $(CYGPATH_W) './src/a68g/bool.c'; else $(CYGPATH_W) '$(srcdir)/./src/a68g/bool.c'; fi` ./src/a68g/a68g-bottom-up.o: ./src/a68g/bottom-up.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT ./src/a68g/a68g-bottom-up.o -MD -MP -MF ./src/a68g/$(DEPDIR)/a68g-bottom-up.Tpo -c -o ./src/a68g/a68g-bottom-up.o `test -f './src/a68g/bottom-up.c' || echo '$(srcdir)/'`./src/a68g/bottom-up.c @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) ./src/a68g/$(DEPDIR)/a68g-bottom-up.Tpo ./src/a68g/$(DEPDIR)/a68g-bottom-up.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='./src/a68g/bottom-up.c' object='./src/a68g/a68g-bottom-up.o' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o ./src/a68g/a68g-bottom-up.o `test -f './src/a68g/bottom-up.c' || echo '$(srcdir)/'`./src/a68g/bottom-up.c ./src/a68g/a68g-bottom-up.obj: ./src/a68g/bottom-up.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT ./src/a68g/a68g-bottom-up.obj -MD -MP -MF ./src/a68g/$(DEPDIR)/a68g-bottom-up.Tpo -c -o ./src/a68g/a68g-bottom-up.obj `if test -f './src/a68g/bottom-up.c'; then $(CYGPATH_W) './src/a68g/bottom-up.c'; else $(CYGPATH_W) '$(srcdir)/./src/a68g/bottom-up.c'; fi` @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) ./src/a68g/$(DEPDIR)/a68g-bottom-up.Tpo ./src/a68g/$(DEPDIR)/a68g-bottom-up.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='./src/a68g/bottom-up.c' object='./src/a68g/a68g-bottom-up.obj' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o ./src/a68g/a68g-bottom-up.obj `if test -f './src/a68g/bottom-up.c'; then $(CYGPATH_W) './src/a68g/bottom-up.c'; else $(CYGPATH_W) '$(srcdir)/./src/a68g/bottom-up.c'; fi` ./src/a68g/a68g-brackets.o: ./src/a68g/brackets.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT ./src/a68g/a68g-brackets.o -MD -MP -MF ./src/a68g/$(DEPDIR)/a68g-brackets.Tpo -c -o ./src/a68g/a68g-brackets.o `test -f './src/a68g/brackets.c' || echo '$(srcdir)/'`./src/a68g/brackets.c @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) ./src/a68g/$(DEPDIR)/a68g-brackets.Tpo ./src/a68g/$(DEPDIR)/a68g-brackets.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='./src/a68g/brackets.c' object='./src/a68g/a68g-brackets.o' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o ./src/a68g/a68g-brackets.o `test -f './src/a68g/brackets.c' || echo '$(srcdir)/'`./src/a68g/brackets.c ./src/a68g/a68g-brackets.obj: ./src/a68g/brackets.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT ./src/a68g/a68g-brackets.obj -MD -MP -MF ./src/a68g/$(DEPDIR)/a68g-brackets.Tpo -c -o ./src/a68g/a68g-brackets.obj `if test -f './src/a68g/brackets.c'; then $(CYGPATH_W) './src/a68g/brackets.c'; else $(CYGPATH_W) '$(srcdir)/./src/a68g/brackets.c'; fi` @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) ./src/a68g/$(DEPDIR)/a68g-brackets.Tpo ./src/a68g/$(DEPDIR)/a68g-brackets.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='./src/a68g/brackets.c' object='./src/a68g/a68g-brackets.obj' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o ./src/a68g/a68g-brackets.obj `if test -f './src/a68g/brackets.c'; then $(CYGPATH_W) './src/a68g/brackets.c'; else $(CYGPATH_W) '$(srcdir)/./src/a68g/brackets.c'; fi` ./src/a68g/a68g-char.o: ./src/a68g/char.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT ./src/a68g/a68g-char.o -MD -MP -MF ./src/a68g/$(DEPDIR)/a68g-char.Tpo -c -o ./src/a68g/a68g-char.o `test -f './src/a68g/char.c' || echo '$(srcdir)/'`./src/a68g/char.c @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) ./src/a68g/$(DEPDIR)/a68g-char.Tpo ./src/a68g/$(DEPDIR)/a68g-char.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='./src/a68g/char.c' object='./src/a68g/a68g-char.o' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o ./src/a68g/a68g-char.o `test -f './src/a68g/char.c' || echo '$(srcdir)/'`./src/a68g/char.c ./src/a68g/a68g-char.obj: ./src/a68g/char.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT ./src/a68g/a68g-char.obj -MD -MP -MF ./src/a68g/$(DEPDIR)/a68g-char.Tpo -c -o ./src/a68g/a68g-char.obj `if test -f './src/a68g/char.c'; then $(CYGPATH_W) './src/a68g/char.c'; else $(CYGPATH_W) '$(srcdir)/./src/a68g/char.c'; fi` @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) ./src/a68g/$(DEPDIR)/a68g-char.Tpo ./src/a68g/$(DEPDIR)/a68g-char.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='./src/a68g/char.c' object='./src/a68g/a68g-char.obj' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o ./src/a68g/a68g-char.obj `if test -f './src/a68g/char.c'; then $(CYGPATH_W) './src/a68g/char.c'; else $(CYGPATH_W) '$(srcdir)/./src/a68g/char.c'; fi` ./src/a68g/a68g-compiler-basic.o: ./src/a68g/compiler-basic.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT ./src/a68g/a68g-compiler-basic.o -MD -MP -MF ./src/a68g/$(DEPDIR)/a68g-compiler-basic.Tpo -c -o ./src/a68g/a68g-compiler-basic.o `test -f './src/a68g/compiler-basic.c' || echo '$(srcdir)/'`./src/a68g/compiler-basic.c @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) ./src/a68g/$(DEPDIR)/a68g-compiler-basic.Tpo ./src/a68g/$(DEPDIR)/a68g-compiler-basic.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='./src/a68g/compiler-basic.c' object='./src/a68g/a68g-compiler-basic.o' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o ./src/a68g/a68g-compiler-basic.o `test -f './src/a68g/compiler-basic.c' || echo '$(srcdir)/'`./src/a68g/compiler-basic.c ./src/a68g/a68g-compiler-basic.obj: ./src/a68g/compiler-basic.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT ./src/a68g/a68g-compiler-basic.obj -MD -MP -MF ./src/a68g/$(DEPDIR)/a68g-compiler-basic.Tpo -c -o ./src/a68g/a68g-compiler-basic.obj `if test -f './src/a68g/compiler-basic.c'; then $(CYGPATH_W) './src/a68g/compiler-basic.c'; else $(CYGPATH_W) '$(srcdir)/./src/a68g/compiler-basic.c'; fi` @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) ./src/a68g/$(DEPDIR)/a68g-compiler-basic.Tpo ./src/a68g/$(DEPDIR)/a68g-compiler-basic.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='./src/a68g/compiler-basic.c' object='./src/a68g/a68g-compiler-basic.obj' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o ./src/a68g/a68g-compiler-basic.obj `if test -f './src/a68g/compiler-basic.c'; then $(CYGPATH_W) './src/a68g/compiler-basic.c'; else $(CYGPATH_W) '$(srcdir)/./src/a68g/compiler-basic.c'; fi` ./src/a68g/a68g-compiler.o: ./src/a68g/compiler.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT ./src/a68g/a68g-compiler.o -MD -MP -MF ./src/a68g/$(DEPDIR)/a68g-compiler.Tpo -c -o ./src/a68g/a68g-compiler.o `test -f './src/a68g/compiler.c' || echo '$(srcdir)/'`./src/a68g/compiler.c @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) ./src/a68g/$(DEPDIR)/a68g-compiler.Tpo ./src/a68g/$(DEPDIR)/a68g-compiler.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='./src/a68g/compiler.c' object='./src/a68g/a68g-compiler.o' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o ./src/a68g/a68g-compiler.o `test -f './src/a68g/compiler.c' || echo '$(srcdir)/'`./src/a68g/compiler.c ./src/a68g/a68g-compiler.obj: ./src/a68g/compiler.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT ./src/a68g/a68g-compiler.obj -MD -MP -MF ./src/a68g/$(DEPDIR)/a68g-compiler.Tpo -c -o ./src/a68g/a68g-compiler.obj `if test -f './src/a68g/compiler.c'; then $(CYGPATH_W) './src/a68g/compiler.c'; else $(CYGPATH_W) '$(srcdir)/./src/a68g/compiler.c'; fi` @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) ./src/a68g/$(DEPDIR)/a68g-compiler.Tpo ./src/a68g/$(DEPDIR)/a68g-compiler.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='./src/a68g/compiler.c' object='./src/a68g/a68g-compiler.obj' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o ./src/a68g/a68g-compiler.obj `if test -f './src/a68g/compiler.c'; then $(CYGPATH_W) './src/a68g/compiler.c'; else $(CYGPATH_W) '$(srcdir)/./src/a68g/compiler.c'; fi` ./src/a68g/a68g-compiler-folder.o: ./src/a68g/compiler-folder.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT ./src/a68g/a68g-compiler-folder.o -MD -MP -MF ./src/a68g/$(DEPDIR)/a68g-compiler-folder.Tpo -c -o ./src/a68g/a68g-compiler-folder.o `test -f './src/a68g/compiler-folder.c' || echo '$(srcdir)/'`./src/a68g/compiler-folder.c @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) ./src/a68g/$(DEPDIR)/a68g-compiler-folder.Tpo ./src/a68g/$(DEPDIR)/a68g-compiler-folder.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='./src/a68g/compiler-folder.c' object='./src/a68g/a68g-compiler-folder.o' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o ./src/a68g/a68g-compiler-folder.o `test -f './src/a68g/compiler-folder.c' || echo '$(srcdir)/'`./src/a68g/compiler-folder.c ./src/a68g/a68g-compiler-folder.obj: ./src/a68g/compiler-folder.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT ./src/a68g/a68g-compiler-folder.obj -MD -MP -MF ./src/a68g/$(DEPDIR)/a68g-compiler-folder.Tpo -c -o ./src/a68g/a68g-compiler-folder.obj `if test -f './src/a68g/compiler-folder.c'; then $(CYGPATH_W) './src/a68g/compiler-folder.c'; else $(CYGPATH_W) '$(srcdir)/./src/a68g/compiler-folder.c'; fi` @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) ./src/a68g/$(DEPDIR)/a68g-compiler-folder.Tpo ./src/a68g/$(DEPDIR)/a68g-compiler-folder.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='./src/a68g/compiler-folder.c' object='./src/a68g/a68g-compiler-folder.obj' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o ./src/a68g/a68g-compiler-folder.obj `if test -f './src/a68g/compiler-folder.c'; then $(CYGPATH_W) './src/a68g/compiler-folder.c'; else $(CYGPATH_W) '$(srcdir)/./src/a68g/compiler-folder.c'; fi` ./src/a68g/a68g-compiler-gen.o: ./src/a68g/compiler-gen.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT ./src/a68g/a68g-compiler-gen.o -MD -MP -MF ./src/a68g/$(DEPDIR)/a68g-compiler-gen.Tpo -c -o ./src/a68g/a68g-compiler-gen.o `test -f './src/a68g/compiler-gen.c' || echo '$(srcdir)/'`./src/a68g/compiler-gen.c @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) ./src/a68g/$(DEPDIR)/a68g-compiler-gen.Tpo ./src/a68g/$(DEPDIR)/a68g-compiler-gen.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='./src/a68g/compiler-gen.c' object='./src/a68g/a68g-compiler-gen.o' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o ./src/a68g/a68g-compiler-gen.o `test -f './src/a68g/compiler-gen.c' || echo '$(srcdir)/'`./src/a68g/compiler-gen.c ./src/a68g/a68g-compiler-gen.obj: ./src/a68g/compiler-gen.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT ./src/a68g/a68g-compiler-gen.obj -MD -MP -MF ./src/a68g/$(DEPDIR)/a68g-compiler-gen.Tpo -c -o ./src/a68g/a68g-compiler-gen.obj `if test -f './src/a68g/compiler-gen.c'; then $(CYGPATH_W) './src/a68g/compiler-gen.c'; else $(CYGPATH_W) '$(srcdir)/./src/a68g/compiler-gen.c'; fi` @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) ./src/a68g/$(DEPDIR)/a68g-compiler-gen.Tpo ./src/a68g/$(DEPDIR)/a68g-compiler-gen.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='./src/a68g/compiler-gen.c' object='./src/a68g/a68g-compiler-gen.obj' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o ./src/a68g/a68g-compiler-gen.obj `if test -f './src/a68g/compiler-gen.c'; then $(CYGPATH_W) './src/a68g/compiler-gen.c'; else $(CYGPATH_W) '$(srcdir)/./src/a68g/compiler-gen.c'; fi` ./src/a68g/a68g-compiler-inline.o: ./src/a68g/compiler-inline.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT ./src/a68g/a68g-compiler-inline.o -MD -MP -MF ./src/a68g/$(DEPDIR)/a68g-compiler-inline.Tpo -c -o ./src/a68g/a68g-compiler-inline.o `test -f './src/a68g/compiler-inline.c' || echo '$(srcdir)/'`./src/a68g/compiler-inline.c @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) ./src/a68g/$(DEPDIR)/a68g-compiler-inline.Tpo ./src/a68g/$(DEPDIR)/a68g-compiler-inline.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='./src/a68g/compiler-inline.c' object='./src/a68g/a68g-compiler-inline.o' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o ./src/a68g/a68g-compiler-inline.o `test -f './src/a68g/compiler-inline.c' || echo '$(srcdir)/'`./src/a68g/compiler-inline.c ./src/a68g/a68g-compiler-inline.obj: ./src/a68g/compiler-inline.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT ./src/a68g/a68g-compiler-inline.obj -MD -MP -MF ./src/a68g/$(DEPDIR)/a68g-compiler-inline.Tpo -c -o ./src/a68g/a68g-compiler-inline.obj `if test -f './src/a68g/compiler-inline.c'; then $(CYGPATH_W) './src/a68g/compiler-inline.c'; else $(CYGPATH_W) '$(srcdir)/./src/a68g/compiler-inline.c'; fi` @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) ./src/a68g/$(DEPDIR)/a68g-compiler-inline.Tpo ./src/a68g/$(DEPDIR)/a68g-compiler-inline.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='./src/a68g/compiler-inline.c' object='./src/a68g/a68g-compiler-inline.obj' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o ./src/a68g/a68g-compiler-inline.obj `if test -f './src/a68g/compiler-inline.c'; then $(CYGPATH_W) './src/a68g/compiler-inline.c'; else $(CYGPATH_W) '$(srcdir)/./src/a68g/compiler-inline.c'; fi` ./src/a68g/a68g-compiler-tables.o: ./src/a68g/compiler-tables.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT ./src/a68g/a68g-compiler-tables.o -MD -MP -MF ./src/a68g/$(DEPDIR)/a68g-compiler-tables.Tpo -c -o ./src/a68g/a68g-compiler-tables.o `test -f './src/a68g/compiler-tables.c' || echo '$(srcdir)/'`./src/a68g/compiler-tables.c @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) ./src/a68g/$(DEPDIR)/a68g-compiler-tables.Tpo ./src/a68g/$(DEPDIR)/a68g-compiler-tables.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='./src/a68g/compiler-tables.c' object='./src/a68g/a68g-compiler-tables.o' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o ./src/a68g/a68g-compiler-tables.o `test -f './src/a68g/compiler-tables.c' || echo '$(srcdir)/'`./src/a68g/compiler-tables.c ./src/a68g/a68g-compiler-tables.obj: ./src/a68g/compiler-tables.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT ./src/a68g/a68g-compiler-tables.obj -MD -MP -MF ./src/a68g/$(DEPDIR)/a68g-compiler-tables.Tpo -c -o ./src/a68g/a68g-compiler-tables.obj `if test -f './src/a68g/compiler-tables.c'; then $(CYGPATH_W) './src/a68g/compiler-tables.c'; else $(CYGPATH_W) '$(srcdir)/./src/a68g/compiler-tables.c'; fi` @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) ./src/a68g/$(DEPDIR)/a68g-compiler-tables.Tpo ./src/a68g/$(DEPDIR)/a68g-compiler-tables.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='./src/a68g/compiler-tables.c' object='./src/a68g/a68g-compiler-tables.obj' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o ./src/a68g/a68g-compiler-tables.obj `if test -f './src/a68g/compiler-tables.c'; then $(CYGPATH_W) './src/a68g/compiler-tables.c'; else $(CYGPATH_W) '$(srcdir)/./src/a68g/compiler-tables.c'; fi` ./src/a68g/a68g-conversion.o: ./src/a68g/conversion.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT ./src/a68g/a68g-conversion.o -MD -MP -MF ./src/a68g/$(DEPDIR)/a68g-conversion.Tpo -c -o ./src/a68g/a68g-conversion.o `test -f './src/a68g/conversion.c' || echo '$(srcdir)/'`./src/a68g/conversion.c @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) ./src/a68g/$(DEPDIR)/a68g-conversion.Tpo ./src/a68g/$(DEPDIR)/a68g-conversion.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='./src/a68g/conversion.c' object='./src/a68g/a68g-conversion.o' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o ./src/a68g/a68g-conversion.o `test -f './src/a68g/conversion.c' || echo '$(srcdir)/'`./src/a68g/conversion.c ./src/a68g/a68g-conversion.obj: ./src/a68g/conversion.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT ./src/a68g/a68g-conversion.obj -MD -MP -MF ./src/a68g/$(DEPDIR)/a68g-conversion.Tpo -c -o ./src/a68g/a68g-conversion.obj `if test -f './src/a68g/conversion.c'; then $(CYGPATH_W) './src/a68g/conversion.c'; else $(CYGPATH_W) '$(srcdir)/./src/a68g/conversion.c'; fi` @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) ./src/a68g/$(DEPDIR)/a68g-conversion.Tpo ./src/a68g/$(DEPDIR)/a68g-conversion.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='./src/a68g/conversion.c' object='./src/a68g/a68g-conversion.obj' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o ./src/a68g/a68g-conversion.obj `if test -f './src/a68g/conversion.c'; then $(CYGPATH_W) './src/a68g/conversion.c'; else $(CYGPATH_W) '$(srcdir)/./src/a68g/conversion.c'; fi` ./src/a68g/a68g-curses.o: ./src/a68g/curses.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT ./src/a68g/a68g-curses.o -MD -MP -MF ./src/a68g/$(DEPDIR)/a68g-curses.Tpo -c -o ./src/a68g/a68g-curses.o `test -f './src/a68g/curses.c' || echo '$(srcdir)/'`./src/a68g/curses.c @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) ./src/a68g/$(DEPDIR)/a68g-curses.Tpo ./src/a68g/$(DEPDIR)/a68g-curses.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='./src/a68g/curses.c' object='./src/a68g/a68g-curses.o' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o ./src/a68g/a68g-curses.o `test -f './src/a68g/curses.c' || echo '$(srcdir)/'`./src/a68g/curses.c ./src/a68g/a68g-curses.obj: ./src/a68g/curses.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT ./src/a68g/a68g-curses.obj -MD -MP -MF ./src/a68g/$(DEPDIR)/a68g-curses.Tpo -c -o ./src/a68g/a68g-curses.obj `if test -f './src/a68g/curses.c'; then $(CYGPATH_W) './src/a68g/curses.c'; else $(CYGPATH_W) '$(srcdir)/./src/a68g/curses.c'; fi` @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) ./src/a68g/$(DEPDIR)/a68g-curses.Tpo ./src/a68g/$(DEPDIR)/a68g-curses.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='./src/a68g/curses.c' object='./src/a68g/a68g-curses.obj' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o ./src/a68g/a68g-curses.obj `if test -f './src/a68g/curses.c'; then $(CYGPATH_W) './src/a68g/curses.c'; else $(CYGPATH_W) '$(srcdir)/./src/a68g/curses.c'; fi` ./src/a68g/a68g-diagnostics.o: ./src/a68g/diagnostics.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT ./src/a68g/a68g-diagnostics.o -MD -MP -MF ./src/a68g/$(DEPDIR)/a68g-diagnostics.Tpo -c -o ./src/a68g/a68g-diagnostics.o `test -f './src/a68g/diagnostics.c' || echo '$(srcdir)/'`./src/a68g/diagnostics.c @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) ./src/a68g/$(DEPDIR)/a68g-diagnostics.Tpo ./src/a68g/$(DEPDIR)/a68g-diagnostics.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='./src/a68g/diagnostics.c' object='./src/a68g/a68g-diagnostics.o' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o ./src/a68g/a68g-diagnostics.o `test -f './src/a68g/diagnostics.c' || echo '$(srcdir)/'`./src/a68g/diagnostics.c ./src/a68g/a68g-diagnostics.obj: ./src/a68g/diagnostics.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT ./src/a68g/a68g-diagnostics.obj -MD -MP -MF ./src/a68g/$(DEPDIR)/a68g-diagnostics.Tpo -c -o ./src/a68g/a68g-diagnostics.obj `if test -f './src/a68g/diagnostics.c'; then $(CYGPATH_W) './src/a68g/diagnostics.c'; else $(CYGPATH_W) '$(srcdir)/./src/a68g/diagnostics.c'; fi` @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) ./src/a68g/$(DEPDIR)/a68g-diagnostics.Tpo ./src/a68g/$(DEPDIR)/a68g-diagnostics.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='./src/a68g/diagnostics.c' object='./src/a68g/a68g-diagnostics.obj' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o ./src/a68g/a68g-diagnostics.obj `if test -f './src/a68g/diagnostics.c'; then $(CYGPATH_W) './src/a68g/diagnostics.c'; else $(CYGPATH_W) '$(srcdir)/./src/a68g/diagnostics.c'; fi` ./src/a68g/a68g-double.o: ./src/a68g/double.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT ./src/a68g/a68g-double.o -MD -MP -MF ./src/a68g/$(DEPDIR)/a68g-double.Tpo -c -o ./src/a68g/a68g-double.o `test -f './src/a68g/double.c' || echo '$(srcdir)/'`./src/a68g/double.c @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) ./src/a68g/$(DEPDIR)/a68g-double.Tpo ./src/a68g/$(DEPDIR)/a68g-double.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='./src/a68g/double.c' object='./src/a68g/a68g-double.o' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o ./src/a68g/a68g-double.o `test -f './src/a68g/double.c' || echo '$(srcdir)/'`./src/a68g/double.c ./src/a68g/a68g-double.obj: ./src/a68g/double.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT ./src/a68g/a68g-double.obj -MD -MP -MF ./src/a68g/$(DEPDIR)/a68g-double.Tpo -c -o ./src/a68g/a68g-double.obj `if test -f './src/a68g/double.c'; then $(CYGPATH_W) './src/a68g/double.c'; else $(CYGPATH_W) '$(srcdir)/./src/a68g/double.c'; fi` @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) ./src/a68g/$(DEPDIR)/a68g-double.Tpo ./src/a68g/$(DEPDIR)/a68g-double.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='./src/a68g/double.c' object='./src/a68g/a68g-double.obj' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o ./src/a68g/a68g-double.obj `if test -f './src/a68g/double.c'; then $(CYGPATH_W) './src/a68g/double.c'; else $(CYGPATH_W) '$(srcdir)/./src/a68g/double.c'; fi` ./src/a68g/a68g-double-gamic.o: ./src/a68g/double-gamic.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT ./src/a68g/a68g-double-gamic.o -MD -MP -MF ./src/a68g/$(DEPDIR)/a68g-double-gamic.Tpo -c -o ./src/a68g/a68g-double-gamic.o `test -f './src/a68g/double-gamic.c' || echo '$(srcdir)/'`./src/a68g/double-gamic.c @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) ./src/a68g/$(DEPDIR)/a68g-double-gamic.Tpo ./src/a68g/$(DEPDIR)/a68g-double-gamic.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='./src/a68g/double-gamic.c' object='./src/a68g/a68g-double-gamic.o' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o ./src/a68g/a68g-double-gamic.o `test -f './src/a68g/double-gamic.c' || echo '$(srcdir)/'`./src/a68g/double-gamic.c ./src/a68g/a68g-double-gamic.obj: ./src/a68g/double-gamic.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT ./src/a68g/a68g-double-gamic.obj -MD -MP -MF ./src/a68g/$(DEPDIR)/a68g-double-gamic.Tpo -c -o ./src/a68g/a68g-double-gamic.obj `if test -f './src/a68g/double-gamic.c'; then $(CYGPATH_W) './src/a68g/double-gamic.c'; else $(CYGPATH_W) '$(srcdir)/./src/a68g/double-gamic.c'; fi` @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) ./src/a68g/$(DEPDIR)/a68g-double-gamic.Tpo ./src/a68g/$(DEPDIR)/a68g-double-gamic.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='./src/a68g/double-gamic.c' object='./src/a68g/a68g-double-gamic.obj' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o ./src/a68g/a68g-double-gamic.obj `if test -f './src/a68g/double-gamic.c'; then $(CYGPATH_W) './src/a68g/double-gamic.c'; else $(CYGPATH_W) '$(srcdir)/./src/a68g/double-gamic.c'; fi` ./src/a68g/a68g-double-math.o: ./src/a68g/double-math.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT ./src/a68g/a68g-double-math.o -MD -MP -MF ./src/a68g/$(DEPDIR)/a68g-double-math.Tpo -c -o ./src/a68g/a68g-double-math.o `test -f './src/a68g/double-math.c' || echo '$(srcdir)/'`./src/a68g/double-math.c @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) ./src/a68g/$(DEPDIR)/a68g-double-math.Tpo ./src/a68g/$(DEPDIR)/a68g-double-math.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='./src/a68g/double-math.c' object='./src/a68g/a68g-double-math.o' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o ./src/a68g/a68g-double-math.o `test -f './src/a68g/double-math.c' || echo '$(srcdir)/'`./src/a68g/double-math.c ./src/a68g/a68g-double-math.obj: ./src/a68g/double-math.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT ./src/a68g/a68g-double-math.obj -MD -MP -MF ./src/a68g/$(DEPDIR)/a68g-double-math.Tpo -c -o ./src/a68g/a68g-double-math.obj `if test -f './src/a68g/double-math.c'; then $(CYGPATH_W) './src/a68g/double-math.c'; else $(CYGPATH_W) '$(srcdir)/./src/a68g/double-math.c'; fi` @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) ./src/a68g/$(DEPDIR)/a68g-double-math.Tpo ./src/a68g/$(DEPDIR)/a68g-double-math.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='./src/a68g/double-math.c' object='./src/a68g/a68g-double-math.obj' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o ./src/a68g/a68g-double-math.obj `if test -f './src/a68g/double-math.c'; then $(CYGPATH_W) './src/a68g/double-math.c'; else $(CYGPATH_W) '$(srcdir)/./src/a68g/double-math.c'; fi` ./src/a68g/a68g-enquiries.o: ./src/a68g/enquiries.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT ./src/a68g/a68g-enquiries.o -MD -MP -MF ./src/a68g/$(DEPDIR)/a68g-enquiries.Tpo -c -o ./src/a68g/a68g-enquiries.o `test -f './src/a68g/enquiries.c' || echo '$(srcdir)/'`./src/a68g/enquiries.c @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) ./src/a68g/$(DEPDIR)/a68g-enquiries.Tpo ./src/a68g/$(DEPDIR)/a68g-enquiries.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='./src/a68g/enquiries.c' object='./src/a68g/a68g-enquiries.o' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o ./src/a68g/a68g-enquiries.o `test -f './src/a68g/enquiries.c' || echo '$(srcdir)/'`./src/a68g/enquiries.c ./src/a68g/a68g-enquiries.obj: ./src/a68g/enquiries.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT ./src/a68g/a68g-enquiries.obj -MD -MP -MF ./src/a68g/$(DEPDIR)/a68g-enquiries.Tpo -c -o ./src/a68g/a68g-enquiries.obj `if test -f './src/a68g/enquiries.c'; then $(CYGPATH_W) './src/a68g/enquiries.c'; else $(CYGPATH_W) '$(srcdir)/./src/a68g/enquiries.c'; fi` @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) ./src/a68g/$(DEPDIR)/a68g-enquiries.Tpo ./src/a68g/$(DEPDIR)/a68g-enquiries.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='./src/a68g/enquiries.c' object='./src/a68g/a68g-enquiries.obj' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o ./src/a68g/a68g-enquiries.obj `if test -f './src/a68g/enquiries.c'; then $(CYGPATH_W) './src/a68g/enquiries.c'; else $(CYGPATH_W) '$(srcdir)/./src/a68g/enquiries.c'; fi` ./src/a68g/a68g-environ.o: ./src/a68g/environ.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT ./src/a68g/a68g-environ.o -MD -MP -MF ./src/a68g/$(DEPDIR)/a68g-environ.Tpo -c -o ./src/a68g/a68g-environ.o `test -f './src/a68g/environ.c' || echo '$(srcdir)/'`./src/a68g/environ.c @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) ./src/a68g/$(DEPDIR)/a68g-environ.Tpo ./src/a68g/$(DEPDIR)/a68g-environ.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='./src/a68g/environ.c' object='./src/a68g/a68g-environ.o' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o ./src/a68g/a68g-environ.o `test -f './src/a68g/environ.c' || echo '$(srcdir)/'`./src/a68g/environ.c ./src/a68g/a68g-environ.obj: ./src/a68g/environ.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT ./src/a68g/a68g-environ.obj -MD -MP -MF ./src/a68g/$(DEPDIR)/a68g-environ.Tpo -c -o ./src/a68g/a68g-environ.obj `if test -f './src/a68g/environ.c'; then $(CYGPATH_W) './src/a68g/environ.c'; else $(CYGPATH_W) '$(srcdir)/./src/a68g/environ.c'; fi` @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) ./src/a68g/$(DEPDIR)/a68g-environ.Tpo ./src/a68g/$(DEPDIR)/a68g-environ.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='./src/a68g/environ.c' object='./src/a68g/a68g-environ.obj' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o ./src/a68g/a68g-environ.obj `if test -f './src/a68g/environ.c'; then $(CYGPATH_W) './src/a68g/environ.c'; else $(CYGPATH_W) '$(srcdir)/./src/a68g/environ.c'; fi` ./src/a68g/a68g-equivalence.o: ./src/a68g/equivalence.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT ./src/a68g/a68g-equivalence.o -MD -MP -MF ./src/a68g/$(DEPDIR)/a68g-equivalence.Tpo -c -o ./src/a68g/a68g-equivalence.o `test -f './src/a68g/equivalence.c' || echo '$(srcdir)/'`./src/a68g/equivalence.c @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) ./src/a68g/$(DEPDIR)/a68g-equivalence.Tpo ./src/a68g/$(DEPDIR)/a68g-equivalence.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='./src/a68g/equivalence.c' object='./src/a68g/a68g-equivalence.o' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o ./src/a68g/a68g-equivalence.o `test -f './src/a68g/equivalence.c' || echo '$(srcdir)/'`./src/a68g/equivalence.c ./src/a68g/a68g-equivalence.obj: ./src/a68g/equivalence.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT ./src/a68g/a68g-equivalence.obj -MD -MP -MF ./src/a68g/$(DEPDIR)/a68g-equivalence.Tpo -c -o ./src/a68g/a68g-equivalence.obj `if test -f './src/a68g/equivalence.c'; then $(CYGPATH_W) './src/a68g/equivalence.c'; else $(CYGPATH_W) '$(srcdir)/./src/a68g/equivalence.c'; fi` @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) ./src/a68g/$(DEPDIR)/a68g-equivalence.Tpo ./src/a68g/$(DEPDIR)/a68g-equivalence.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='./src/a68g/equivalence.c' object='./src/a68g/a68g-equivalence.obj' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o ./src/a68g/a68g-equivalence.obj `if test -f './src/a68g/equivalence.c'; then $(CYGPATH_W) './src/a68g/equivalence.c'; else $(CYGPATH_W) '$(srcdir)/./src/a68g/equivalence.c'; fi` ./src/a68g/a68g-extract.o: ./src/a68g/extract.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT ./src/a68g/a68g-extract.o -MD -MP -MF ./src/a68g/$(DEPDIR)/a68g-extract.Tpo -c -o ./src/a68g/a68g-extract.o `test -f './src/a68g/extract.c' || echo '$(srcdir)/'`./src/a68g/extract.c @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) ./src/a68g/$(DEPDIR)/a68g-extract.Tpo ./src/a68g/$(DEPDIR)/a68g-extract.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='./src/a68g/extract.c' object='./src/a68g/a68g-extract.o' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o ./src/a68g/a68g-extract.o `test -f './src/a68g/extract.c' || echo '$(srcdir)/'`./src/a68g/extract.c ./src/a68g/a68g-extract.obj: ./src/a68g/extract.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT ./src/a68g/a68g-extract.obj -MD -MP -MF ./src/a68g/$(DEPDIR)/a68g-extract.Tpo -c -o ./src/a68g/a68g-extract.obj `if test -f './src/a68g/extract.c'; then $(CYGPATH_W) './src/a68g/extract.c'; else $(CYGPATH_W) '$(srcdir)/./src/a68g/extract.c'; fi` @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) ./src/a68g/$(DEPDIR)/a68g-extract.Tpo ./src/a68g/$(DEPDIR)/a68g-extract.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='./src/a68g/extract.c' object='./src/a68g/a68g-extract.obj' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o ./src/a68g/a68g-extract.obj `if test -f './src/a68g/extract.c'; then $(CYGPATH_W) './src/a68g/extract.c'; else $(CYGPATH_W) '$(srcdir)/./src/a68g/extract.c'; fi` ./src/a68g/a68g-fft.o: ./src/a68g/fft.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT ./src/a68g/a68g-fft.o -MD -MP -MF ./src/a68g/$(DEPDIR)/a68g-fft.Tpo -c -o ./src/a68g/a68g-fft.o `test -f './src/a68g/fft.c' || echo '$(srcdir)/'`./src/a68g/fft.c @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) ./src/a68g/$(DEPDIR)/a68g-fft.Tpo ./src/a68g/$(DEPDIR)/a68g-fft.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='./src/a68g/fft.c' object='./src/a68g/a68g-fft.o' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o ./src/a68g/a68g-fft.o `test -f './src/a68g/fft.c' || echo '$(srcdir)/'`./src/a68g/fft.c ./src/a68g/a68g-fft.obj: ./src/a68g/fft.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT ./src/a68g/a68g-fft.obj -MD -MP -MF ./src/a68g/$(DEPDIR)/a68g-fft.Tpo -c -o ./src/a68g/a68g-fft.obj `if test -f './src/a68g/fft.c'; then $(CYGPATH_W) './src/a68g/fft.c'; else $(CYGPATH_W) '$(srcdir)/./src/a68g/fft.c'; fi` @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) ./src/a68g/$(DEPDIR)/a68g-fft.Tpo ./src/a68g/$(DEPDIR)/a68g-fft.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='./src/a68g/fft.c' object='./src/a68g/a68g-fft.obj' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o ./src/a68g/a68g-fft.obj `if test -f './src/a68g/fft.c'; then $(CYGPATH_W) './src/a68g/fft.c'; else $(CYGPATH_W) '$(srcdir)/./src/a68g/fft.c'; fi` ./src/a68g/a68g-format.o: ./src/a68g/format.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT ./src/a68g/a68g-format.o -MD -MP -MF ./src/a68g/$(DEPDIR)/a68g-format.Tpo -c -o ./src/a68g/a68g-format.o `test -f './src/a68g/format.c' || echo '$(srcdir)/'`./src/a68g/format.c @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) ./src/a68g/$(DEPDIR)/a68g-format.Tpo ./src/a68g/$(DEPDIR)/a68g-format.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='./src/a68g/format.c' object='./src/a68g/a68g-format.o' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o ./src/a68g/a68g-format.o `test -f './src/a68g/format.c' || echo '$(srcdir)/'`./src/a68g/format.c ./src/a68g/a68g-format.obj: ./src/a68g/format.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT ./src/a68g/a68g-format.obj -MD -MP -MF ./src/a68g/$(DEPDIR)/a68g-format.Tpo -c -o ./src/a68g/a68g-format.obj `if test -f './src/a68g/format.c'; then $(CYGPATH_W) './src/a68g/format.c'; else $(CYGPATH_W) '$(srcdir)/./src/a68g/format.c'; fi` @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) ./src/a68g/$(DEPDIR)/a68g-format.Tpo ./src/a68g/$(DEPDIR)/a68g-format.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='./src/a68g/format.c' object='./src/a68g/a68g-format.obj' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o ./src/a68g/a68g-format.obj `if test -f './src/a68g/format.c'; then $(CYGPATH_W) './src/a68g/format.c'; else $(CYGPATH_W) '$(srcdir)/./src/a68g/format.c'; fi` ./src/a68g/a68g-genie.o: ./src/a68g/genie.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT ./src/a68g/a68g-genie.o -MD -MP -MF ./src/a68g/$(DEPDIR)/a68g-genie.Tpo -c -o ./src/a68g/a68g-genie.o `test -f './src/a68g/genie.c' || echo '$(srcdir)/'`./src/a68g/genie.c @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) ./src/a68g/$(DEPDIR)/a68g-genie.Tpo ./src/a68g/$(DEPDIR)/a68g-genie.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='./src/a68g/genie.c' object='./src/a68g/a68g-genie.o' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o ./src/a68g/a68g-genie.o `test -f './src/a68g/genie.c' || echo '$(srcdir)/'`./src/a68g/genie.c ./src/a68g/a68g-genie.obj: ./src/a68g/genie.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT ./src/a68g/a68g-genie.obj -MD -MP -MF ./src/a68g/$(DEPDIR)/a68g-genie.Tpo -c -o ./src/a68g/a68g-genie.obj `if test -f './src/a68g/genie.c'; then $(CYGPATH_W) './src/a68g/genie.c'; else $(CYGPATH_W) '$(srcdir)/./src/a68g/genie.c'; fi` @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) ./src/a68g/$(DEPDIR)/a68g-genie.Tpo ./src/a68g/$(DEPDIR)/a68g-genie.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='./src/a68g/genie.c' object='./src/a68g/a68g-genie.obj' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o ./src/a68g/a68g-genie.obj `if test -f './src/a68g/genie.c'; then $(CYGPATH_W) './src/a68g/genie.c'; else $(CYGPATH_W) '$(srcdir)/./src/a68g/genie.c'; fi` ./src/a68g/a68g-genie-coerce.o: ./src/a68g/genie-coerce.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT ./src/a68g/a68g-genie-coerce.o -MD -MP -MF ./src/a68g/$(DEPDIR)/a68g-genie-coerce.Tpo -c -o ./src/a68g/a68g-genie-coerce.o `test -f './src/a68g/genie-coerce.c' || echo '$(srcdir)/'`./src/a68g/genie-coerce.c @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) ./src/a68g/$(DEPDIR)/a68g-genie-coerce.Tpo ./src/a68g/$(DEPDIR)/a68g-genie-coerce.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='./src/a68g/genie-coerce.c' object='./src/a68g/a68g-genie-coerce.o' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o ./src/a68g/a68g-genie-coerce.o `test -f './src/a68g/genie-coerce.c' || echo '$(srcdir)/'`./src/a68g/genie-coerce.c ./src/a68g/a68g-genie-coerce.obj: ./src/a68g/genie-coerce.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT ./src/a68g/a68g-genie-coerce.obj -MD -MP -MF ./src/a68g/$(DEPDIR)/a68g-genie-coerce.Tpo -c -o ./src/a68g/a68g-genie-coerce.obj `if test -f './src/a68g/genie-coerce.c'; then $(CYGPATH_W) './src/a68g/genie-coerce.c'; else $(CYGPATH_W) '$(srcdir)/./src/a68g/genie-coerce.c'; fi` @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) ./src/a68g/$(DEPDIR)/a68g-genie-coerce.Tpo ./src/a68g/$(DEPDIR)/a68g-genie-coerce.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='./src/a68g/genie-coerce.c' object='./src/a68g/a68g-genie-coerce.obj' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o ./src/a68g/a68g-genie-coerce.obj `if test -f './src/a68g/genie-coerce.c'; then $(CYGPATH_W) './src/a68g/genie-coerce.c'; else $(CYGPATH_W) '$(srcdir)/./src/a68g/genie-coerce.c'; fi` ./src/a68g/a68g-genie-stowed.o: ./src/a68g/genie-stowed.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT ./src/a68g/a68g-genie-stowed.o -MD -MP -MF ./src/a68g/$(DEPDIR)/a68g-genie-stowed.Tpo -c -o ./src/a68g/a68g-genie-stowed.o `test -f './src/a68g/genie-stowed.c' || echo '$(srcdir)/'`./src/a68g/genie-stowed.c @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) ./src/a68g/$(DEPDIR)/a68g-genie-stowed.Tpo ./src/a68g/$(DEPDIR)/a68g-genie-stowed.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='./src/a68g/genie-stowed.c' object='./src/a68g/a68g-genie-stowed.o' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o ./src/a68g/a68g-genie-stowed.o `test -f './src/a68g/genie-stowed.c' || echo '$(srcdir)/'`./src/a68g/genie-stowed.c ./src/a68g/a68g-genie-stowed.obj: ./src/a68g/genie-stowed.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT ./src/a68g/a68g-genie-stowed.obj -MD -MP -MF ./src/a68g/$(DEPDIR)/a68g-genie-stowed.Tpo -c -o ./src/a68g/a68g-genie-stowed.obj `if test -f './src/a68g/genie-stowed.c'; then $(CYGPATH_W) './src/a68g/genie-stowed.c'; else $(CYGPATH_W) '$(srcdir)/./src/a68g/genie-stowed.c'; fi` @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) ./src/a68g/$(DEPDIR)/a68g-genie-stowed.Tpo ./src/a68g/$(DEPDIR)/a68g-genie-stowed.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='./src/a68g/genie-stowed.c' object='./src/a68g/a68g-genie-stowed.obj' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o ./src/a68g/a68g-genie-stowed.obj `if test -f './src/a68g/genie-stowed.c'; then $(CYGPATH_W) './src/a68g/genie-stowed.c'; else $(CYGPATH_W) '$(srcdir)/./src/a68g/genie-stowed.c'; fi` ./src/a68g/a68g-heap.o: ./src/a68g/heap.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT ./src/a68g/a68g-heap.o -MD -MP -MF ./src/a68g/$(DEPDIR)/a68g-heap.Tpo -c -o ./src/a68g/a68g-heap.o `test -f './src/a68g/heap.c' || echo '$(srcdir)/'`./src/a68g/heap.c @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) ./src/a68g/$(DEPDIR)/a68g-heap.Tpo ./src/a68g/$(DEPDIR)/a68g-heap.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='./src/a68g/heap.c' object='./src/a68g/a68g-heap.o' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o ./src/a68g/a68g-heap.o `test -f './src/a68g/heap.c' || echo '$(srcdir)/'`./src/a68g/heap.c ./src/a68g/a68g-heap.obj: ./src/a68g/heap.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT ./src/a68g/a68g-heap.obj -MD -MP -MF ./src/a68g/$(DEPDIR)/a68g-heap.Tpo -c -o ./src/a68g/a68g-heap.obj `if test -f './src/a68g/heap.c'; then $(CYGPATH_W) './src/a68g/heap.c'; else $(CYGPATH_W) '$(srcdir)/./src/a68g/heap.c'; fi` @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) ./src/a68g/$(DEPDIR)/a68g-heap.Tpo ./src/a68g/$(DEPDIR)/a68g-heap.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='./src/a68g/heap.c' object='./src/a68g/a68g-heap.obj' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o ./src/a68g/a68g-heap.obj `if test -f './src/a68g/heap.c'; then $(CYGPATH_W) './src/a68g/heap.c'; else $(CYGPATH_W) '$(srcdir)/./src/a68g/heap.c'; fi` ./src/a68g/a68g-io.o: ./src/a68g/io.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT ./src/a68g/a68g-io.o -MD -MP -MF ./src/a68g/$(DEPDIR)/a68g-io.Tpo -c -o ./src/a68g/a68g-io.o `test -f './src/a68g/io.c' || echo '$(srcdir)/'`./src/a68g/io.c @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) ./src/a68g/$(DEPDIR)/a68g-io.Tpo ./src/a68g/$(DEPDIR)/a68g-io.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='./src/a68g/io.c' object='./src/a68g/a68g-io.o' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o ./src/a68g/a68g-io.o `test -f './src/a68g/io.c' || echo '$(srcdir)/'`./src/a68g/io.c ./src/a68g/a68g-io.obj: ./src/a68g/io.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT ./src/a68g/a68g-io.obj -MD -MP -MF ./src/a68g/$(DEPDIR)/a68g-io.Tpo -c -o ./src/a68g/a68g-io.obj `if test -f './src/a68g/io.c'; then $(CYGPATH_W) './src/a68g/io.c'; else $(CYGPATH_W) '$(srcdir)/./src/a68g/io.c'; fi` @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) ./src/a68g/$(DEPDIR)/a68g-io.Tpo ./src/a68g/$(DEPDIR)/a68g-io.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='./src/a68g/io.c' object='./src/a68g/a68g-io.obj' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o ./src/a68g/a68g-io.obj `if test -f './src/a68g/io.c'; then $(CYGPATH_W) './src/a68g/io.c'; else $(CYGPATH_W) '$(srcdir)/./src/a68g/io.c'; fi` ./src/a68g/a68g-keywords.o: ./src/a68g/keywords.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT ./src/a68g/a68g-keywords.o -MD -MP -MF ./src/a68g/$(DEPDIR)/a68g-keywords.Tpo -c -o ./src/a68g/a68g-keywords.o `test -f './src/a68g/keywords.c' || echo '$(srcdir)/'`./src/a68g/keywords.c @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) ./src/a68g/$(DEPDIR)/a68g-keywords.Tpo ./src/a68g/$(DEPDIR)/a68g-keywords.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='./src/a68g/keywords.c' object='./src/a68g/a68g-keywords.o' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o ./src/a68g/a68g-keywords.o `test -f './src/a68g/keywords.c' || echo '$(srcdir)/'`./src/a68g/keywords.c ./src/a68g/a68g-keywords.obj: ./src/a68g/keywords.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT ./src/a68g/a68g-keywords.obj -MD -MP -MF ./src/a68g/$(DEPDIR)/a68g-keywords.Tpo -c -o ./src/a68g/a68g-keywords.obj `if test -f './src/a68g/keywords.c'; then $(CYGPATH_W) './src/a68g/keywords.c'; else $(CYGPATH_W) '$(srcdir)/./src/a68g/keywords.c'; fi` @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) ./src/a68g/$(DEPDIR)/a68g-keywords.Tpo ./src/a68g/$(DEPDIR)/a68g-keywords.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='./src/a68g/keywords.c' object='./src/a68g/a68g-keywords.obj' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o ./src/a68g/a68g-keywords.obj `if test -f './src/a68g/keywords.c'; then $(CYGPATH_W) './src/a68g/keywords.c'; else $(CYGPATH_W) '$(srcdir)/./src/a68g/keywords.c'; fi` ./src/a68g/a68g-laplace.o: ./src/a68g/laplace.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT ./src/a68g/a68g-laplace.o -MD -MP -MF ./src/a68g/$(DEPDIR)/a68g-laplace.Tpo -c -o ./src/a68g/a68g-laplace.o `test -f './src/a68g/laplace.c' || echo '$(srcdir)/'`./src/a68g/laplace.c @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) ./src/a68g/$(DEPDIR)/a68g-laplace.Tpo ./src/a68g/$(DEPDIR)/a68g-laplace.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='./src/a68g/laplace.c' object='./src/a68g/a68g-laplace.o' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o ./src/a68g/a68g-laplace.o `test -f './src/a68g/laplace.c' || echo '$(srcdir)/'`./src/a68g/laplace.c ./src/a68g/a68g-laplace.obj: ./src/a68g/laplace.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT ./src/a68g/a68g-laplace.obj -MD -MP -MF ./src/a68g/$(DEPDIR)/a68g-laplace.Tpo -c -o ./src/a68g/a68g-laplace.obj `if test -f './src/a68g/laplace.c'; then $(CYGPATH_W) './src/a68g/laplace.c'; else $(CYGPATH_W) '$(srcdir)/./src/a68g/laplace.c'; fi` @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) ./src/a68g/$(DEPDIR)/a68g-laplace.Tpo ./src/a68g/$(DEPDIR)/a68g-laplace.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='./src/a68g/laplace.c' object='./src/a68g/a68g-laplace.obj' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o ./src/a68g/a68g-laplace.obj `if test -f './src/a68g/laplace.c'; then $(CYGPATH_W) './src/a68g/laplace.c'; else $(CYGPATH_W) '$(srcdir)/./src/a68g/laplace.c'; fi` ./src/a68g/a68g-listing.o: ./src/a68g/listing.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT ./src/a68g/a68g-listing.o -MD -MP -MF ./src/a68g/$(DEPDIR)/a68g-listing.Tpo -c -o ./src/a68g/a68g-listing.o `test -f './src/a68g/listing.c' || echo '$(srcdir)/'`./src/a68g/listing.c @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) ./src/a68g/$(DEPDIR)/a68g-listing.Tpo ./src/a68g/$(DEPDIR)/a68g-listing.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='./src/a68g/listing.c' object='./src/a68g/a68g-listing.o' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o ./src/a68g/a68g-listing.o `test -f './src/a68g/listing.c' || echo '$(srcdir)/'`./src/a68g/listing.c ./src/a68g/a68g-listing.obj: ./src/a68g/listing.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT ./src/a68g/a68g-listing.obj -MD -MP -MF ./src/a68g/$(DEPDIR)/a68g-listing.Tpo -c -o ./src/a68g/a68g-listing.obj `if test -f './src/a68g/listing.c'; then $(CYGPATH_W) './src/a68g/listing.c'; else $(CYGPATH_W) '$(srcdir)/./src/a68g/listing.c'; fi` @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) ./src/a68g/$(DEPDIR)/a68g-listing.Tpo ./src/a68g/$(DEPDIR)/a68g-listing.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='./src/a68g/listing.c' object='./src/a68g/a68g-listing.obj' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o ./src/a68g/a68g-listing.obj `if test -f './src/a68g/listing.c'; then $(CYGPATH_W) './src/a68g/listing.c'; else $(CYGPATH_W) '$(srcdir)/./src/a68g/listing.c'; fi` ./src/a68g/a68g-mem.o: ./src/a68g/mem.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT ./src/a68g/a68g-mem.o -MD -MP -MF ./src/a68g/$(DEPDIR)/a68g-mem.Tpo -c -o ./src/a68g/a68g-mem.o `test -f './src/a68g/mem.c' || echo '$(srcdir)/'`./src/a68g/mem.c @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) ./src/a68g/$(DEPDIR)/a68g-mem.Tpo ./src/a68g/$(DEPDIR)/a68g-mem.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='./src/a68g/mem.c' object='./src/a68g/a68g-mem.o' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o ./src/a68g/a68g-mem.o `test -f './src/a68g/mem.c' || echo '$(srcdir)/'`./src/a68g/mem.c ./src/a68g/a68g-mem.obj: ./src/a68g/mem.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT ./src/a68g/a68g-mem.obj -MD -MP -MF ./src/a68g/$(DEPDIR)/a68g-mem.Tpo -c -o ./src/a68g/a68g-mem.obj `if test -f './src/a68g/mem.c'; then $(CYGPATH_W) './src/a68g/mem.c'; else $(CYGPATH_W) '$(srcdir)/./src/a68g/mem.c'; fi` @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) ./src/a68g/$(DEPDIR)/a68g-mem.Tpo ./src/a68g/$(DEPDIR)/a68g-mem.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='./src/a68g/mem.c' object='./src/a68g/a68g-mem.obj' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o ./src/a68g/a68g-mem.obj `if test -f './src/a68g/mem.c'; then $(CYGPATH_W) './src/a68g/mem.c'; else $(CYGPATH_W) '$(srcdir)/./src/a68g/mem.c'; fi` ./src/a68g/a68g-modes.o: ./src/a68g/modes.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT ./src/a68g/a68g-modes.o -MD -MP -MF ./src/a68g/$(DEPDIR)/a68g-modes.Tpo -c -o ./src/a68g/a68g-modes.o `test -f './src/a68g/modes.c' || echo '$(srcdir)/'`./src/a68g/modes.c @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) ./src/a68g/$(DEPDIR)/a68g-modes.Tpo ./src/a68g/$(DEPDIR)/a68g-modes.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='./src/a68g/modes.c' object='./src/a68g/a68g-modes.o' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o ./src/a68g/a68g-modes.o `test -f './src/a68g/modes.c' || echo '$(srcdir)/'`./src/a68g/modes.c ./src/a68g/a68g-modes.obj: ./src/a68g/modes.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT ./src/a68g/a68g-modes.obj -MD -MP -MF ./src/a68g/$(DEPDIR)/a68g-modes.Tpo -c -o ./src/a68g/a68g-modes.obj `if test -f './src/a68g/modes.c'; then $(CYGPATH_W) './src/a68g/modes.c'; else $(CYGPATH_W) '$(srcdir)/./src/a68g/modes.c'; fi` @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) ./src/a68g/$(DEPDIR)/a68g-modes.Tpo ./src/a68g/$(DEPDIR)/a68g-modes.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='./src/a68g/modes.c' object='./src/a68g/a68g-modes.obj' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o ./src/a68g/a68g-modes.obj `if test -f './src/a68g/modes.c'; then $(CYGPATH_W) './src/a68g/modes.c'; else $(CYGPATH_W) '$(srcdir)/./src/a68g/modes.c'; fi` ./src/a68g/a68g-moid-size.o: ./src/a68g/moid-size.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT ./src/a68g/a68g-moid-size.o -MD -MP -MF ./src/a68g/$(DEPDIR)/a68g-moid-size.Tpo -c -o ./src/a68g/a68g-moid-size.o `test -f './src/a68g/moid-size.c' || echo '$(srcdir)/'`./src/a68g/moid-size.c @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) ./src/a68g/$(DEPDIR)/a68g-moid-size.Tpo ./src/a68g/$(DEPDIR)/a68g-moid-size.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='./src/a68g/moid-size.c' object='./src/a68g/a68g-moid-size.o' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o ./src/a68g/a68g-moid-size.o `test -f './src/a68g/moid-size.c' || echo '$(srcdir)/'`./src/a68g/moid-size.c ./src/a68g/a68g-moid-size.obj: ./src/a68g/moid-size.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT ./src/a68g/a68g-moid-size.obj -MD -MP -MF ./src/a68g/$(DEPDIR)/a68g-moid-size.Tpo -c -o ./src/a68g/a68g-moid-size.obj `if test -f './src/a68g/moid-size.c'; then $(CYGPATH_W) './src/a68g/moid-size.c'; else $(CYGPATH_W) '$(srcdir)/./src/a68g/moid-size.c'; fi` @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) ./src/a68g/$(DEPDIR)/a68g-moid-size.Tpo ./src/a68g/$(DEPDIR)/a68g-moid-size.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='./src/a68g/moid-size.c' object='./src/a68g/a68g-moid-size.obj' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o ./src/a68g/a68g-moid-size.obj `if test -f './src/a68g/moid-size.c'; then $(CYGPATH_W) './src/a68g/moid-size.c'; else $(CYGPATH_W) '$(srcdir)/./src/a68g/moid-size.c'; fi` ./src/a68g/a68g-moid-to-string.o: ./src/a68g/moid-to-string.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT ./src/a68g/a68g-moid-to-string.o -MD -MP -MF ./src/a68g/$(DEPDIR)/a68g-moid-to-string.Tpo -c -o ./src/a68g/a68g-moid-to-string.o `test -f './src/a68g/moid-to-string.c' || echo '$(srcdir)/'`./src/a68g/moid-to-string.c @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) ./src/a68g/$(DEPDIR)/a68g-moid-to-string.Tpo ./src/a68g/$(DEPDIR)/a68g-moid-to-string.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='./src/a68g/moid-to-string.c' object='./src/a68g/a68g-moid-to-string.o' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o ./src/a68g/a68g-moid-to-string.o `test -f './src/a68g/moid-to-string.c' || echo '$(srcdir)/'`./src/a68g/moid-to-string.c ./src/a68g/a68g-moid-to-string.obj: ./src/a68g/moid-to-string.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT ./src/a68g/a68g-moid-to-string.obj -MD -MP -MF ./src/a68g/$(DEPDIR)/a68g-moid-to-string.Tpo -c -o ./src/a68g/a68g-moid-to-string.obj `if test -f './src/a68g/moid-to-string.c'; then $(CYGPATH_W) './src/a68g/moid-to-string.c'; else $(CYGPATH_W) '$(srcdir)/./src/a68g/moid-to-string.c'; fi` @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) ./src/a68g/$(DEPDIR)/a68g-moid-to-string.Tpo ./src/a68g/$(DEPDIR)/a68g-moid-to-string.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='./src/a68g/moid-to-string.c' object='./src/a68g/a68g-moid-to-string.obj' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o ./src/a68g/a68g-moid-to-string.obj `if test -f './src/a68g/moid-to-string.c'; then $(CYGPATH_W) './src/a68g/moid-to-string.c'; else $(CYGPATH_W) '$(srcdir)/./src/a68g/moid-to-string.c'; fi` ./src/a68g/a68g-monitor.o: ./src/a68g/monitor.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT ./src/a68g/a68g-monitor.o -MD -MP -MF ./src/a68g/$(DEPDIR)/a68g-monitor.Tpo -c -o ./src/a68g/a68g-monitor.o `test -f './src/a68g/monitor.c' || echo '$(srcdir)/'`./src/a68g/monitor.c @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) ./src/a68g/$(DEPDIR)/a68g-monitor.Tpo ./src/a68g/$(DEPDIR)/a68g-monitor.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='./src/a68g/monitor.c' object='./src/a68g/a68g-monitor.o' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o ./src/a68g/a68g-monitor.o `test -f './src/a68g/monitor.c' || echo '$(srcdir)/'`./src/a68g/monitor.c ./src/a68g/a68g-monitor.obj: ./src/a68g/monitor.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT ./src/a68g/a68g-monitor.obj -MD -MP -MF ./src/a68g/$(DEPDIR)/a68g-monitor.Tpo -c -o ./src/a68g/a68g-monitor.obj `if test -f './src/a68g/monitor.c'; then $(CYGPATH_W) './src/a68g/monitor.c'; else $(CYGPATH_W) '$(srcdir)/./src/a68g/monitor.c'; fi` @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) ./src/a68g/$(DEPDIR)/a68g-monitor.Tpo ./src/a68g/$(DEPDIR)/a68g-monitor.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='./src/a68g/monitor.c' object='./src/a68g/a68g-monitor.obj' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o ./src/a68g/a68g-monitor.obj `if test -f './src/a68g/monitor.c'; then $(CYGPATH_W) './src/a68g/monitor.c'; else $(CYGPATH_W) '$(srcdir)/./src/a68g/monitor.c'; fi` ./src/a68g/a68g-mp-bits.o: ./src/a68g/mp-bits.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT ./src/a68g/a68g-mp-bits.o -MD -MP -MF ./src/a68g/$(DEPDIR)/a68g-mp-bits.Tpo -c -o ./src/a68g/a68g-mp-bits.o `test -f './src/a68g/mp-bits.c' || echo '$(srcdir)/'`./src/a68g/mp-bits.c @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) ./src/a68g/$(DEPDIR)/a68g-mp-bits.Tpo ./src/a68g/$(DEPDIR)/a68g-mp-bits.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='./src/a68g/mp-bits.c' object='./src/a68g/a68g-mp-bits.o' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o ./src/a68g/a68g-mp-bits.o `test -f './src/a68g/mp-bits.c' || echo '$(srcdir)/'`./src/a68g/mp-bits.c ./src/a68g/a68g-mp-bits.obj: ./src/a68g/mp-bits.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT ./src/a68g/a68g-mp-bits.obj -MD -MP -MF ./src/a68g/$(DEPDIR)/a68g-mp-bits.Tpo -c -o ./src/a68g/a68g-mp-bits.obj `if test -f './src/a68g/mp-bits.c'; then $(CYGPATH_W) './src/a68g/mp-bits.c'; else $(CYGPATH_W) '$(srcdir)/./src/a68g/mp-bits.c'; fi` @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) ./src/a68g/$(DEPDIR)/a68g-mp-bits.Tpo ./src/a68g/$(DEPDIR)/a68g-mp-bits.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='./src/a68g/mp-bits.c' object='./src/a68g/a68g-mp-bits.obj' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o ./src/a68g/a68g-mp-bits.obj `if test -f './src/a68g/mp-bits.c'; then $(CYGPATH_W) './src/a68g/mp-bits.c'; else $(CYGPATH_W) '$(srcdir)/./src/a68g/mp-bits.c'; fi` ./src/a68g/a68g-mp.o: ./src/a68g/mp.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT ./src/a68g/a68g-mp.o -MD -MP -MF ./src/a68g/$(DEPDIR)/a68g-mp.Tpo -c -o ./src/a68g/a68g-mp.o `test -f './src/a68g/mp.c' || echo '$(srcdir)/'`./src/a68g/mp.c @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) ./src/a68g/$(DEPDIR)/a68g-mp.Tpo ./src/a68g/$(DEPDIR)/a68g-mp.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='./src/a68g/mp.c' object='./src/a68g/a68g-mp.o' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o ./src/a68g/a68g-mp.o `test -f './src/a68g/mp.c' || echo '$(srcdir)/'`./src/a68g/mp.c ./src/a68g/a68g-mp.obj: ./src/a68g/mp.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT ./src/a68g/a68g-mp.obj -MD -MP -MF ./src/a68g/$(DEPDIR)/a68g-mp.Tpo -c -o ./src/a68g/a68g-mp.obj `if test -f './src/a68g/mp.c'; then $(CYGPATH_W) './src/a68g/mp.c'; else $(CYGPATH_W) '$(srcdir)/./src/a68g/mp.c'; fi` @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) ./src/a68g/$(DEPDIR)/a68g-mp.Tpo ./src/a68g/$(DEPDIR)/a68g-mp.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='./src/a68g/mp.c' object='./src/a68g/a68g-mp.obj' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o ./src/a68g/a68g-mp.obj `if test -f './src/a68g/mp.c'; then $(CYGPATH_W) './src/a68g/mp.c'; else $(CYGPATH_W) '$(srcdir)/./src/a68g/mp.c'; fi` ./src/a68g/a68g-mp-constant.o: ./src/a68g/mp-constant.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT ./src/a68g/a68g-mp-constant.o -MD -MP -MF ./src/a68g/$(DEPDIR)/a68g-mp-constant.Tpo -c -o ./src/a68g/a68g-mp-constant.o `test -f './src/a68g/mp-constant.c' || echo '$(srcdir)/'`./src/a68g/mp-constant.c @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) ./src/a68g/$(DEPDIR)/a68g-mp-constant.Tpo ./src/a68g/$(DEPDIR)/a68g-mp-constant.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='./src/a68g/mp-constant.c' object='./src/a68g/a68g-mp-constant.o' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o ./src/a68g/a68g-mp-constant.o `test -f './src/a68g/mp-constant.c' || echo '$(srcdir)/'`./src/a68g/mp-constant.c ./src/a68g/a68g-mp-constant.obj: ./src/a68g/mp-constant.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT ./src/a68g/a68g-mp-constant.obj -MD -MP -MF ./src/a68g/$(DEPDIR)/a68g-mp-constant.Tpo -c -o ./src/a68g/a68g-mp-constant.obj `if test -f './src/a68g/mp-constant.c'; then $(CYGPATH_W) './src/a68g/mp-constant.c'; else $(CYGPATH_W) '$(srcdir)/./src/a68g/mp-constant.c'; fi` @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) ./src/a68g/$(DEPDIR)/a68g-mp-constant.Tpo ./src/a68g/$(DEPDIR)/a68g-mp-constant.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='./src/a68g/mp-constant.c' object='./src/a68g/a68g-mp-constant.obj' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o ./src/a68g/a68g-mp-constant.obj `if test -f './src/a68g/mp-constant.c'; then $(CYGPATH_W) './src/a68g/mp-constant.c'; else $(CYGPATH_W) '$(srcdir)/./src/a68g/mp-constant.c'; fi` ./src/a68g/a68g-mp-gamic.o: ./src/a68g/mp-gamic.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT ./src/a68g/a68g-mp-gamic.o -MD -MP -MF ./src/a68g/$(DEPDIR)/a68g-mp-gamic.Tpo -c -o ./src/a68g/a68g-mp-gamic.o `test -f './src/a68g/mp-gamic.c' || echo '$(srcdir)/'`./src/a68g/mp-gamic.c @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) ./src/a68g/$(DEPDIR)/a68g-mp-gamic.Tpo ./src/a68g/$(DEPDIR)/a68g-mp-gamic.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='./src/a68g/mp-gamic.c' object='./src/a68g/a68g-mp-gamic.o' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o ./src/a68g/a68g-mp-gamic.o `test -f './src/a68g/mp-gamic.c' || echo '$(srcdir)/'`./src/a68g/mp-gamic.c ./src/a68g/a68g-mp-gamic.obj: ./src/a68g/mp-gamic.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT ./src/a68g/a68g-mp-gamic.obj -MD -MP -MF ./src/a68g/$(DEPDIR)/a68g-mp-gamic.Tpo -c -o ./src/a68g/a68g-mp-gamic.obj `if test -f './src/a68g/mp-gamic.c'; then $(CYGPATH_W) './src/a68g/mp-gamic.c'; else $(CYGPATH_W) '$(srcdir)/./src/a68g/mp-gamic.c'; fi` @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) ./src/a68g/$(DEPDIR)/a68g-mp-gamic.Tpo ./src/a68g/$(DEPDIR)/a68g-mp-gamic.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='./src/a68g/mp-gamic.c' object='./src/a68g/a68g-mp-gamic.obj' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o ./src/a68g/a68g-mp-gamic.obj `if test -f './src/a68g/mp-gamic.c'; then $(CYGPATH_W) './src/a68g/mp-gamic.c'; else $(CYGPATH_W) '$(srcdir)/./src/a68g/mp-gamic.c'; fi` ./src/a68g/a68g-mp-gamma.o: ./src/a68g/mp-gamma.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT ./src/a68g/a68g-mp-gamma.o -MD -MP -MF ./src/a68g/$(DEPDIR)/a68g-mp-gamma.Tpo -c -o ./src/a68g/a68g-mp-gamma.o `test -f './src/a68g/mp-gamma.c' || echo '$(srcdir)/'`./src/a68g/mp-gamma.c @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) ./src/a68g/$(DEPDIR)/a68g-mp-gamma.Tpo ./src/a68g/$(DEPDIR)/a68g-mp-gamma.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='./src/a68g/mp-gamma.c' object='./src/a68g/a68g-mp-gamma.o' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o ./src/a68g/a68g-mp-gamma.o `test -f './src/a68g/mp-gamma.c' || echo '$(srcdir)/'`./src/a68g/mp-gamma.c ./src/a68g/a68g-mp-gamma.obj: ./src/a68g/mp-gamma.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT ./src/a68g/a68g-mp-gamma.obj -MD -MP -MF ./src/a68g/$(DEPDIR)/a68g-mp-gamma.Tpo -c -o ./src/a68g/a68g-mp-gamma.obj `if test -f './src/a68g/mp-gamma.c'; then $(CYGPATH_W) './src/a68g/mp-gamma.c'; else $(CYGPATH_W) '$(srcdir)/./src/a68g/mp-gamma.c'; fi` @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) ./src/a68g/$(DEPDIR)/a68g-mp-gamma.Tpo ./src/a68g/$(DEPDIR)/a68g-mp-gamma.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='./src/a68g/mp-gamma.c' object='./src/a68g/a68g-mp-gamma.obj' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o ./src/a68g/a68g-mp-gamma.obj `if test -f './src/a68g/mp-gamma.c'; then $(CYGPATH_W) './src/a68g/mp-gamma.c'; else $(CYGPATH_W) '$(srcdir)/./src/a68g/mp-gamma.c'; fi` ./src/a68g/a68g-mp-genie.o: ./src/a68g/mp-genie.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT ./src/a68g/a68g-mp-genie.o -MD -MP -MF ./src/a68g/$(DEPDIR)/a68g-mp-genie.Tpo -c -o ./src/a68g/a68g-mp-genie.o `test -f './src/a68g/mp-genie.c' || echo '$(srcdir)/'`./src/a68g/mp-genie.c @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) ./src/a68g/$(DEPDIR)/a68g-mp-genie.Tpo ./src/a68g/$(DEPDIR)/a68g-mp-genie.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='./src/a68g/mp-genie.c' object='./src/a68g/a68g-mp-genie.o' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o ./src/a68g/a68g-mp-genie.o `test -f './src/a68g/mp-genie.c' || echo '$(srcdir)/'`./src/a68g/mp-genie.c ./src/a68g/a68g-mp-genie.obj: ./src/a68g/mp-genie.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT ./src/a68g/a68g-mp-genie.obj -MD -MP -MF ./src/a68g/$(DEPDIR)/a68g-mp-genie.Tpo -c -o ./src/a68g/a68g-mp-genie.obj `if test -f './src/a68g/mp-genie.c'; then $(CYGPATH_W) './src/a68g/mp-genie.c'; else $(CYGPATH_W) '$(srcdir)/./src/a68g/mp-genie.c'; fi` @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) ./src/a68g/$(DEPDIR)/a68g-mp-genie.Tpo ./src/a68g/$(DEPDIR)/a68g-mp-genie.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='./src/a68g/mp-genie.c' object='./src/a68g/a68g-mp-genie.obj' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o ./src/a68g/a68g-mp-genie.obj `if test -f './src/a68g/mp-genie.c'; then $(CYGPATH_W) './src/a68g/mp-genie.c'; else $(CYGPATH_W) '$(srcdir)/./src/a68g/mp-genie.c'; fi` ./src/a68g/a68g-mp-math.o: ./src/a68g/mp-math.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT ./src/a68g/a68g-mp-math.o -MD -MP -MF ./src/a68g/$(DEPDIR)/a68g-mp-math.Tpo -c -o ./src/a68g/a68g-mp-math.o `test -f './src/a68g/mp-math.c' || echo '$(srcdir)/'`./src/a68g/mp-math.c @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) ./src/a68g/$(DEPDIR)/a68g-mp-math.Tpo ./src/a68g/$(DEPDIR)/a68g-mp-math.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='./src/a68g/mp-math.c' object='./src/a68g/a68g-mp-math.o' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o ./src/a68g/a68g-mp-math.o `test -f './src/a68g/mp-math.c' || echo '$(srcdir)/'`./src/a68g/mp-math.c ./src/a68g/a68g-mp-math.obj: ./src/a68g/mp-math.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT ./src/a68g/a68g-mp-math.obj -MD -MP -MF ./src/a68g/$(DEPDIR)/a68g-mp-math.Tpo -c -o ./src/a68g/a68g-mp-math.obj `if test -f './src/a68g/mp-math.c'; then $(CYGPATH_W) './src/a68g/mp-math.c'; else $(CYGPATH_W) '$(srcdir)/./src/a68g/mp-math.c'; fi` @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) ./src/a68g/$(DEPDIR)/a68g-mp-math.Tpo ./src/a68g/$(DEPDIR)/a68g-mp-math.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='./src/a68g/mp-math.c' object='./src/a68g/a68g-mp-math.obj' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o ./src/a68g/a68g-mp-math.obj `if test -f './src/a68g/mp-math.c'; then $(CYGPATH_W) './src/a68g/mp-math.c'; else $(CYGPATH_W) '$(srcdir)/./src/a68g/mp-math.c'; fi` ./src/a68g/a68g-mp-mpfr.o: ./src/a68g/mp-mpfr.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT ./src/a68g/a68g-mp-mpfr.o -MD -MP -MF ./src/a68g/$(DEPDIR)/a68g-mp-mpfr.Tpo -c -o ./src/a68g/a68g-mp-mpfr.o `test -f './src/a68g/mp-mpfr.c' || echo '$(srcdir)/'`./src/a68g/mp-mpfr.c @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) ./src/a68g/$(DEPDIR)/a68g-mp-mpfr.Tpo ./src/a68g/$(DEPDIR)/a68g-mp-mpfr.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='./src/a68g/mp-mpfr.c' object='./src/a68g/a68g-mp-mpfr.o' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o ./src/a68g/a68g-mp-mpfr.o `test -f './src/a68g/mp-mpfr.c' || echo '$(srcdir)/'`./src/a68g/mp-mpfr.c ./src/a68g/a68g-mp-mpfr.obj: ./src/a68g/mp-mpfr.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT ./src/a68g/a68g-mp-mpfr.obj -MD -MP -MF ./src/a68g/$(DEPDIR)/a68g-mp-mpfr.Tpo -c -o ./src/a68g/a68g-mp-mpfr.obj `if test -f './src/a68g/mp-mpfr.c'; then $(CYGPATH_W) './src/a68g/mp-mpfr.c'; else $(CYGPATH_W) '$(srcdir)/./src/a68g/mp-mpfr.c'; fi` @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) ./src/a68g/$(DEPDIR)/a68g-mp-mpfr.Tpo ./src/a68g/$(DEPDIR)/a68g-mp-mpfr.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='./src/a68g/mp-mpfr.c' object='./src/a68g/a68g-mp-mpfr.obj' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o ./src/a68g/a68g-mp-mpfr.obj `if test -f './src/a68g/mp-mpfr.c'; then $(CYGPATH_W) './src/a68g/mp-mpfr.c'; else $(CYGPATH_W) '$(srcdir)/./src/a68g/mp-mpfr.c'; fi` ./src/a68g/a68g-non-terminal.o: ./src/a68g/non-terminal.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT ./src/a68g/a68g-non-terminal.o -MD -MP -MF ./src/a68g/$(DEPDIR)/a68g-non-terminal.Tpo -c -o ./src/a68g/a68g-non-terminal.o `test -f './src/a68g/non-terminal.c' || echo '$(srcdir)/'`./src/a68g/non-terminal.c @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) ./src/a68g/$(DEPDIR)/a68g-non-terminal.Tpo ./src/a68g/$(DEPDIR)/a68g-non-terminal.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='./src/a68g/non-terminal.c' object='./src/a68g/a68g-non-terminal.o' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o ./src/a68g/a68g-non-terminal.o `test -f './src/a68g/non-terminal.c' || echo '$(srcdir)/'`./src/a68g/non-terminal.c ./src/a68g/a68g-non-terminal.obj: ./src/a68g/non-terminal.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT ./src/a68g/a68g-non-terminal.obj -MD -MP -MF ./src/a68g/$(DEPDIR)/a68g-non-terminal.Tpo -c -o ./src/a68g/a68g-non-terminal.obj `if test -f './src/a68g/non-terminal.c'; then $(CYGPATH_W) './src/a68g/non-terminal.c'; else $(CYGPATH_W) '$(srcdir)/./src/a68g/non-terminal.c'; fi` @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) ./src/a68g/$(DEPDIR)/a68g-non-terminal.Tpo ./src/a68g/$(DEPDIR)/a68g-non-terminal.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='./src/a68g/non-terminal.c' object='./src/a68g/a68g-non-terminal.obj' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o ./src/a68g/a68g-non-terminal.obj `if test -f './src/a68g/non-terminal.c'; then $(CYGPATH_W) './src/a68g/non-terminal.c'; else $(CYGPATH_W) '$(srcdir)/./src/a68g/non-terminal.c'; fi` ./src/a68g/a68g-options.o: ./src/a68g/options.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT ./src/a68g/a68g-options.o -MD -MP -MF ./src/a68g/$(DEPDIR)/a68g-options.Tpo -c -o ./src/a68g/a68g-options.o `test -f './src/a68g/options.c' || echo '$(srcdir)/'`./src/a68g/options.c @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) ./src/a68g/$(DEPDIR)/a68g-options.Tpo ./src/a68g/$(DEPDIR)/a68g-options.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='./src/a68g/options.c' object='./src/a68g/a68g-options.o' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o ./src/a68g/a68g-options.o `test -f './src/a68g/options.c' || echo '$(srcdir)/'`./src/a68g/options.c ./src/a68g/a68g-options.obj: ./src/a68g/options.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT ./src/a68g/a68g-options.obj -MD -MP -MF ./src/a68g/$(DEPDIR)/a68g-options.Tpo -c -o ./src/a68g/a68g-options.obj `if test -f './src/a68g/options.c'; then $(CYGPATH_W) './src/a68g/options.c'; else $(CYGPATH_W) '$(srcdir)/./src/a68g/options.c'; fi` @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) ./src/a68g/$(DEPDIR)/a68g-options.Tpo ./src/a68g/$(DEPDIR)/a68g-options.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='./src/a68g/options.c' object='./src/a68g/a68g-options.obj' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o ./src/a68g/a68g-options.obj `if test -f './src/a68g/options.c'; then $(CYGPATH_W) './src/a68g/options.c'; else $(CYGPATH_W) '$(srcdir)/./src/a68g/options.c'; fi` ./src/a68g/a68g-parallel.o: ./src/a68g/parallel.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT ./src/a68g/a68g-parallel.o -MD -MP -MF ./src/a68g/$(DEPDIR)/a68g-parallel.Tpo -c -o ./src/a68g/a68g-parallel.o `test -f './src/a68g/parallel.c' || echo '$(srcdir)/'`./src/a68g/parallel.c @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) ./src/a68g/$(DEPDIR)/a68g-parallel.Tpo ./src/a68g/$(DEPDIR)/a68g-parallel.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='./src/a68g/parallel.c' object='./src/a68g/a68g-parallel.o' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o ./src/a68g/a68g-parallel.o `test -f './src/a68g/parallel.c' || echo '$(srcdir)/'`./src/a68g/parallel.c ./src/a68g/a68g-parallel.obj: ./src/a68g/parallel.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT ./src/a68g/a68g-parallel.obj -MD -MP -MF ./src/a68g/$(DEPDIR)/a68g-parallel.Tpo -c -o ./src/a68g/a68g-parallel.obj `if test -f './src/a68g/parallel.c'; then $(CYGPATH_W) './src/a68g/parallel.c'; else $(CYGPATH_W) '$(srcdir)/./src/a68g/parallel.c'; fi` @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) ./src/a68g/$(DEPDIR)/a68g-parallel.Tpo ./src/a68g/$(DEPDIR)/a68g-parallel.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='./src/a68g/parallel.c' object='./src/a68g/a68g-parallel.obj' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o ./src/a68g/a68g-parallel.obj `if test -f './src/a68g/parallel.c'; then $(CYGPATH_W) './src/a68g/parallel.c'; else $(CYGPATH_W) '$(srcdir)/./src/a68g/parallel.c'; fi` ./src/a68g/a68g-parser.o: ./src/a68g/parser.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT ./src/a68g/a68g-parser.o -MD -MP -MF ./src/a68g/$(DEPDIR)/a68g-parser.Tpo -c -o ./src/a68g/a68g-parser.o `test -f './src/a68g/parser.c' || echo '$(srcdir)/'`./src/a68g/parser.c @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) ./src/a68g/$(DEPDIR)/a68g-parser.Tpo ./src/a68g/$(DEPDIR)/a68g-parser.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='./src/a68g/parser.c' object='./src/a68g/a68g-parser.o' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o ./src/a68g/a68g-parser.o `test -f './src/a68g/parser.c' || echo '$(srcdir)/'`./src/a68g/parser.c ./src/a68g/a68g-parser.obj: ./src/a68g/parser.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT ./src/a68g/a68g-parser.obj -MD -MP -MF ./src/a68g/$(DEPDIR)/a68g-parser.Tpo -c -o ./src/a68g/a68g-parser.obj `if test -f './src/a68g/parser.c'; then $(CYGPATH_W) './src/a68g/parser.c'; else $(CYGPATH_W) '$(srcdir)/./src/a68g/parser.c'; fi` @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) ./src/a68g/$(DEPDIR)/a68g-parser.Tpo ./src/a68g/$(DEPDIR)/a68g-parser.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='./src/a68g/parser.c' object='./src/a68g/a68g-parser.obj' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o ./src/a68g/a68g-parser.obj `if test -f './src/a68g/parser.c'; then $(CYGPATH_W) './src/a68g/parser.c'; else $(CYGPATH_W) '$(srcdir)/./src/a68g/parser.c'; fi` ./src/a68g/a68g-physics.o: ./src/a68g/physics.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT ./src/a68g/a68g-physics.o -MD -MP -MF ./src/a68g/$(DEPDIR)/a68g-physics.Tpo -c -o ./src/a68g/a68g-physics.o `test -f './src/a68g/physics.c' || echo '$(srcdir)/'`./src/a68g/physics.c @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) ./src/a68g/$(DEPDIR)/a68g-physics.Tpo ./src/a68g/$(DEPDIR)/a68g-physics.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='./src/a68g/physics.c' object='./src/a68g/a68g-physics.o' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o ./src/a68g/a68g-physics.o `test -f './src/a68g/physics.c' || echo '$(srcdir)/'`./src/a68g/physics.c ./src/a68g/a68g-physics.obj: ./src/a68g/physics.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT ./src/a68g/a68g-physics.obj -MD -MP -MF ./src/a68g/$(DEPDIR)/a68g-physics.Tpo -c -o ./src/a68g/a68g-physics.obj `if test -f './src/a68g/physics.c'; then $(CYGPATH_W) './src/a68g/physics.c'; else $(CYGPATH_W) '$(srcdir)/./src/a68g/physics.c'; fi` @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) ./src/a68g/$(DEPDIR)/a68g-physics.Tpo ./src/a68g/$(DEPDIR)/a68g-physics.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='./src/a68g/physics.c' object='./src/a68g/a68g-physics.obj' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o ./src/a68g/a68g-physics.obj `if test -f './src/a68g/physics.c'; then $(CYGPATH_W) './src/a68g/physics.c'; else $(CYGPATH_W) '$(srcdir)/./src/a68g/physics.c'; fi` ./src/a68g/a68g-plotutils.o: ./src/a68g/plotutils.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT ./src/a68g/a68g-plotutils.o -MD -MP -MF ./src/a68g/$(DEPDIR)/a68g-plotutils.Tpo -c -o ./src/a68g/a68g-plotutils.o `test -f './src/a68g/plotutils.c' || echo '$(srcdir)/'`./src/a68g/plotutils.c @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) ./src/a68g/$(DEPDIR)/a68g-plotutils.Tpo ./src/a68g/$(DEPDIR)/a68g-plotutils.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='./src/a68g/plotutils.c' object='./src/a68g/a68g-plotutils.o' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o ./src/a68g/a68g-plotutils.o `test -f './src/a68g/plotutils.c' || echo '$(srcdir)/'`./src/a68g/plotutils.c ./src/a68g/a68g-plotutils.obj: ./src/a68g/plotutils.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT ./src/a68g/a68g-plotutils.obj -MD -MP -MF ./src/a68g/$(DEPDIR)/a68g-plotutils.Tpo -c -o ./src/a68g/a68g-plotutils.obj `if test -f './src/a68g/plotutils.c'; then $(CYGPATH_W) './src/a68g/plotutils.c'; else $(CYGPATH_W) '$(srcdir)/./src/a68g/plotutils.c'; fi` @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) ./src/a68g/$(DEPDIR)/a68g-plotutils.Tpo ./src/a68g/$(DEPDIR)/a68g-plotutils.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='./src/a68g/plotutils.c' object='./src/a68g/a68g-plotutils.obj' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o ./src/a68g/a68g-plotutils.obj `if test -f './src/a68g/plotutils.c'; then $(CYGPATH_W) './src/a68g/plotutils.c'; else $(CYGPATH_W) '$(srcdir)/./src/a68g/plotutils.c'; fi` ./src/a68g/a68g-postgresql.o: ./src/a68g/postgresql.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT ./src/a68g/a68g-postgresql.o -MD -MP -MF ./src/a68g/$(DEPDIR)/a68g-postgresql.Tpo -c -o ./src/a68g/a68g-postgresql.o `test -f './src/a68g/postgresql.c' || echo '$(srcdir)/'`./src/a68g/postgresql.c @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) ./src/a68g/$(DEPDIR)/a68g-postgresql.Tpo ./src/a68g/$(DEPDIR)/a68g-postgresql.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='./src/a68g/postgresql.c' object='./src/a68g/a68g-postgresql.o' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o ./src/a68g/a68g-postgresql.o `test -f './src/a68g/postgresql.c' || echo '$(srcdir)/'`./src/a68g/postgresql.c ./src/a68g/a68g-postgresql.obj: ./src/a68g/postgresql.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT ./src/a68g/a68g-postgresql.obj -MD -MP -MF ./src/a68g/$(DEPDIR)/a68g-postgresql.Tpo -c -o ./src/a68g/a68g-postgresql.obj `if test -f './src/a68g/postgresql.c'; then $(CYGPATH_W) './src/a68g/postgresql.c'; else $(CYGPATH_W) '$(srcdir)/./src/a68g/postgresql.c'; fi` @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) ./src/a68g/$(DEPDIR)/a68g-postgresql.Tpo ./src/a68g/$(DEPDIR)/a68g-postgresql.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='./src/a68g/postgresql.c' object='./src/a68g/a68g-postgresql.obj' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o ./src/a68g/a68g-postgresql.obj `if test -f './src/a68g/postgresql.c'; then $(CYGPATH_W) './src/a68g/postgresql.c'; else $(CYGPATH_W) '$(srcdir)/./src/a68g/postgresql.c'; fi` ./src/a68g/a68g-postulates.o: ./src/a68g/postulates.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT ./src/a68g/a68g-postulates.o -MD -MP -MF ./src/a68g/$(DEPDIR)/a68g-postulates.Tpo -c -o ./src/a68g/a68g-postulates.o `test -f './src/a68g/postulates.c' || echo '$(srcdir)/'`./src/a68g/postulates.c @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) ./src/a68g/$(DEPDIR)/a68g-postulates.Tpo ./src/a68g/$(DEPDIR)/a68g-postulates.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='./src/a68g/postulates.c' object='./src/a68g/a68g-postulates.o' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o ./src/a68g/a68g-postulates.o `test -f './src/a68g/postulates.c' || echo '$(srcdir)/'`./src/a68g/postulates.c ./src/a68g/a68g-postulates.obj: ./src/a68g/postulates.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT ./src/a68g/a68g-postulates.obj -MD -MP -MF ./src/a68g/$(DEPDIR)/a68g-postulates.Tpo -c -o ./src/a68g/a68g-postulates.obj `if test -f './src/a68g/postulates.c'; then $(CYGPATH_W) './src/a68g/postulates.c'; else $(CYGPATH_W) '$(srcdir)/./src/a68g/postulates.c'; fi` @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) ./src/a68g/$(DEPDIR)/a68g-postulates.Tpo ./src/a68g/$(DEPDIR)/a68g-postulates.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='./src/a68g/postulates.c' object='./src/a68g/a68g-postulates.obj' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o ./src/a68g/a68g-postulates.obj `if test -f './src/a68g/postulates.c'; then $(CYGPATH_W) './src/a68g/postulates.c'; else $(CYGPATH_W) '$(srcdir)/./src/a68g/postulates.c'; fi` ./src/a68g/a68g-prelude-bits.o: ./src/a68g/prelude-bits.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT ./src/a68g/a68g-prelude-bits.o -MD -MP -MF ./src/a68g/$(DEPDIR)/a68g-prelude-bits.Tpo -c -o ./src/a68g/a68g-prelude-bits.o `test -f './src/a68g/prelude-bits.c' || echo '$(srcdir)/'`./src/a68g/prelude-bits.c @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) ./src/a68g/$(DEPDIR)/a68g-prelude-bits.Tpo ./src/a68g/$(DEPDIR)/a68g-prelude-bits.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='./src/a68g/prelude-bits.c' object='./src/a68g/a68g-prelude-bits.o' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o ./src/a68g/a68g-prelude-bits.o `test -f './src/a68g/prelude-bits.c' || echo '$(srcdir)/'`./src/a68g/prelude-bits.c ./src/a68g/a68g-prelude-bits.obj: ./src/a68g/prelude-bits.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT ./src/a68g/a68g-prelude-bits.obj -MD -MP -MF ./src/a68g/$(DEPDIR)/a68g-prelude-bits.Tpo -c -o ./src/a68g/a68g-prelude-bits.obj `if test -f './src/a68g/prelude-bits.c'; then $(CYGPATH_W) './src/a68g/prelude-bits.c'; else $(CYGPATH_W) '$(srcdir)/./src/a68g/prelude-bits.c'; fi` @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) ./src/a68g/$(DEPDIR)/a68g-prelude-bits.Tpo ./src/a68g/$(DEPDIR)/a68g-prelude-bits.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='./src/a68g/prelude-bits.c' object='./src/a68g/a68g-prelude-bits.obj' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o ./src/a68g/a68g-prelude-bits.obj `if test -f './src/a68g/prelude-bits.c'; then $(CYGPATH_W) './src/a68g/prelude-bits.c'; else $(CYGPATH_W) '$(srcdir)/./src/a68g/prelude-bits.c'; fi` ./src/a68g/a68g-prelude.o: ./src/a68g/prelude.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT ./src/a68g/a68g-prelude.o -MD -MP -MF ./src/a68g/$(DEPDIR)/a68g-prelude.Tpo -c -o ./src/a68g/a68g-prelude.o `test -f './src/a68g/prelude.c' || echo '$(srcdir)/'`./src/a68g/prelude.c @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) ./src/a68g/$(DEPDIR)/a68g-prelude.Tpo ./src/a68g/$(DEPDIR)/a68g-prelude.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='./src/a68g/prelude.c' object='./src/a68g/a68g-prelude.o' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o ./src/a68g/a68g-prelude.o `test -f './src/a68g/prelude.c' || echo '$(srcdir)/'`./src/a68g/prelude.c ./src/a68g/a68g-prelude.obj: ./src/a68g/prelude.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT ./src/a68g/a68g-prelude.obj -MD -MP -MF ./src/a68g/$(DEPDIR)/a68g-prelude.Tpo -c -o ./src/a68g/a68g-prelude.obj `if test -f './src/a68g/prelude.c'; then $(CYGPATH_W) './src/a68g/prelude.c'; else $(CYGPATH_W) '$(srcdir)/./src/a68g/prelude.c'; fi` @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) ./src/a68g/$(DEPDIR)/a68g-prelude.Tpo ./src/a68g/$(DEPDIR)/a68g-prelude.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='./src/a68g/prelude.c' object='./src/a68g/a68g-prelude.obj' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o ./src/a68g/a68g-prelude.obj `if test -f './src/a68g/prelude.c'; then $(CYGPATH_W) './src/a68g/prelude.c'; else $(CYGPATH_W) '$(srcdir)/./src/a68g/prelude.c'; fi` ./src/a68g/a68g-prelude-gsl.o: ./src/a68g/prelude-gsl.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT ./src/a68g/a68g-prelude-gsl.o -MD -MP -MF ./src/a68g/$(DEPDIR)/a68g-prelude-gsl.Tpo -c -o ./src/a68g/a68g-prelude-gsl.o `test -f './src/a68g/prelude-gsl.c' || echo '$(srcdir)/'`./src/a68g/prelude-gsl.c @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) ./src/a68g/$(DEPDIR)/a68g-prelude-gsl.Tpo ./src/a68g/$(DEPDIR)/a68g-prelude-gsl.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='./src/a68g/prelude-gsl.c' object='./src/a68g/a68g-prelude-gsl.o' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o ./src/a68g/a68g-prelude-gsl.o `test -f './src/a68g/prelude-gsl.c' || echo '$(srcdir)/'`./src/a68g/prelude-gsl.c ./src/a68g/a68g-prelude-gsl.obj: ./src/a68g/prelude-gsl.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT ./src/a68g/a68g-prelude-gsl.obj -MD -MP -MF ./src/a68g/$(DEPDIR)/a68g-prelude-gsl.Tpo -c -o ./src/a68g/a68g-prelude-gsl.obj `if test -f './src/a68g/prelude-gsl.c'; then $(CYGPATH_W) './src/a68g/prelude-gsl.c'; else $(CYGPATH_W) '$(srcdir)/./src/a68g/prelude-gsl.c'; fi` @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) ./src/a68g/$(DEPDIR)/a68g-prelude-gsl.Tpo ./src/a68g/$(DEPDIR)/a68g-prelude-gsl.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='./src/a68g/prelude-gsl.c' object='./src/a68g/a68g-prelude-gsl.obj' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o ./src/a68g/a68g-prelude-gsl.obj `if test -f './src/a68g/prelude-gsl.c'; then $(CYGPATH_W) './src/a68g/prelude-gsl.c'; else $(CYGPATH_W) '$(srcdir)/./src/a68g/prelude-gsl.c'; fi` ./src/a68g/a68g-prelude-mathlib.o: ./src/a68g/prelude-mathlib.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT ./src/a68g/a68g-prelude-mathlib.o -MD -MP -MF ./src/a68g/$(DEPDIR)/a68g-prelude-mathlib.Tpo -c -o ./src/a68g/a68g-prelude-mathlib.o `test -f './src/a68g/prelude-mathlib.c' || echo '$(srcdir)/'`./src/a68g/prelude-mathlib.c @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) ./src/a68g/$(DEPDIR)/a68g-prelude-mathlib.Tpo ./src/a68g/$(DEPDIR)/a68g-prelude-mathlib.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='./src/a68g/prelude-mathlib.c' object='./src/a68g/a68g-prelude-mathlib.o' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o ./src/a68g/a68g-prelude-mathlib.o `test -f './src/a68g/prelude-mathlib.c' || echo '$(srcdir)/'`./src/a68g/prelude-mathlib.c ./src/a68g/a68g-prelude-mathlib.obj: ./src/a68g/prelude-mathlib.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT ./src/a68g/a68g-prelude-mathlib.obj -MD -MP -MF ./src/a68g/$(DEPDIR)/a68g-prelude-mathlib.Tpo -c -o ./src/a68g/a68g-prelude-mathlib.obj `if test -f './src/a68g/prelude-mathlib.c'; then $(CYGPATH_W) './src/a68g/prelude-mathlib.c'; else $(CYGPATH_W) '$(srcdir)/./src/a68g/prelude-mathlib.c'; fi` @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) ./src/a68g/$(DEPDIR)/a68g-prelude-mathlib.Tpo ./src/a68g/$(DEPDIR)/a68g-prelude-mathlib.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='./src/a68g/prelude-mathlib.c' object='./src/a68g/a68g-prelude-mathlib.obj' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o ./src/a68g/a68g-prelude-mathlib.obj `if test -f './src/a68g/prelude-mathlib.c'; then $(CYGPATH_W) './src/a68g/prelude-mathlib.c'; else $(CYGPATH_W) '$(srcdir)/./src/a68g/prelude-mathlib.c'; fi` ./src/a68g/a68g-pretty.o: ./src/a68g/pretty.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT ./src/a68g/a68g-pretty.o -MD -MP -MF ./src/a68g/$(DEPDIR)/a68g-pretty.Tpo -c -o ./src/a68g/a68g-pretty.o `test -f './src/a68g/pretty.c' || echo '$(srcdir)/'`./src/a68g/pretty.c @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) ./src/a68g/$(DEPDIR)/a68g-pretty.Tpo ./src/a68g/$(DEPDIR)/a68g-pretty.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='./src/a68g/pretty.c' object='./src/a68g/a68g-pretty.o' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o ./src/a68g/a68g-pretty.o `test -f './src/a68g/pretty.c' || echo '$(srcdir)/'`./src/a68g/pretty.c ./src/a68g/a68g-pretty.obj: ./src/a68g/pretty.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT ./src/a68g/a68g-pretty.obj -MD -MP -MF ./src/a68g/$(DEPDIR)/a68g-pretty.Tpo -c -o ./src/a68g/a68g-pretty.obj `if test -f './src/a68g/pretty.c'; then $(CYGPATH_W) './src/a68g/pretty.c'; else $(CYGPATH_W) '$(srcdir)/./src/a68g/pretty.c'; fi` @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) ./src/a68g/$(DEPDIR)/a68g-pretty.Tpo ./src/a68g/$(DEPDIR)/a68g-pretty.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='./src/a68g/pretty.c' object='./src/a68g/a68g-pretty.obj' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o ./src/a68g/a68g-pretty.obj `if test -f './src/a68g/pretty.c'; then $(CYGPATH_W) './src/a68g/pretty.c'; else $(CYGPATH_W) '$(srcdir)/./src/a68g/pretty.c'; fi` ./src/a68g/a68g-refinement.o: ./src/a68g/refinement.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT ./src/a68g/a68g-refinement.o -MD -MP -MF ./src/a68g/$(DEPDIR)/a68g-refinement.Tpo -c -o ./src/a68g/a68g-refinement.o `test -f './src/a68g/refinement.c' || echo '$(srcdir)/'`./src/a68g/refinement.c @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) ./src/a68g/$(DEPDIR)/a68g-refinement.Tpo ./src/a68g/$(DEPDIR)/a68g-refinement.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='./src/a68g/refinement.c' object='./src/a68g/a68g-refinement.o' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o ./src/a68g/a68g-refinement.o `test -f './src/a68g/refinement.c' || echo '$(srcdir)/'`./src/a68g/refinement.c ./src/a68g/a68g-refinement.obj: ./src/a68g/refinement.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT ./src/a68g/a68g-refinement.obj -MD -MP -MF ./src/a68g/$(DEPDIR)/a68g-refinement.Tpo -c -o ./src/a68g/a68g-refinement.obj `if test -f './src/a68g/refinement.c'; then $(CYGPATH_W) './src/a68g/refinement.c'; else $(CYGPATH_W) '$(srcdir)/./src/a68g/refinement.c'; fi` @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) ./src/a68g/$(DEPDIR)/a68g-refinement.Tpo ./src/a68g/$(DEPDIR)/a68g-refinement.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='./src/a68g/refinement.c' object='./src/a68g/a68g-refinement.obj' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o ./src/a68g/a68g-refinement.obj `if test -f './src/a68g/refinement.c'; then $(CYGPATH_W) './src/a68g/refinement.c'; else $(CYGPATH_W) '$(srcdir)/./src/a68g/refinement.c'; fi` ./src/a68g/a68g-regex.o: ./src/a68g/regex.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT ./src/a68g/a68g-regex.o -MD -MP -MF ./src/a68g/$(DEPDIR)/a68g-regex.Tpo -c -o ./src/a68g/a68g-regex.o `test -f './src/a68g/regex.c' || echo '$(srcdir)/'`./src/a68g/regex.c @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) ./src/a68g/$(DEPDIR)/a68g-regex.Tpo ./src/a68g/$(DEPDIR)/a68g-regex.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='./src/a68g/regex.c' object='./src/a68g/a68g-regex.o' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o ./src/a68g/a68g-regex.o `test -f './src/a68g/regex.c' || echo '$(srcdir)/'`./src/a68g/regex.c ./src/a68g/a68g-regex.obj: ./src/a68g/regex.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT ./src/a68g/a68g-regex.obj -MD -MP -MF ./src/a68g/$(DEPDIR)/a68g-regex.Tpo -c -o ./src/a68g/a68g-regex.obj `if test -f './src/a68g/regex.c'; then $(CYGPATH_W) './src/a68g/regex.c'; else $(CYGPATH_W) '$(srcdir)/./src/a68g/regex.c'; fi` @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) ./src/a68g/$(DEPDIR)/a68g-regex.Tpo ./src/a68g/$(DEPDIR)/a68g-regex.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='./src/a68g/regex.c' object='./src/a68g/a68g-regex.obj' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o ./src/a68g/a68g-regex.obj `if test -f './src/a68g/regex.c'; then $(CYGPATH_W) './src/a68g/regex.c'; else $(CYGPATH_W) '$(srcdir)/./src/a68g/regex.c'; fi` ./src/a68g/a68g-rows.o: ./src/a68g/rows.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT ./src/a68g/a68g-rows.o -MD -MP -MF ./src/a68g/$(DEPDIR)/a68g-rows.Tpo -c -o ./src/a68g/a68g-rows.o `test -f './src/a68g/rows.c' || echo '$(srcdir)/'`./src/a68g/rows.c @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) ./src/a68g/$(DEPDIR)/a68g-rows.Tpo ./src/a68g/$(DEPDIR)/a68g-rows.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='./src/a68g/rows.c' object='./src/a68g/a68g-rows.o' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o ./src/a68g/a68g-rows.o `test -f './src/a68g/rows.c' || echo '$(srcdir)/'`./src/a68g/rows.c ./src/a68g/a68g-rows.obj: ./src/a68g/rows.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT ./src/a68g/a68g-rows.obj -MD -MP -MF ./src/a68g/$(DEPDIR)/a68g-rows.Tpo -c -o ./src/a68g/a68g-rows.obj `if test -f './src/a68g/rows.c'; then $(CYGPATH_W) './src/a68g/rows.c'; else $(CYGPATH_W) '$(srcdir)/./src/a68g/rows.c'; fi` @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) ./src/a68g/$(DEPDIR)/a68g-rows.Tpo ./src/a68g/$(DEPDIR)/a68g-rows.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='./src/a68g/rows.c' object='./src/a68g/a68g-rows.obj' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o ./src/a68g/a68g-rows.obj `if test -f './src/a68g/rows.c'; then $(CYGPATH_W) './src/a68g/rows.c'; else $(CYGPATH_W) '$(srcdir)/./src/a68g/rows.c'; fi` ./src/a68g/a68g-scanner.o: ./src/a68g/scanner.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT ./src/a68g/a68g-scanner.o -MD -MP -MF ./src/a68g/$(DEPDIR)/a68g-scanner.Tpo -c -o ./src/a68g/a68g-scanner.o `test -f './src/a68g/scanner.c' || echo '$(srcdir)/'`./src/a68g/scanner.c @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) ./src/a68g/$(DEPDIR)/a68g-scanner.Tpo ./src/a68g/$(DEPDIR)/a68g-scanner.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='./src/a68g/scanner.c' object='./src/a68g/a68g-scanner.o' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o ./src/a68g/a68g-scanner.o `test -f './src/a68g/scanner.c' || echo '$(srcdir)/'`./src/a68g/scanner.c ./src/a68g/a68g-scanner.obj: ./src/a68g/scanner.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT ./src/a68g/a68g-scanner.obj -MD -MP -MF ./src/a68g/$(DEPDIR)/a68g-scanner.Tpo -c -o ./src/a68g/a68g-scanner.obj `if test -f './src/a68g/scanner.c'; then $(CYGPATH_W) './src/a68g/scanner.c'; else $(CYGPATH_W) '$(srcdir)/./src/a68g/scanner.c'; fi` @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) ./src/a68g/$(DEPDIR)/a68g-scanner.Tpo ./src/a68g/$(DEPDIR)/a68g-scanner.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='./src/a68g/scanner.c' object='./src/a68g/a68g-scanner.obj' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o ./src/a68g/a68g-scanner.obj `if test -f './src/a68g/scanner.c'; then $(CYGPATH_W) './src/a68g/scanner.c'; else $(CYGPATH_W) '$(srcdir)/./src/a68g/scanner.c'; fi` ./src/a68g/a68g-scope.o: ./src/a68g/scope.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT ./src/a68g/a68g-scope.o -MD -MP -MF ./src/a68g/$(DEPDIR)/a68g-scope.Tpo -c -o ./src/a68g/a68g-scope.o `test -f './src/a68g/scope.c' || echo '$(srcdir)/'`./src/a68g/scope.c @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) ./src/a68g/$(DEPDIR)/a68g-scope.Tpo ./src/a68g/$(DEPDIR)/a68g-scope.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='./src/a68g/scope.c' object='./src/a68g/a68g-scope.o' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o ./src/a68g/a68g-scope.o `test -f './src/a68g/scope.c' || echo '$(srcdir)/'`./src/a68g/scope.c ./src/a68g/a68g-scope.obj: ./src/a68g/scope.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT ./src/a68g/a68g-scope.obj -MD -MP -MF ./src/a68g/$(DEPDIR)/a68g-scope.Tpo -c -o ./src/a68g/a68g-scope.obj `if test -f './src/a68g/scope.c'; then $(CYGPATH_W) './src/a68g/scope.c'; else $(CYGPATH_W) '$(srcdir)/./src/a68g/scope.c'; fi` @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) ./src/a68g/$(DEPDIR)/a68g-scope.Tpo ./src/a68g/$(DEPDIR)/a68g-scope.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='./src/a68g/scope.c' object='./src/a68g/a68g-scope.obj' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o ./src/a68g/a68g-scope.obj `if test -f './src/a68g/scope.c'; then $(CYGPATH_W) './src/a68g/scope.c'; else $(CYGPATH_W) '$(srcdir)/./src/a68g/scope.c'; fi` ./src/a68g/a68g-script.o: ./src/a68g/script.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT ./src/a68g/a68g-script.o -MD -MP -MF ./src/a68g/$(DEPDIR)/a68g-script.Tpo -c -o ./src/a68g/a68g-script.o `test -f './src/a68g/script.c' || echo '$(srcdir)/'`./src/a68g/script.c @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) ./src/a68g/$(DEPDIR)/a68g-script.Tpo ./src/a68g/$(DEPDIR)/a68g-script.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='./src/a68g/script.c' object='./src/a68g/a68g-script.o' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o ./src/a68g/a68g-script.o `test -f './src/a68g/script.c' || echo '$(srcdir)/'`./src/a68g/script.c ./src/a68g/a68g-script.obj: ./src/a68g/script.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT ./src/a68g/a68g-script.obj -MD -MP -MF ./src/a68g/$(DEPDIR)/a68g-script.Tpo -c -o ./src/a68g/a68g-script.obj `if test -f './src/a68g/script.c'; then $(CYGPATH_W) './src/a68g/script.c'; else $(CYGPATH_W) '$(srcdir)/./src/a68g/script.c'; fi` @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) ./src/a68g/$(DEPDIR)/a68g-script.Tpo ./src/a68g/$(DEPDIR)/a68g-script.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='./src/a68g/script.c' object='./src/a68g/a68g-script.obj' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o ./src/a68g/a68g-script.obj `if test -f './src/a68g/script.c'; then $(CYGPATH_W) './src/a68g/script.c'; else $(CYGPATH_W) '$(srcdir)/./src/a68g/script.c'; fi` ./src/a68g/a68g-single.o: ./src/a68g/single.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT ./src/a68g/a68g-single.o -MD -MP -MF ./src/a68g/$(DEPDIR)/a68g-single.Tpo -c -o ./src/a68g/a68g-single.o `test -f './src/a68g/single.c' || echo '$(srcdir)/'`./src/a68g/single.c @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) ./src/a68g/$(DEPDIR)/a68g-single.Tpo ./src/a68g/$(DEPDIR)/a68g-single.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='./src/a68g/single.c' object='./src/a68g/a68g-single.o' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o ./src/a68g/a68g-single.o `test -f './src/a68g/single.c' || echo '$(srcdir)/'`./src/a68g/single.c ./src/a68g/a68g-single.obj: ./src/a68g/single.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT ./src/a68g/a68g-single.obj -MD -MP -MF ./src/a68g/$(DEPDIR)/a68g-single.Tpo -c -o ./src/a68g/a68g-single.obj `if test -f './src/a68g/single.c'; then $(CYGPATH_W) './src/a68g/single.c'; else $(CYGPATH_W) '$(srcdir)/./src/a68g/single.c'; fi` @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) ./src/a68g/$(DEPDIR)/a68g-single.Tpo ./src/a68g/$(DEPDIR)/a68g-single.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='./src/a68g/single.c' object='./src/a68g/a68g-single.obj' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o ./src/a68g/a68g-single.obj `if test -f './src/a68g/single.c'; then $(CYGPATH_W) './src/a68g/single.c'; else $(CYGPATH_W) '$(srcdir)/./src/a68g/single.c'; fi` ./src/a68g/a68g-single-gamic.o: ./src/a68g/single-gamic.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT ./src/a68g/a68g-single-gamic.o -MD -MP -MF ./src/a68g/$(DEPDIR)/a68g-single-gamic.Tpo -c -o ./src/a68g/a68g-single-gamic.o `test -f './src/a68g/single-gamic.c' || echo '$(srcdir)/'`./src/a68g/single-gamic.c @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) ./src/a68g/$(DEPDIR)/a68g-single-gamic.Tpo ./src/a68g/$(DEPDIR)/a68g-single-gamic.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='./src/a68g/single-gamic.c' object='./src/a68g/a68g-single-gamic.o' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o ./src/a68g/a68g-single-gamic.o `test -f './src/a68g/single-gamic.c' || echo '$(srcdir)/'`./src/a68g/single-gamic.c ./src/a68g/a68g-single-gamic.obj: ./src/a68g/single-gamic.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT ./src/a68g/a68g-single-gamic.obj -MD -MP -MF ./src/a68g/$(DEPDIR)/a68g-single-gamic.Tpo -c -o ./src/a68g/a68g-single-gamic.obj `if test -f './src/a68g/single-gamic.c'; then $(CYGPATH_W) './src/a68g/single-gamic.c'; else $(CYGPATH_W) '$(srcdir)/./src/a68g/single-gamic.c'; fi` @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) ./src/a68g/$(DEPDIR)/a68g-single-gamic.Tpo ./src/a68g/$(DEPDIR)/a68g-single-gamic.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='./src/a68g/single-gamic.c' object='./src/a68g/a68g-single-gamic.obj' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o ./src/a68g/a68g-single-gamic.obj `if test -f './src/a68g/single-gamic.c'; then $(CYGPATH_W) './src/a68g/single-gamic.c'; else $(CYGPATH_W) '$(srcdir)/./src/a68g/single-gamic.c'; fi` ./src/a68g/a68g-single-gsl.o: ./src/a68g/single-gsl.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT ./src/a68g/a68g-single-gsl.o -MD -MP -MF ./src/a68g/$(DEPDIR)/a68g-single-gsl.Tpo -c -o ./src/a68g/a68g-single-gsl.o `test -f './src/a68g/single-gsl.c' || echo '$(srcdir)/'`./src/a68g/single-gsl.c @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) ./src/a68g/$(DEPDIR)/a68g-single-gsl.Tpo ./src/a68g/$(DEPDIR)/a68g-single-gsl.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='./src/a68g/single-gsl.c' object='./src/a68g/a68g-single-gsl.o' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o ./src/a68g/a68g-single-gsl.o `test -f './src/a68g/single-gsl.c' || echo '$(srcdir)/'`./src/a68g/single-gsl.c ./src/a68g/a68g-single-gsl.obj: ./src/a68g/single-gsl.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT ./src/a68g/a68g-single-gsl.obj -MD -MP -MF ./src/a68g/$(DEPDIR)/a68g-single-gsl.Tpo -c -o ./src/a68g/a68g-single-gsl.obj `if test -f './src/a68g/single-gsl.c'; then $(CYGPATH_W) './src/a68g/single-gsl.c'; else $(CYGPATH_W) '$(srcdir)/./src/a68g/single-gsl.c'; fi` @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) ./src/a68g/$(DEPDIR)/a68g-single-gsl.Tpo ./src/a68g/$(DEPDIR)/a68g-single-gsl.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='./src/a68g/single-gsl.c' object='./src/a68g/a68g-single-gsl.obj' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o ./src/a68g/a68g-single-gsl.obj `if test -f './src/a68g/single-gsl.c'; then $(CYGPATH_W) './src/a68g/single-gsl.c'; else $(CYGPATH_W) '$(srcdir)/./src/a68g/single-gsl.c'; fi` ./src/a68g/a68g-single-math.o: ./src/a68g/single-math.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT ./src/a68g/a68g-single-math.o -MD -MP -MF ./src/a68g/$(DEPDIR)/a68g-single-math.Tpo -c -o ./src/a68g/a68g-single-math.o `test -f './src/a68g/single-math.c' || echo '$(srcdir)/'`./src/a68g/single-math.c @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) ./src/a68g/$(DEPDIR)/a68g-single-math.Tpo ./src/a68g/$(DEPDIR)/a68g-single-math.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='./src/a68g/single-math.c' object='./src/a68g/a68g-single-math.o' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o ./src/a68g/a68g-single-math.o `test -f './src/a68g/single-math.c' || echo '$(srcdir)/'`./src/a68g/single-math.c ./src/a68g/a68g-single-math.obj: ./src/a68g/single-math.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT ./src/a68g/a68g-single-math.obj -MD -MP -MF ./src/a68g/$(DEPDIR)/a68g-single-math.Tpo -c -o ./src/a68g/a68g-single-math.obj `if test -f './src/a68g/single-math.c'; then $(CYGPATH_W) './src/a68g/single-math.c'; else $(CYGPATH_W) '$(srcdir)/./src/a68g/single-math.c'; fi` @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) ./src/a68g/$(DEPDIR)/a68g-single-math.Tpo ./src/a68g/$(DEPDIR)/a68g-single-math.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='./src/a68g/single-math.c' object='./src/a68g/a68g-single-math.obj' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o ./src/a68g/a68g-single-math.obj `if test -f './src/a68g/single-math.c'; then $(CYGPATH_W) './src/a68g/single-math.c'; else $(CYGPATH_W) '$(srcdir)/./src/a68g/single-math.c'; fi` ./src/a68g/a68g-single-mathlib.o: ./src/a68g/single-mathlib.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT ./src/a68g/a68g-single-mathlib.o -MD -MP -MF ./src/a68g/$(DEPDIR)/a68g-single-mathlib.Tpo -c -o ./src/a68g/a68g-single-mathlib.o `test -f './src/a68g/single-mathlib.c' || echo '$(srcdir)/'`./src/a68g/single-mathlib.c @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) ./src/a68g/$(DEPDIR)/a68g-single-mathlib.Tpo ./src/a68g/$(DEPDIR)/a68g-single-mathlib.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='./src/a68g/single-mathlib.c' object='./src/a68g/a68g-single-mathlib.o' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o ./src/a68g/a68g-single-mathlib.o `test -f './src/a68g/single-mathlib.c' || echo '$(srcdir)/'`./src/a68g/single-mathlib.c ./src/a68g/a68g-single-mathlib.obj: ./src/a68g/single-mathlib.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT ./src/a68g/a68g-single-mathlib.obj -MD -MP -MF ./src/a68g/$(DEPDIR)/a68g-single-mathlib.Tpo -c -o ./src/a68g/a68g-single-mathlib.obj `if test -f './src/a68g/single-mathlib.c'; then $(CYGPATH_W) './src/a68g/single-mathlib.c'; else $(CYGPATH_W) '$(srcdir)/./src/a68g/single-mathlib.c'; fi` @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) ./src/a68g/$(DEPDIR)/a68g-single-mathlib.Tpo ./src/a68g/$(DEPDIR)/a68g-single-mathlib.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='./src/a68g/single-mathlib.c' object='./src/a68g/a68g-single-mathlib.obj' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o ./src/a68g/a68g-single-mathlib.obj `if test -f './src/a68g/single-mathlib.c'; then $(CYGPATH_W) './src/a68g/single-mathlib.c'; else $(CYGPATH_W) '$(srcdir)/./src/a68g/single-mathlib.c'; fi` ./src/a68g/a68g-single-rnd.o: ./src/a68g/single-rnd.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT ./src/a68g/a68g-single-rnd.o -MD -MP -MF ./src/a68g/$(DEPDIR)/a68g-single-rnd.Tpo -c -o ./src/a68g/a68g-single-rnd.o `test -f './src/a68g/single-rnd.c' || echo '$(srcdir)/'`./src/a68g/single-rnd.c @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) ./src/a68g/$(DEPDIR)/a68g-single-rnd.Tpo ./src/a68g/$(DEPDIR)/a68g-single-rnd.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='./src/a68g/single-rnd.c' object='./src/a68g/a68g-single-rnd.o' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o ./src/a68g/a68g-single-rnd.o `test -f './src/a68g/single-rnd.c' || echo '$(srcdir)/'`./src/a68g/single-rnd.c ./src/a68g/a68g-single-rnd.obj: ./src/a68g/single-rnd.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT ./src/a68g/a68g-single-rnd.obj -MD -MP -MF ./src/a68g/$(DEPDIR)/a68g-single-rnd.Tpo -c -o ./src/a68g/a68g-single-rnd.obj `if test -f './src/a68g/single-rnd.c'; then $(CYGPATH_W) './src/a68g/single-rnd.c'; else $(CYGPATH_W) '$(srcdir)/./src/a68g/single-rnd.c'; fi` @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) ./src/a68g/$(DEPDIR)/a68g-single-rnd.Tpo ./src/a68g/$(DEPDIR)/a68g-single-rnd.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='./src/a68g/single-rnd.c' object='./src/a68g/a68g-single-rnd.obj' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o ./src/a68g/a68g-single-rnd.obj `if test -f './src/a68g/single-rnd.c'; then $(CYGPATH_W) './src/a68g/single-rnd.c'; else $(CYGPATH_W) '$(srcdir)/./src/a68g/single-rnd.c'; fi` ./src/a68g/a68g-socket.o: ./src/a68g/socket.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT ./src/a68g/a68g-socket.o -MD -MP -MF ./src/a68g/$(DEPDIR)/a68g-socket.Tpo -c -o ./src/a68g/a68g-socket.o `test -f './src/a68g/socket.c' || echo '$(srcdir)/'`./src/a68g/socket.c @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) ./src/a68g/$(DEPDIR)/a68g-socket.Tpo ./src/a68g/$(DEPDIR)/a68g-socket.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='./src/a68g/socket.c' object='./src/a68g/a68g-socket.o' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o ./src/a68g/a68g-socket.o `test -f './src/a68g/socket.c' || echo '$(srcdir)/'`./src/a68g/socket.c ./src/a68g/a68g-socket.obj: ./src/a68g/socket.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT ./src/a68g/a68g-socket.obj -MD -MP -MF ./src/a68g/$(DEPDIR)/a68g-socket.Tpo -c -o ./src/a68g/a68g-socket.obj `if test -f './src/a68g/socket.c'; then $(CYGPATH_W) './src/a68g/socket.c'; else $(CYGPATH_W) '$(srcdir)/./src/a68g/socket.c'; fi` @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) ./src/a68g/$(DEPDIR)/a68g-socket.Tpo ./src/a68g/$(DEPDIR)/a68g-socket.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='./src/a68g/socket.c' object='./src/a68g/a68g-socket.obj' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o ./src/a68g/a68g-socket.obj `if test -f './src/a68g/socket.c'; then $(CYGPATH_W) './src/a68g/socket.c'; else $(CYGPATH_W) '$(srcdir)/./src/a68g/socket.c'; fi` ./src/a68g/a68g-sounds.o: ./src/a68g/sounds.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT ./src/a68g/a68g-sounds.o -MD -MP -MF ./src/a68g/$(DEPDIR)/a68g-sounds.Tpo -c -o ./src/a68g/a68g-sounds.o `test -f './src/a68g/sounds.c' || echo '$(srcdir)/'`./src/a68g/sounds.c @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) ./src/a68g/$(DEPDIR)/a68g-sounds.Tpo ./src/a68g/$(DEPDIR)/a68g-sounds.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='./src/a68g/sounds.c' object='./src/a68g/a68g-sounds.o' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o ./src/a68g/a68g-sounds.o `test -f './src/a68g/sounds.c' || echo '$(srcdir)/'`./src/a68g/sounds.c ./src/a68g/a68g-sounds.obj: ./src/a68g/sounds.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT ./src/a68g/a68g-sounds.obj -MD -MP -MF ./src/a68g/$(DEPDIR)/a68g-sounds.Tpo -c -o ./src/a68g/a68g-sounds.obj `if test -f './src/a68g/sounds.c'; then $(CYGPATH_W) './src/a68g/sounds.c'; else $(CYGPATH_W) '$(srcdir)/./src/a68g/sounds.c'; fi` @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) ./src/a68g/$(DEPDIR)/a68g-sounds.Tpo ./src/a68g/$(DEPDIR)/a68g-sounds.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='./src/a68g/sounds.c' object='./src/a68g/a68g-sounds.obj' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o ./src/a68g/a68g-sounds.obj `if test -f './src/a68g/sounds.c'; then $(CYGPATH_W) './src/a68g/sounds.c'; else $(CYGPATH_W) '$(srcdir)/./src/a68g/sounds.c'; fi` ./src/a68g/a68g-taxes.o: ./src/a68g/taxes.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT ./src/a68g/a68g-taxes.o -MD -MP -MF ./src/a68g/$(DEPDIR)/a68g-taxes.Tpo -c -o ./src/a68g/a68g-taxes.o `test -f './src/a68g/taxes.c' || echo '$(srcdir)/'`./src/a68g/taxes.c @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) ./src/a68g/$(DEPDIR)/a68g-taxes.Tpo ./src/a68g/$(DEPDIR)/a68g-taxes.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='./src/a68g/taxes.c' object='./src/a68g/a68g-taxes.o' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o ./src/a68g/a68g-taxes.o `test -f './src/a68g/taxes.c' || echo '$(srcdir)/'`./src/a68g/taxes.c ./src/a68g/a68g-taxes.obj: ./src/a68g/taxes.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT ./src/a68g/a68g-taxes.obj -MD -MP -MF ./src/a68g/$(DEPDIR)/a68g-taxes.Tpo -c -o ./src/a68g/a68g-taxes.obj `if test -f './src/a68g/taxes.c'; then $(CYGPATH_W) './src/a68g/taxes.c'; else $(CYGPATH_W) '$(srcdir)/./src/a68g/taxes.c'; fi` @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) ./src/a68g/$(DEPDIR)/a68g-taxes.Tpo ./src/a68g/$(DEPDIR)/a68g-taxes.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='./src/a68g/taxes.c' object='./src/a68g/a68g-taxes.obj' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o ./src/a68g/a68g-taxes.obj `if test -f './src/a68g/taxes.c'; then $(CYGPATH_W) './src/a68g/taxes.c'; else $(CYGPATH_W) '$(srcdir)/./src/a68g/taxes.c'; fi` ./src/a68g/a68g-top-down.o: ./src/a68g/top-down.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT ./src/a68g/a68g-top-down.o -MD -MP -MF ./src/a68g/$(DEPDIR)/a68g-top-down.Tpo -c -o ./src/a68g/a68g-top-down.o `test -f './src/a68g/top-down.c' || echo '$(srcdir)/'`./src/a68g/top-down.c @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) ./src/a68g/$(DEPDIR)/a68g-top-down.Tpo ./src/a68g/$(DEPDIR)/a68g-top-down.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='./src/a68g/top-down.c' object='./src/a68g/a68g-top-down.o' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o ./src/a68g/a68g-top-down.o `test -f './src/a68g/top-down.c' || echo '$(srcdir)/'`./src/a68g/top-down.c ./src/a68g/a68g-top-down.obj: ./src/a68g/top-down.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT ./src/a68g/a68g-top-down.obj -MD -MP -MF ./src/a68g/$(DEPDIR)/a68g-top-down.Tpo -c -o ./src/a68g/a68g-top-down.obj `if test -f './src/a68g/top-down.c'; then $(CYGPATH_W) './src/a68g/top-down.c'; else $(CYGPATH_W) '$(srcdir)/./src/a68g/top-down.c'; fi` @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) ./src/a68g/$(DEPDIR)/a68g-top-down.Tpo ./src/a68g/$(DEPDIR)/a68g-top-down.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='./src/a68g/top-down.c' object='./src/a68g/a68g-top-down.obj' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o ./src/a68g/a68g-top-down.obj `if test -f './src/a68g/top-down.c'; then $(CYGPATH_W) './src/a68g/top-down.c'; else $(CYGPATH_W) '$(srcdir)/./src/a68g/top-down.c'; fi` ./src/a68g/a68g-torrix.o: ./src/a68g/torrix.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT ./src/a68g/a68g-torrix.o -MD -MP -MF ./src/a68g/$(DEPDIR)/a68g-torrix.Tpo -c -o ./src/a68g/a68g-torrix.o `test -f './src/a68g/torrix.c' || echo '$(srcdir)/'`./src/a68g/torrix.c @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) ./src/a68g/$(DEPDIR)/a68g-torrix.Tpo ./src/a68g/$(DEPDIR)/a68g-torrix.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='./src/a68g/torrix.c' object='./src/a68g/a68g-torrix.o' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o ./src/a68g/a68g-torrix.o `test -f './src/a68g/torrix.c' || echo '$(srcdir)/'`./src/a68g/torrix.c ./src/a68g/a68g-torrix.obj: ./src/a68g/torrix.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT ./src/a68g/a68g-torrix.obj -MD -MP -MF ./src/a68g/$(DEPDIR)/a68g-torrix.Tpo -c -o ./src/a68g/a68g-torrix.obj `if test -f './src/a68g/torrix.c'; then $(CYGPATH_W) './src/a68g/torrix.c'; else $(CYGPATH_W) '$(srcdir)/./src/a68g/torrix.c'; fi` @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) ./src/a68g/$(DEPDIR)/a68g-torrix.Tpo ./src/a68g/$(DEPDIR)/a68g-torrix.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='./src/a68g/torrix.c' object='./src/a68g/a68g-torrix.obj' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o ./src/a68g/a68g-torrix.obj `if test -f './src/a68g/torrix.c'; then $(CYGPATH_W) './src/a68g/torrix.c'; else $(CYGPATH_W) '$(srcdir)/./src/a68g/torrix.c'; fi` ./src/a68g/a68g-transput.o: ./src/a68g/transput.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT ./src/a68g/a68g-transput.o -MD -MP -MF ./src/a68g/$(DEPDIR)/a68g-transput.Tpo -c -o ./src/a68g/a68g-transput.o `test -f './src/a68g/transput.c' || echo '$(srcdir)/'`./src/a68g/transput.c @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) ./src/a68g/$(DEPDIR)/a68g-transput.Tpo ./src/a68g/$(DEPDIR)/a68g-transput.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='./src/a68g/transput.c' object='./src/a68g/a68g-transput.o' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o ./src/a68g/a68g-transput.o `test -f './src/a68g/transput.c' || echo '$(srcdir)/'`./src/a68g/transput.c ./src/a68g/a68g-transput.obj: ./src/a68g/transput.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT ./src/a68g/a68g-transput.obj -MD -MP -MF ./src/a68g/$(DEPDIR)/a68g-transput.Tpo -c -o ./src/a68g/a68g-transput.obj `if test -f './src/a68g/transput.c'; then $(CYGPATH_W) './src/a68g/transput.c'; else $(CYGPATH_W) '$(srcdir)/./src/a68g/transput.c'; fi` @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) ./src/a68g/$(DEPDIR)/a68g-transput.Tpo ./src/a68g/$(DEPDIR)/a68g-transput.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='./src/a68g/transput.c' object='./src/a68g/a68g-transput.obj' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o ./src/a68g/a68g-transput.obj `if test -f './src/a68g/transput.c'; then $(CYGPATH_W) './src/a68g/transput.c'; else $(CYGPATH_W) '$(srcdir)/./src/a68g/transput.c'; fi` ./src/a68g/a68g-unix.o: ./src/a68g/unix.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT ./src/a68g/a68g-unix.o -MD -MP -MF ./src/a68g/$(DEPDIR)/a68g-unix.Tpo -c -o ./src/a68g/a68g-unix.o `test -f './src/a68g/unix.c' || echo '$(srcdir)/'`./src/a68g/unix.c @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) ./src/a68g/$(DEPDIR)/a68g-unix.Tpo ./src/a68g/$(DEPDIR)/a68g-unix.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='./src/a68g/unix.c' object='./src/a68g/a68g-unix.o' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o ./src/a68g/a68g-unix.o `test -f './src/a68g/unix.c' || echo '$(srcdir)/'`./src/a68g/unix.c ./src/a68g/a68g-unix.obj: ./src/a68g/unix.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT ./src/a68g/a68g-unix.obj -MD -MP -MF ./src/a68g/$(DEPDIR)/a68g-unix.Tpo -c -o ./src/a68g/a68g-unix.obj `if test -f './src/a68g/unix.c'; then $(CYGPATH_W) './src/a68g/unix.c'; else $(CYGPATH_W) '$(srcdir)/./src/a68g/unix.c'; fi` @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) ./src/a68g/$(DEPDIR)/a68g-unix.Tpo ./src/a68g/$(DEPDIR)/a68g-unix.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='./src/a68g/unix.c' object='./src/a68g/a68g-unix.obj' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o ./src/a68g/a68g-unix.obj `if test -f './src/a68g/unix.c'; then $(CYGPATH_W) './src/a68g/unix.c'; else $(CYGPATH_W) '$(srcdir)/./src/a68g/unix.c'; fi` ./src/a68g/a68g-victal.o: ./src/a68g/victal.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT ./src/a68g/a68g-victal.o -MD -MP -MF ./src/a68g/$(DEPDIR)/a68g-victal.Tpo -c -o ./src/a68g/a68g-victal.o `test -f './src/a68g/victal.c' || echo '$(srcdir)/'`./src/a68g/victal.c @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) ./src/a68g/$(DEPDIR)/a68g-victal.Tpo ./src/a68g/$(DEPDIR)/a68g-victal.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='./src/a68g/victal.c' object='./src/a68g/a68g-victal.o' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o ./src/a68g/a68g-victal.o `test -f './src/a68g/victal.c' || echo '$(srcdir)/'`./src/a68g/victal.c ./src/a68g/a68g-victal.obj: ./src/a68g/victal.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT ./src/a68g/a68g-victal.obj -MD -MP -MF ./src/a68g/$(DEPDIR)/a68g-victal.Tpo -c -o ./src/a68g/a68g-victal.obj `if test -f './src/a68g/victal.c'; then $(CYGPATH_W) './src/a68g/victal.c'; else $(CYGPATH_W) '$(srcdir)/./src/a68g/victal.c'; fi` @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) ./src/a68g/$(DEPDIR)/a68g-victal.Tpo ./src/a68g/$(DEPDIR)/a68g-victal.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='./src/a68g/victal.c' object='./src/a68g/a68g-victal.obj' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(a68g_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o ./src/a68g/a68g-victal.obj `if test -f './src/a68g/victal.c'; then $(CYGPATH_W) './src/a68g/victal.c'; else $(CYGPATH_W) '$(srcdir)/./src/a68g/victal.c'; fi` install-man1: $(man_MANS) @$(NORMAL_INSTALL) @list1=''; \ list2='$(man_MANS)'; \ test -n "$(man1dir)" \ && test -n "`echo $$list1$$list2`" \ || exit 0; \ echo " $(MKDIR_P) '$(DESTDIR)$(man1dir)'"; \ $(MKDIR_P) "$(DESTDIR)$(man1dir)" || exit 1; \ { for i in $$list1; do echo "$$i"; done; \ if test -n "$$list2"; then \ for i in $$list2; do echo "$$i"; done \ | sed -n '/\.1[a-z]*$$/p'; \ fi; \ } | while read p; do \ if test -f $$p; then d=; else d="$(srcdir)/"; fi; \ echo "$$d$$p"; echo "$$p"; \ done | \ sed -e 'n;s,.*/,,;p;h;s,.*\.,,;s,^[^1][0-9a-z]*$$,1,;x' \ -e 's,\.[0-9a-z]*$$,,;$(transform);G;s,\n,.,' | \ sed 'N;N;s,\n, ,g' | { \ list=; while read file base inst; do \ if test "$$base" = "$$inst"; then list="$$list $$file"; else \ echo " $(INSTALL_DATA) '$$file' '$(DESTDIR)$(man1dir)/$$inst'"; \ $(INSTALL_DATA) "$$file" "$(DESTDIR)$(man1dir)/$$inst" || exit $$?; \ fi; \ done; \ for i in $$list; do echo "$$i"; done | $(am__base_list) | \ while read files; do \ test -z "$$files" || { \ echo " $(INSTALL_DATA) $$files '$(DESTDIR)$(man1dir)'"; \ $(INSTALL_DATA) $$files "$(DESTDIR)$(man1dir)" || exit $$?; }; \ done; } uninstall-man1: @$(NORMAL_UNINSTALL) @list=''; test -n "$(man1dir)" || exit 0; \ files=`{ for i in $$list; do echo "$$i"; done; \ l2='$(man_MANS)'; for i in $$l2; do echo "$$i"; done | \ sed -n '/\.1[a-z]*$$/p'; \ } | sed -e 's,.*/,,;h;s,.*\.,,;s,^[^1][0-9a-z]*$$,1,;x' \ -e 's,\.[0-9a-z]*$$,,;$(transform);G;s,\n,.,'`; \ dir='$(DESTDIR)$(man1dir)'; $(am__uninstall_files_from_dir) install-docDATA: $(doc_DATA) @$(NORMAL_INSTALL) @list='$(doc_DATA)'; test -n "$(docdir)" || list=; \ if test -n "$$list"; then \ echo " $(MKDIR_P) '$(DESTDIR)$(docdir)'"; \ $(MKDIR_P) "$(DESTDIR)$(docdir)" || exit 1; \ fi; \ for p in $$list; do \ if test -f "$$p"; then d=; else d="$(srcdir)/"; fi; \ echo "$$d$$p"; \ done | $(am__base_list) | \ while read files; do \ echo " $(INSTALL_DATA) $$files '$(DESTDIR)$(docdir)'"; \ $(INSTALL_DATA) $$files "$(DESTDIR)$(docdir)" || exit $$?; \ done uninstall-docDATA: @$(NORMAL_UNINSTALL) @list='$(doc_DATA)'; test -n "$(docdir)" || list=; \ files=`for p in $$list; do echo $$p; done | sed -e 's|^.*/||'`; \ dir='$(DESTDIR)$(docdir)'; $(am__uninstall_files_from_dir) install-pkgincludeHEADERS: $(pkginclude_HEADERS) @$(NORMAL_INSTALL) @list='$(pkginclude_HEADERS)'; test -n "$(pkgincludedir)" || list=; \ if test -n "$$list"; then \ echo " $(MKDIR_P) '$(DESTDIR)$(pkgincludedir)'"; \ $(MKDIR_P) "$(DESTDIR)$(pkgincludedir)" || exit 1; \ fi; \ for p in $$list; do \ if test -f "$$p"; then d=; else d="$(srcdir)/"; fi; \ echo "$$d$$p"; \ done | $(am__base_list) | \ while read files; do \ echo " $(INSTALL_HEADER) $$files '$(DESTDIR)$(pkgincludedir)'"; \ $(INSTALL_HEADER) $$files "$(DESTDIR)$(pkgincludedir)" || exit $$?; \ done uninstall-pkgincludeHEADERS: @$(NORMAL_UNINSTALL) @list='$(pkginclude_HEADERS)'; test -n "$(pkgincludedir)" || list=; \ files=`for p in $$list; do echo $$p; done | sed -e 's|^.*/||'`; \ dir='$(DESTDIR)$(pkgincludedir)'; $(am__uninstall_files_from_dir) ID: $(am__tagged_files) $(am__define_uniq_tagged_files); mkid -fID $$unique tags: tags-am TAGS: tags tags-am: $(TAGS_DEPENDENCIES) $(am__tagged_files) set x; \ here=`pwd`; \ $(am__define_uniq_tagged_files); \ shift; \ if test -z "$(ETAGS_ARGS)$$*$$unique"; then :; else \ test -n "$$unique" || unique=$$empty_fix; \ if test $$# -gt 0; then \ $(ETAGS) $(ETAGSFLAGS) $(AM_ETAGSFLAGS) $(ETAGS_ARGS) \ "$$@" $$unique; \ else \ $(ETAGS) $(ETAGSFLAGS) $(AM_ETAGSFLAGS) $(ETAGS_ARGS) \ $$unique; \ fi; \ fi ctags: ctags-am CTAGS: ctags ctags-am: $(TAGS_DEPENDENCIES) $(am__tagged_files) $(am__define_uniq_tagged_files); \ test -z "$(CTAGS_ARGS)$$unique" \ || $(CTAGS) $(CTAGSFLAGS) $(AM_CTAGSFLAGS) $(CTAGS_ARGS) \ $$unique GTAGS: here=`$(am__cd) $(top_builddir) && pwd` \ && $(am__cd) $(top_srcdir) \ && gtags -i $(GTAGS_ARGS) "$$here" cscope: cscope.files test ! -s cscope.files \ || $(CSCOPE) -b -q $(AM_CSCOPEFLAGS) $(CSCOPEFLAGS) -i cscope.files $(CSCOPE_ARGS) clean-cscope: -rm -f cscope.files cscope.files: clean-cscope cscopelist cscopelist: cscopelist-am cscopelist-am: $(am__tagged_files) list='$(am__tagged_files)'; \ case "$(srcdir)" in \ [\\/]* | ?:[\\/]*) sdir="$(srcdir)" ;; \ *) sdir=$(subdir)/$(srcdir) ;; \ esac; \ for i in $$list; do \ if test -f "$$i"; then \ echo "$(subdir)/$$i"; \ else \ echo "$$sdir/$$i"; \ fi; \ done >> $(top_builddir)/cscope.files distclean-tags: -rm -f TAGS ID GTAGS GRTAGS GSYMS GPATH tags -rm -f cscope.out cscope.in.out cscope.po.out cscope.files check-TESTS: $(TESTS) @failed=0; all=0; xfail=0; xpass=0; skip=0; \ srcdir=$(srcdir); export srcdir; \ list=' $(TESTS) '; \ $(am__tty_colors); \ 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 $(AM_TESTS_FD_REDIRECT); then \ all=`expr $$all + 1`; \ case " $(XFAIL_TESTS) " in \ *[\ \ ]$$tst[\ \ ]*) \ xpass=`expr $$xpass + 1`; \ failed=`expr $$failed + 1`; \ col=$$red; res=XPASS; \ ;; \ *) \ col=$$grn; res=PASS; \ ;; \ esac; \ elif test $$? -ne 77; then \ all=`expr $$all + 1`; \ case " $(XFAIL_TESTS) " in \ *[\ \ ]$$tst[\ \ ]*) \ xfail=`expr $$xfail + 1`; \ col=$$lgn; res=XFAIL; \ ;; \ *) \ failed=`expr $$failed + 1`; \ col=$$red; res=FAIL; \ ;; \ esac; \ else \ skip=`expr $$skip + 1`; \ col=$$blu; res=SKIP; \ fi; \ echo "$${col}$$res$${std}: $$tst"; \ done; \ if test "$$all" -eq 1; then \ tests="test"; \ All=""; \ else \ tests="tests"; \ All="All "; \ fi; \ if test "$$failed" -eq 0; then \ if test "$$xfail" -eq 0; then \ banner="$$All$$all $$tests passed"; \ else \ if test "$$xfail" -eq 1; then failures=failure; else failures=failures; fi; \ 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 \ if test "$$xpass" -eq 1; then passes=pass; else passes=passes; fi; \ banner="$$failed of $$all $$tests did not behave as expected ($$xpass unexpected $$passes)"; \ fi; \ fi; \ dashes="$$banner"; \ skipped=""; \ if test "$$skip" -ne 0; then \ if test "$$skip" -eq 1; then \ skipped="($$skip test was not run)"; \ else \ skipped="($$skip tests were not run)"; \ fi; \ 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`; \ if test "$$failed" -eq 0; then \ col="$$grn"; \ else \ col="$$red"; \ fi; \ echo "$${col}$$dashes$${std}"; \ echo "$${col}$$banner$${std}"; \ test -z "$$skipped" || echo "$${col}$$skipped$${std}"; \ test -z "$$report" || echo "$${col}$$report$${std}"; \ echo "$${col}$$dashes$${std}"; \ test "$$failed" -eq 0; \ else :; fi distdir: $(BUILT_SOURCES) $(MAKE) $(AM_MAKEFLAGS) distdir-am distdir-am: $(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 "$(distdir)/$$file"; then \ find "$(distdir)/$$file" -type d ! -perm -700 -exec chmod u+rwx {} \;; \ fi; \ if test -d $(srcdir)/$$file && test $$d != $(srcdir); then \ cp -fpR $(srcdir)/$$file "$(distdir)$$dir" || exit 1; \ find "$(distdir)/$$file" -type d ! -perm -700 -exec chmod u+rwx {} \;; \ fi; \ cp -fpR $$d/$$file "$(distdir)$$dir" || exit 1; \ else \ test -f "$(distdir)/$$file" \ || cp -p $$d/$$file "$(distdir)/$$file" \ || exit 1; \ fi; \ done -test -n "$(am__skip_mode_fix)" \ || find "$(distdir)" -type d ! -perm -755 \ -exec chmod u+rwx,go+rx {} \; -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) | eval GZIP= gzip $(GZIP_ENV) -c >$(distdir).tar.gz $(am__post_remove_distdir) dist-bzip2: distdir tardir=$(distdir) && $(am__tar) | BZIP2=$${BZIP2--9} bzip2 -c >$(distdir).tar.bz2 $(am__post_remove_distdir) dist-lzip: distdir tardir=$(distdir) && $(am__tar) | lzip -c $${LZIP_OPT--9} >$(distdir).tar.lz $(am__post_remove_distdir) dist-xz: distdir tardir=$(distdir) && $(am__tar) | XZ_OPT=$${XZ_OPT--e} xz -c >$(distdir).tar.xz $(am__post_remove_distdir) dist-zstd: distdir tardir=$(distdir) && $(am__tar) | zstd -c $${ZSTD_CLEVEL-$${ZSTD_OPT--19}} >$(distdir).tar.zst $(am__post_remove_distdir) dist-tarZ: distdir @echo WARNING: "Support for distribution archives compressed with" \ "legacy program 'compress' is deprecated." >&2 @echo WARNING: "It will be removed altogether in Automake 2.0" >&2 tardir=$(distdir) && $(am__tar) | compress -c >$(distdir).tar.Z $(am__post_remove_distdir) dist-shar: distdir @echo WARNING: "Support for shar distribution archives is" \ "deprecated." >&2 @echo WARNING: "It will be removed altogether in Automake 2.0" >&2 shar $(distdir) | eval GZIP= gzip $(GZIP_ENV) -c >$(distdir).shar.gz $(am__post_remove_distdir) dist-zip: distdir -rm -f $(distdir).zip zip -rq $(distdir).zip $(distdir) $(am__post_remove_distdir) dist dist-all: $(MAKE) $(AM_MAKEFLAGS) $(DIST_TARGETS) am__post_remove_distdir='@:' $(am__post_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*) \ eval GZIP= gzip $(GZIP_ENV) -dc $(distdir).tar.gz | $(am__untar) ;;\ *.tar.bz2*) \ bzip2 -dc $(distdir).tar.bz2 | $(am__untar) ;;\ *.tar.lz*) \ lzip -dc $(distdir).tar.lz | $(am__untar) ;;\ *.tar.xz*) \ xz -dc $(distdir).tar.xz | $(am__untar) ;;\ *.tar.Z*) \ uncompress -c $(distdir).tar.Z | $(am__untar) ;;\ *.shar.gz*) \ eval GZIP= gzip $(GZIP_ENV) -dc $(distdir).shar.gz | unshar ;;\ *.zip*) \ unzip $(distdir).zip ;;\ *.tar.zst*) \ zstd -dc $(distdir).tar.zst | $(am__untar) ;;\ esac chmod -R a-w $(distdir) chmod u+w $(distdir) mkdir $(distdir)/_build $(distdir)/_build/sub $(distdir)/_inst chmod a-w $(distdir) test -d $(distdir)/_build || exit 0; \ dc_install_base=`$(am__cd) $(distdir)/_inst && pwd | sed -e 's,^[^:\\/]:[\\/],/,'` \ && dc_destdir="$${TMPDIR-/tmp}/am-dc-$$$$/" \ && am__cwd=`pwd` \ && $(am__cd) $(distdir)/_build/sub \ && ../../configure \ $(AM_DISTCHECK_CONFIGURE_FLAGS) \ $(DISTCHECK_CONFIGURE_FLAGS) \ --srcdir=../.. --prefix="$$dc_install_base" \ && $(MAKE) $(AM_MAKEFLAGS) \ && $(MAKE) $(AM_MAKEFLAGS) $(AM_DISTCHECK_DVI_TARGET) \ && $(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 \ && cd "$$am__cwd" \ || exit 1 $(am__post_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: @test -n '$(distuninstallcheck_dir)' || { \ echo 'ERROR: trying to run $@ with an empty' \ '$$(distuninstallcheck_dir)' >&2; \ exit 1; \ }; \ $(am__cd) '$(distuninstallcheck_dir)' || { \ echo 'ERROR: cannot chdir into $(distuninstallcheck_dir)' >&2; \ exit 1; \ }; \ test `$(am__distuninstallcheck_listfiles) | wc -l` -eq 0 \ || { 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) a68g-config.h 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: if test -z '$(STRIP)'; then \ $(MAKE) $(AM_MAKEFLAGS) INSTALL_PROGRAM="$(INSTALL_STRIP_PROGRAM)" \ install_sh_PROGRAM="$(INSTALL_STRIP_PROGRAM)" INSTALL_STRIP_FLAG=-s \ install; \ else \ $(MAKE) $(AM_MAKEFLAGS) INSTALL_PROGRAM="$(INSTALL_STRIP_PROGRAM)" \ install_sh_PROGRAM="$(INSTALL_STRIP_PROGRAM)" INSTALL_STRIP_FLAG=-s \ "INSTALL_PROGRAM_ENV=STRIPPROG='$(STRIP)'" install; \ fi mostlyclean-generic: clean-generic: distclean-generic: -test -z "$(CONFIG_CLEAN_FILES)" || rm -f $(CONFIG_CLEAN_FILES) -test . = "$(srcdir)" || test -z "$(CONFIG_CLEAN_VPATH_FILES)" || rm -f $(CONFIG_CLEAN_VPATH_FILES) -rm -f src/a68g/$(DEPDIR)/$(am__dirstamp) -rm -f src/a68g/$(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 -f ./src/a68g/$(DEPDIR)/a68g-a68g.Po -rm -f ./src/a68g/$(DEPDIR)/a68g-a68glib.Po -rm -f ./src/a68g/$(DEPDIR)/a68g-apropos.Po -rm -f ./src/a68g/$(DEPDIR)/a68g-bits.Po -rm -f ./src/a68g/$(DEPDIR)/a68g-bool.Po -rm -f ./src/a68g/$(DEPDIR)/a68g-bottom-up.Po -rm -f ./src/a68g/$(DEPDIR)/a68g-brackets.Po -rm -f ./src/a68g/$(DEPDIR)/a68g-char.Po -rm -f ./src/a68g/$(DEPDIR)/a68g-compiler-basic.Po -rm -f ./src/a68g/$(DEPDIR)/a68g-compiler-folder.Po -rm -f ./src/a68g/$(DEPDIR)/a68g-compiler-gen.Po -rm -f ./src/a68g/$(DEPDIR)/a68g-compiler-inline.Po -rm -f ./src/a68g/$(DEPDIR)/a68g-compiler-tables.Po -rm -f ./src/a68g/$(DEPDIR)/a68g-compiler.Po -rm -f ./src/a68g/$(DEPDIR)/a68g-conversion.Po -rm -f ./src/a68g/$(DEPDIR)/a68g-curses.Po -rm -f ./src/a68g/$(DEPDIR)/a68g-diagnostics.Po -rm -f ./src/a68g/$(DEPDIR)/a68g-double-gamic.Po -rm -f ./src/a68g/$(DEPDIR)/a68g-double-math.Po -rm -f ./src/a68g/$(DEPDIR)/a68g-double.Po -rm -f ./src/a68g/$(DEPDIR)/a68g-enquiries.Po -rm -f ./src/a68g/$(DEPDIR)/a68g-environ.Po -rm -f ./src/a68g/$(DEPDIR)/a68g-equivalence.Po -rm -f ./src/a68g/$(DEPDIR)/a68g-extract.Po -rm -f ./src/a68g/$(DEPDIR)/a68g-fft.Po -rm -f ./src/a68g/$(DEPDIR)/a68g-format.Po -rm -f ./src/a68g/$(DEPDIR)/a68g-genie-coerce.Po -rm -f ./src/a68g/$(DEPDIR)/a68g-genie-stowed.Po -rm -f ./src/a68g/$(DEPDIR)/a68g-genie.Po -rm -f ./src/a68g/$(DEPDIR)/a68g-heap.Po -rm -f ./src/a68g/$(DEPDIR)/a68g-io.Po -rm -f ./src/a68g/$(DEPDIR)/a68g-keywords.Po -rm -f ./src/a68g/$(DEPDIR)/a68g-laplace.Po -rm -f ./src/a68g/$(DEPDIR)/a68g-listing.Po -rm -f ./src/a68g/$(DEPDIR)/a68g-mem.Po -rm -f ./src/a68g/$(DEPDIR)/a68g-modes.Po -rm -f ./src/a68g/$(DEPDIR)/a68g-moid-size.Po -rm -f ./src/a68g/$(DEPDIR)/a68g-moid-to-string.Po -rm -f ./src/a68g/$(DEPDIR)/a68g-monitor.Po -rm -f ./src/a68g/$(DEPDIR)/a68g-mp-bits.Po -rm -f ./src/a68g/$(DEPDIR)/a68g-mp-constant.Po -rm -f ./src/a68g/$(DEPDIR)/a68g-mp-gamic.Po -rm -f ./src/a68g/$(DEPDIR)/a68g-mp-gamma.Po -rm -f ./src/a68g/$(DEPDIR)/a68g-mp-genie.Po -rm -f ./src/a68g/$(DEPDIR)/a68g-mp-math.Po -rm -f ./src/a68g/$(DEPDIR)/a68g-mp-mpfr.Po -rm -f ./src/a68g/$(DEPDIR)/a68g-mp.Po -rm -f ./src/a68g/$(DEPDIR)/a68g-non-terminal.Po -rm -f ./src/a68g/$(DEPDIR)/a68g-options.Po -rm -f ./src/a68g/$(DEPDIR)/a68g-parallel.Po -rm -f ./src/a68g/$(DEPDIR)/a68g-parser.Po -rm -f ./src/a68g/$(DEPDIR)/a68g-physics.Po -rm -f ./src/a68g/$(DEPDIR)/a68g-plotutils.Po -rm -f ./src/a68g/$(DEPDIR)/a68g-postgresql.Po -rm -f ./src/a68g/$(DEPDIR)/a68g-postulates.Po -rm -f ./src/a68g/$(DEPDIR)/a68g-prelude-bits.Po -rm -f ./src/a68g/$(DEPDIR)/a68g-prelude-gsl.Po -rm -f ./src/a68g/$(DEPDIR)/a68g-prelude-mathlib.Po -rm -f ./src/a68g/$(DEPDIR)/a68g-prelude.Po -rm -f ./src/a68g/$(DEPDIR)/a68g-pretty.Po -rm -f ./src/a68g/$(DEPDIR)/a68g-refinement.Po -rm -f ./src/a68g/$(DEPDIR)/a68g-regex.Po -rm -f ./src/a68g/$(DEPDIR)/a68g-rows.Po -rm -f ./src/a68g/$(DEPDIR)/a68g-scanner.Po -rm -f ./src/a68g/$(DEPDIR)/a68g-scope.Po -rm -f ./src/a68g/$(DEPDIR)/a68g-script.Po -rm -f ./src/a68g/$(DEPDIR)/a68g-single-gamic.Po -rm -f ./src/a68g/$(DEPDIR)/a68g-single-gsl.Po -rm -f ./src/a68g/$(DEPDIR)/a68g-single-math.Po -rm -f ./src/a68g/$(DEPDIR)/a68g-single-mathlib.Po -rm -f ./src/a68g/$(DEPDIR)/a68g-single-rnd.Po -rm -f ./src/a68g/$(DEPDIR)/a68g-single.Po -rm -f ./src/a68g/$(DEPDIR)/a68g-socket.Po -rm -f ./src/a68g/$(DEPDIR)/a68g-sounds.Po -rm -f ./src/a68g/$(DEPDIR)/a68g-taxes.Po -rm -f ./src/a68g/$(DEPDIR)/a68g-top-down.Po -rm -f ./src/a68g/$(DEPDIR)/a68g-torrix.Po -rm -f ./src/a68g/$(DEPDIR)/a68g-transput.Po -rm -f ./src/a68g/$(DEPDIR)/a68g-unix.Po -rm -f ./src/a68g/$(DEPDIR)/a68g-victal.Po -rm -f Makefile distclean-am: clean-am distclean-compile distclean-generic \ distclean-hdr distclean-tags dvi: dvi-am dvi-am: html: html-am html-am: info: info-am info-am: install-data-am: install-docDATA install-man install-pkgincludeHEADERS install-dvi: install-dvi-am install-dvi-am: install-exec-am: install-binPROGRAMS install-html: install-html-am install-html-am: install-info: install-info-am install-info-am: install-man: install-man1 install-pdf: install-pdf-am install-pdf-am: install-ps: install-ps-am install-ps-am: installcheck-am: maintainer-clean: maintainer-clean-am -rm -f $(am__CONFIG_DISTCLEAN_FILES) -rm -rf $(top_srcdir)/autom4te.cache -rm -f ./src/a68g/$(DEPDIR)/a68g-a68g.Po -rm -f ./src/a68g/$(DEPDIR)/a68g-a68glib.Po -rm -f ./src/a68g/$(DEPDIR)/a68g-apropos.Po -rm -f ./src/a68g/$(DEPDIR)/a68g-bits.Po -rm -f ./src/a68g/$(DEPDIR)/a68g-bool.Po -rm -f ./src/a68g/$(DEPDIR)/a68g-bottom-up.Po -rm -f ./src/a68g/$(DEPDIR)/a68g-brackets.Po -rm -f ./src/a68g/$(DEPDIR)/a68g-char.Po -rm -f ./src/a68g/$(DEPDIR)/a68g-compiler-basic.Po -rm -f ./src/a68g/$(DEPDIR)/a68g-compiler-folder.Po -rm -f ./src/a68g/$(DEPDIR)/a68g-compiler-gen.Po -rm -f ./src/a68g/$(DEPDIR)/a68g-compiler-inline.Po -rm -f ./src/a68g/$(DEPDIR)/a68g-compiler-tables.Po -rm -f ./src/a68g/$(DEPDIR)/a68g-compiler.Po -rm -f ./src/a68g/$(DEPDIR)/a68g-conversion.Po -rm -f ./src/a68g/$(DEPDIR)/a68g-curses.Po -rm -f ./src/a68g/$(DEPDIR)/a68g-diagnostics.Po -rm -f ./src/a68g/$(DEPDIR)/a68g-double-gamic.Po -rm -f ./src/a68g/$(DEPDIR)/a68g-double-math.Po -rm -f ./src/a68g/$(DEPDIR)/a68g-double.Po -rm -f ./src/a68g/$(DEPDIR)/a68g-enquiries.Po -rm -f ./src/a68g/$(DEPDIR)/a68g-environ.Po -rm -f ./src/a68g/$(DEPDIR)/a68g-equivalence.Po -rm -f ./src/a68g/$(DEPDIR)/a68g-extract.Po -rm -f ./src/a68g/$(DEPDIR)/a68g-fft.Po -rm -f ./src/a68g/$(DEPDIR)/a68g-format.Po -rm -f ./src/a68g/$(DEPDIR)/a68g-genie-coerce.Po -rm -f ./src/a68g/$(DEPDIR)/a68g-genie-stowed.Po -rm -f ./src/a68g/$(DEPDIR)/a68g-genie.Po -rm -f ./src/a68g/$(DEPDIR)/a68g-heap.Po -rm -f ./src/a68g/$(DEPDIR)/a68g-io.Po -rm -f ./src/a68g/$(DEPDIR)/a68g-keywords.Po -rm -f ./src/a68g/$(DEPDIR)/a68g-laplace.Po -rm -f ./src/a68g/$(DEPDIR)/a68g-listing.Po -rm -f ./src/a68g/$(DEPDIR)/a68g-mem.Po -rm -f ./src/a68g/$(DEPDIR)/a68g-modes.Po -rm -f ./src/a68g/$(DEPDIR)/a68g-moid-size.Po -rm -f ./src/a68g/$(DEPDIR)/a68g-moid-to-string.Po -rm -f ./src/a68g/$(DEPDIR)/a68g-monitor.Po -rm -f ./src/a68g/$(DEPDIR)/a68g-mp-bits.Po -rm -f ./src/a68g/$(DEPDIR)/a68g-mp-constant.Po -rm -f ./src/a68g/$(DEPDIR)/a68g-mp-gamic.Po -rm -f ./src/a68g/$(DEPDIR)/a68g-mp-gamma.Po -rm -f ./src/a68g/$(DEPDIR)/a68g-mp-genie.Po -rm -f ./src/a68g/$(DEPDIR)/a68g-mp-math.Po -rm -f ./src/a68g/$(DEPDIR)/a68g-mp-mpfr.Po -rm -f ./src/a68g/$(DEPDIR)/a68g-mp.Po -rm -f ./src/a68g/$(DEPDIR)/a68g-non-terminal.Po -rm -f ./src/a68g/$(DEPDIR)/a68g-options.Po -rm -f ./src/a68g/$(DEPDIR)/a68g-parallel.Po -rm -f ./src/a68g/$(DEPDIR)/a68g-parser.Po -rm -f ./src/a68g/$(DEPDIR)/a68g-physics.Po -rm -f ./src/a68g/$(DEPDIR)/a68g-plotutils.Po -rm -f ./src/a68g/$(DEPDIR)/a68g-postgresql.Po -rm -f ./src/a68g/$(DEPDIR)/a68g-postulates.Po -rm -f ./src/a68g/$(DEPDIR)/a68g-prelude-bits.Po -rm -f ./src/a68g/$(DEPDIR)/a68g-prelude-gsl.Po -rm -f ./src/a68g/$(DEPDIR)/a68g-prelude-mathlib.Po -rm -f ./src/a68g/$(DEPDIR)/a68g-prelude.Po -rm -f ./src/a68g/$(DEPDIR)/a68g-pretty.Po -rm -f ./src/a68g/$(DEPDIR)/a68g-refinement.Po -rm -f ./src/a68g/$(DEPDIR)/a68g-regex.Po -rm -f ./src/a68g/$(DEPDIR)/a68g-rows.Po -rm -f ./src/a68g/$(DEPDIR)/a68g-scanner.Po -rm -f ./src/a68g/$(DEPDIR)/a68g-scope.Po -rm -f ./src/a68g/$(DEPDIR)/a68g-script.Po -rm -f ./src/a68g/$(DEPDIR)/a68g-single-gamic.Po -rm -f ./src/a68g/$(DEPDIR)/a68g-single-gsl.Po -rm -f ./src/a68g/$(DEPDIR)/a68g-single-math.Po -rm -f ./src/a68g/$(DEPDIR)/a68g-single-mathlib.Po -rm -f ./src/a68g/$(DEPDIR)/a68g-single-rnd.Po -rm -f ./src/a68g/$(DEPDIR)/a68g-single.Po -rm -f ./src/a68g/$(DEPDIR)/a68g-socket.Po -rm -f ./src/a68g/$(DEPDIR)/a68g-sounds.Po -rm -f ./src/a68g/$(DEPDIR)/a68g-taxes.Po -rm -f ./src/a68g/$(DEPDIR)/a68g-top-down.Po -rm -f ./src/a68g/$(DEPDIR)/a68g-torrix.Po -rm -f ./src/a68g/$(DEPDIR)/a68g-transput.Po -rm -f ./src/a68g/$(DEPDIR)/a68g-unix.Po -rm -f ./src/a68g/$(DEPDIR)/a68g-victal.Po -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: all check-am install-am install-strip .PHONY: CTAGS GTAGS TAGS all all-am am--depfiles am--refresh check \ check-TESTS check-am clean clean-binPROGRAMS clean-cscope \ clean-generic cscope cscopelist-am ctags ctags-am dist \ dist-all dist-bzip2 dist-gzip dist-lzip dist-shar dist-tarZ \ dist-xz dist-zip dist-zstd 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 tags-am uninstall uninstall-am \ uninstall-binPROGRAMS uninstall-docDATA uninstall-man \ uninstall-man1 uninstall-pkgincludeHEADERS .PRECIOUS: Makefile # 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-3.1.2/Makefile.am0000644000175000017500000001176414361065446012137 00000000000000a68g_SOURCES = \ ./src/a68g/a68g.c \ ./src/a68g/a68glib.c \ ./src/a68g/apropos.c \ ./src/a68g/bits.c \ ./src/a68g/bool.c \ ./src/a68g/bottom-up.c \ ./src/a68g/brackets.c \ ./src/a68g/char.c \ ./src/a68g/compiler-basic.c \ ./src/a68g/compiler.c \ ./src/a68g/compiler-folder.c \ ./src/a68g/compiler-gen.c \ ./src/a68g/compiler-inline.c \ ./src/a68g/compiler-tables.c \ ./src/a68g/conversion.c \ ./src/a68g/curses.c \ ./src/a68g/diagnostics.c \ ./src/a68g/double.c \ ./src/a68g/double-gamic.c \ ./src/a68g/double-math.c \ ./src/a68g/enquiries.c \ ./src/a68g/environ.c \ ./src/a68g/equivalence.c \ ./src/a68g/extract.c \ ./src/a68g/fft.c \ ./src/a68g/format.c \ ./src/a68g/genie.c \ ./src/a68g/genie-coerce.c \ ./src/a68g/genie-stowed.c \ ./src/a68g/heap.c \ ./src/a68g/io.c \ ./src/a68g/keywords.c \ ./src/a68g/laplace.c \ ./src/a68g/listing.c \ ./src/a68g/mem.c \ ./src/a68g/modes.c \ ./src/a68g/moid-size.c \ ./src/a68g/moid-to-string.c \ ./src/a68g/monitor.c \ ./src/a68g/mp-bits.c \ ./src/a68g/mp.c \ ./src/a68g/mp-constant.c \ ./src/a68g/mp-gamic.c \ ./src/a68g/mp-gamma.c \ ./src/a68g/mp-genie.c \ ./src/a68g/mp-math.c \ ./src/a68g/mp-mpfr.c \ ./src/a68g/non-terminal.c \ ./src/a68g/options.c \ ./src/a68g/parallel.c \ ./src/a68g/parser.c \ ./src/a68g/physics.c \ ./src/a68g/plotutils.c \ ./src/a68g/postgresql.c \ ./src/a68g/postulates.c \ ./src/a68g/prelude-bits.c \ ./src/a68g/prelude.c \ ./src/a68g/prelude-gsl.c \ ./src/a68g/prelude-mathlib.c \ ./src/a68g/pretty.c \ ./src/a68g/refinement.c \ ./src/a68g/regex.c \ ./src/a68g/rows.c \ ./src/a68g/scanner.c \ ./src/a68g/scope.c \ ./src/a68g/script.c \ ./src/a68g/single.c \ ./src/a68g/single-gamic.c \ ./src/a68g/single-gsl.c \ ./src/a68g/single-math.c \ ./src/a68g/single-mathlib.c \ ./src/a68g/single-rnd.c \ ./src/a68g/socket.c \ ./src/a68g/sounds.c \ ./src/a68g/taxes.c \ ./src/a68g/top-down.c \ ./src/a68g/torrix.c \ ./src/a68g/transput.c \ ./src/a68g/unix.c \ ./src/a68g/victal.c \ ./src/include/a68g-common.h \ ./src/include/a68g-compiler.h \ ./src/include/a68g-config.win32.h \ ./src/include/a68g-defines.h \ ./src/include/a68g-diagnostics.h \ ./src/include/a68g-double.h \ ./src/include/a68g-enums.h \ ./src/include/a68g-environ.h \ ./src/include/a68g-frames.h \ ./src/include/a68g-generic.h \ ./src/include/a68g-genie.h \ ./src/include/a68g.h \ ./src/include/a68g-includes.h \ ./src/include/a68g-level-3.h \ ./src/include/a68g-lib.h \ ./src/include/a68g-listing.h \ ./src/include/a68g-masks.h \ ./src/include/a68g-math.h \ ./src/include/a68g-mp.h \ ./src/include/a68g-nil.h \ ./src/include/a68g-numbers.h \ ./src/include/a68g-optimiser.h \ ./src/include/a68g-options.h \ ./src/include/a68g-parser.h \ ./src/include/a68g-physics.h \ ./src/include/a68g-platform.h \ ./src/include/a68g-postulates.h \ ./src/include/a68g-prelude-gsl.h \ ./src/include/a68g-prelude.h \ ./src/include/a68g-prelude-mathlib.h \ ./src/include/a68g-stack.h \ ./src/include/a68g-stddef.h \ ./src/include/a68g-transput.h \ ./src/include/a68g-types.h pkginclude_HEADERS = \ ./a68g-config.h \ ./src/include/a68g-common.h \ ./src/include/a68g-compiler.h \ ./src/include/a68g-config.win32.h \ ./src/include/a68g-defines.h \ ./src/include/a68g-diagnostics.h \ ./src/include/a68g-double.h \ ./src/include/a68g-enums.h \ ./src/include/a68g-environ.h \ ./src/include/a68g-frames.h \ ./src/include/a68g-generic.h \ ./src/include/a68g-genie.h \ ./src/include/a68g.h \ ./src/include/a68g-includes.h \ ./src/include/a68g-level-3.h \ ./src/include/a68g-lib.h \ ./src/include/a68g-listing.h \ ./src/include/a68g-masks.h \ ./src/include/a68g-math.h \ ./src/include/a68g-mp.h \ ./src/include/a68g-nil.h \ ./src/include/a68g-numbers.h \ ./src/include/a68g-optimiser.h \ ./src/include/a68g-options.h \ ./src/include/a68g-parser.h \ ./src/include/a68g-physics.h \ ./src/include/a68g-platform.h \ ./src/include/a68g-postulates.h \ ./src/include/a68g-prelude-gsl.h \ ./src/include/a68g-prelude.h \ ./src/include/a68g-prelude-mathlib.h \ ./src/include/a68g-stack.h \ ./src/include/a68g-stddef.h \ ./src/include/a68g-transput.h \ ./src/include/a68g-types.h bin_PROGRAMS = a68g a68g_CFLAGS = -DBINDIR='"$(bindir)"' -DINCLUDEDIR='"$(includedir)"' a68g_CPPFLAGS = -I$(top_srcdir)/src/include TESTS_ENVIRONMENT=./a68g TESTS=\ test-set/01-chaos.a68\ test-set/02-decision.a68\ test-set/03-digits.a68\ test-set/04-end-of-time.a68\ test-set/05-fft.a68\ test-set/06-fibonacci-grammar.a68\ test-set/07-formula-manipulation.a68\ test-set/08-guldens.a68\ test-set/09-hamming.a68\ test-set/10-hilbert.a68\ test-set/11-lisp.a68\ test-set/12-mandelbrot.a68\ test-set/13-mastermind.a68\ test-set/14-math.a68\ test-set/15-mersenne.a68\ test-set/16-procedures.a68\ test-set/17-pseudo-switch.a68\ test-set/18-qgammainc.a68\ test-set/19-queens.a68\ test-set/20-quicksort.a68\ test-set/21-rationals.a68\ test-set/22-semana-santa.a68\ test-set/23-tukey.a68\ test-set/24-whetstones.a68 if EXPORT_DYNAMIC a68g_LDFLAGS = -Wl,--export-dynamic else a68g_LDFLAGS = endif man_MANS = doc/a68g.1 docdir = @docdir@ doc_DATA = AUTHORS COPYING ChangeLog NEWS README EXTRA_DIST = $(man_MANS)\ $(TESTS) algol68g-3.1.2/README0000644000175000017500000000637614361065322010757 00000000000000This file is part of Algol 68 Genie - an Algol 68 compiler-interpreter. Copyright 2001-2023 J. Marcel van der Veer . ALGOL68G - ALGOL 68 GENIE Algol68G is an implementation of Algol 68 as defined by the Revised Report. 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 ranking 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, * optionally, many procedures from R mathlib or the GNU Scientific Library, * a gdb-style debugger and a pretty-printer to beautify source code, * optional linkage to GNU MPFR, GNU plotutils or PostgreSQL, * extensions as UNIX pipes, regular expression matching. 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, go to algol68g-VERSION's directory and start bin\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 [sudo] make install Algol 68 Genie can link to the GNU Scientific Library, plotlib from GNU plotutils, R mathlib, GNU MPFR and libpq from PostgreSQL. Libraries not available on your platform are graciously ignored.