algol68g-2.4.1/0000777000175000001440000000000011771660256010155 500000000000000algol68g-2.4.1/configure0000755000175000001440000405212311771657112012004 00000000000000#! /bin/sh # Guess values for system-dependent variables and create Makefiles. # Generated by GNU Autoconf 2.63 for algol68g 2.4.1. # # Report bugs to >. # # Copyright (C) 1992, 1993, 1994, 1995, 1996, 1998, 1999, 2000, 2001, # 2002, 2003, 2004, 2005, 2006, 2007, 2008 Free Software Foundation, Inc. # This configure script is free software; the Free Software Foundation # gives unlimited permission to copy, distribute and modify it. ## --------------------- ## ## M4sh Initialization. ## ## --------------------- ## # Be more Bourne compatible DUALCASE=1; export DUALCASE # for MKS sh if test -n "${ZSH_VERSION+set}" && (emulate sh) >/dev/null 2>&1; then emulate sh NULLCMD=: # Pre-4.2 versions of Zsh do word splitting on ${1+"$@"}, which # is contrary to our usage. Disable this feature. alias -g '${1+"$@"}'='"$@"' setopt NO_GLOB_SUBST else case `(set -o) 2>/dev/null` in *posix*) set -o posix ;; esac fi # PATH needs CR # Avoid depending upon Character Ranges. as_cr_letters='abcdefghijklmnopqrstuvwxyz' as_cr_LETTERS='ABCDEFGHIJKLMNOPQRSTUVWXYZ' as_cr_Letters=$as_cr_letters$as_cr_LETTERS as_cr_digits='0123456789' as_cr_alnum=$as_cr_Letters$as_cr_digits as_nl=' ' export as_nl # Printing a long string crashes Solaris 7 /usr/bin/printf. as_echo='\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\' as_echo=$as_echo$as_echo$as_echo$as_echo$as_echo as_echo=$as_echo$as_echo$as_echo$as_echo$as_echo$as_echo if (test "X`printf %s $as_echo`" = "X$as_echo") 2>/dev/null; then as_echo='printf %s\n' as_echo_n='printf %s' else if test "X`(/usr/ucb/echo -n -n $as_echo) 2>/dev/null`" = "X-n $as_echo"; then as_echo_body='eval /usr/ucb/echo -n "$1$as_nl"' as_echo_n='/usr/ucb/echo -n' else as_echo_body='eval expr "X$1" : "X\\(.*\\)"' as_echo_n_body='eval arg=$1; case $arg in *"$as_nl"*) expr "X$arg" : "X\\(.*\\)$as_nl"; arg=`expr "X$arg" : ".*$as_nl\\(.*\\)"`;; esac; expr "X$arg" : "X\\(.*\\)" | tr -d "$as_nl" ' export as_echo_n_body as_echo_n='sh -c $as_echo_n_body as_echo' fi export as_echo_body as_echo='sh -c $as_echo_body as_echo' fi # The user is always right. if test "${PATH_SEPARATOR+set}" != set; then PATH_SEPARATOR=: (PATH='/bin;/bin'; FPATH=$PATH; sh -c :) >/dev/null 2>&1 && { (PATH='/bin:/bin'; FPATH=$PATH; sh -c :) >/dev/null 2>&1 || PATH_SEPARATOR=';' } fi # Support unset when possible. if ( (MAIL=60; unset MAIL) || exit) >/dev/null 2>&1; then as_unset=unset else as_unset=false fi # IFS # We need space, tab and new line, in precisely that order. Quoting is # there to prevent editors from complaining about space-tab. # (If _AS_PATH_WALK were called with IFS unset, it would disable word # splitting by setting IFS to empty value.) IFS=" "" $as_nl" # Find who we are. Look in the path if we contain no directory separator. case $0 in *[\\/]* ) as_myself=$0 ;; *) as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. test -r "$as_dir/$0" && as_myself=$as_dir/$0 && break done IFS=$as_save_IFS ;; esac # We did not find ourselves, most probably we were run as `sh COMMAND' # in which case we are not to be found in the path. if test "x$as_myself" = x; then as_myself=$0 fi if test ! -f "$as_myself"; then $as_echo "$as_myself: error: cannot find myself; rerun with an absolute file name" >&2 { (exit 1); exit 1; } fi # Work around bugs in pre-3.0 UWIN ksh. for as_var in ENV MAIL MAILPATH do ($as_unset $as_var) >/dev/null 2>&1 && $as_unset $as_var done PS1='$ ' PS2='> ' PS4='+ ' # NLS nuisances. LC_ALL=C export LC_ALL LANGUAGE=C export LANGUAGE # Required to use basename. if expr a : '\(a\)' >/dev/null 2>&1 && test "X`expr 00001 : '.*\(...\)'`" = X001; then as_expr=expr else as_expr=false fi if (basename -- /) >/dev/null 2>&1 && test "X`basename -- / 2>&1`" = "X/"; then as_basename=basename else as_basename=false fi # Name of the executable. as_me=`$as_basename -- "$0" || $as_expr X/"$0" : '.*/\([^/][^/]*\)/*$' \| \ X"$0" : 'X\(//\)$' \| \ X"$0" : 'X\(/\)' \| . 2>/dev/null || $as_echo X/"$0" | sed '/^.*\/\([^/][^/]*\)\/*$/{ s//\1/ q } /^X\/\(\/\/\)$/{ s//\1/ q } /^X\/\(\/\).*/{ s//\1/ q } s/.*/./; q'` # CDPATH. $as_unset CDPATH if test "x$CONFIG_SHELL" = x; then if (eval ":") 2>/dev/null; then as_have_required=yes else as_have_required=no fi if test $as_have_required = yes && (eval ": (as_func_return () { (exit \$1) } as_func_success () { as_func_return 0 } as_func_failure () { as_func_return 1 } as_func_ret_success () { return 0 } as_func_ret_failure () { return 1 } exitcode=0 if as_func_success; then : else exitcode=1 echo as_func_success failed. fi if as_func_failure; then exitcode=1 echo as_func_failure succeeded. fi if as_func_ret_success; then : else exitcode=1 echo as_func_ret_success failed. fi if as_func_ret_failure; then exitcode=1 echo as_func_ret_failure succeeded. fi if ( set x; as_func_ret_success y && test x = \"\$1\" ); then : else exitcode=1 echo positional parameters were not saved. fi test \$exitcode = 0) || { (exit 1); exit 1; } ( as_lineno_1=\$LINENO as_lineno_2=\$LINENO test \"x\$as_lineno_1\" != \"x\$as_lineno_2\" && test \"x\`expr \$as_lineno_1 + 1\`\" = \"x\$as_lineno_2\") || { (exit 1); exit 1; } ") 2> /dev/null; then : else as_candidate_shells= as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in /bin$PATH_SEPARATOR/usr/bin$PATH_SEPARATOR$PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. case $as_dir in /*) for as_base in sh bash ksh sh5; do as_candidate_shells="$as_candidate_shells $as_dir/$as_base" done;; esac done IFS=$as_save_IFS for as_shell in $as_candidate_shells $SHELL; do # Try only shells that exist, to save several forks. if { test -f "$as_shell" || test -f "$as_shell.exe"; } && { ("$as_shell") 2> /dev/null <<\_ASEOF if test -n "${ZSH_VERSION+set}" && (emulate sh) >/dev/null 2>&1; then emulate sh NULLCMD=: # Pre-4.2 versions of Zsh do word splitting on ${1+"$@"}, which # is contrary to our usage. Disable this feature. alias -g '${1+"$@"}'='"$@"' setopt NO_GLOB_SUBST else case `(set -o) 2>/dev/null` in *posix*) set -o posix ;; esac fi : _ASEOF }; then CONFIG_SHELL=$as_shell as_have_required=yes if { "$as_shell" 2> /dev/null <<\_ASEOF if test -n "${ZSH_VERSION+set}" && (emulate sh) >/dev/null 2>&1; then emulate sh NULLCMD=: # Pre-4.2 versions of Zsh do word splitting on ${1+"$@"}, which # is contrary to our usage. Disable this feature. alias -g '${1+"$@"}'='"$@"' setopt NO_GLOB_SUBST else case `(set -o) 2>/dev/null` in *posix*) set -o posix ;; esac fi : (as_func_return () { (exit $1) } as_func_success () { as_func_return 0 } as_func_failure () { as_func_return 1 } as_func_ret_success () { return 0 } as_func_ret_failure () { return 1 } exitcode=0 if as_func_success; then : else exitcode=1 echo as_func_success failed. fi if as_func_failure; then exitcode=1 echo as_func_failure succeeded. fi if as_func_ret_success; then : else exitcode=1 echo as_func_ret_success failed. fi if as_func_ret_failure; then exitcode=1 echo as_func_ret_failure succeeded. fi if ( set x; as_func_ret_success y && test x = "$1" ); then : else exitcode=1 echo positional parameters were not saved. fi test $exitcode = 0) || { (exit 1); exit 1; } ( as_lineno_1=$LINENO as_lineno_2=$LINENO test "x$as_lineno_1" != "x$as_lineno_2" && test "x`expr $as_lineno_1 + 1`" = "x$as_lineno_2") || { (exit 1); exit 1; } _ASEOF }; then break fi fi done if test "x$CONFIG_SHELL" != x; then for as_var in BASH_ENV ENV do ($as_unset $as_var) >/dev/null 2>&1 && $as_unset $as_var done export CONFIG_SHELL exec "$CONFIG_SHELL" "$as_myself" ${1+"$@"} fi if test $as_have_required = no; then echo This script requires a shell more modern than all the echo shells that I found on your system. Please install a echo modern shell, or manually run the script under such a echo shell if you do have one. { (exit 1); exit 1; } fi fi fi (eval "as_func_return () { (exit \$1) } as_func_success () { as_func_return 0 } as_func_failure () { as_func_return 1 } as_func_ret_success () { return 0 } as_func_ret_failure () { return 1 } exitcode=0 if as_func_success; then : else exitcode=1 echo as_func_success failed. fi if as_func_failure; then exitcode=1 echo as_func_failure succeeded. fi if as_func_ret_success; then : else exitcode=1 echo as_func_ret_success failed. fi if as_func_ret_failure; then exitcode=1 echo as_func_ret_failure succeeded. fi if ( set x; as_func_ret_success y && test x = \"\$1\" ); then : else exitcode=1 echo positional parameters were not saved. fi test \$exitcode = 0") || { echo No shell found that supports shell functions. echo Please tell bug-autoconf@gnu.org about your system, echo including any error possibly output before this message. echo This can help us improve future autoconf versions. echo Configuration will now proceed without shell functions. } as_lineno_1=$LINENO as_lineno_2=$LINENO test "x$as_lineno_1" != "x$as_lineno_2" && test "x`expr $as_lineno_1 + 1`" = "x$as_lineno_2" || { # Create $as_me.lineno as a copy of $as_myself, but with $LINENO # uniformly replaced by the line number. The first 'sed' inserts a # line-number line after each line using $LINENO; the second 'sed' # does the real work. The second script uses 'N' to pair each # line-number line with the line containing $LINENO, and appends # trailing '-' during substitution so that $LINENO is not a special # case at line end. # (Raja R Harinath suggested sed '=', and Paul Eggert wrote the # scripts with optimization help from Paolo Bonzini. Blame Lee # E. McMahon (1931-1989) for sed's syntax. :-) sed -n ' p /[$]LINENO/= ' <$as_myself | sed ' s/[$]LINENO.*/&-/ t lineno b :lineno N :loop s/[$]LINENO\([^'$as_cr_alnum'_].*\n\)\(.*\)/\2\1\2/ t loop s/-\n.*// ' >$as_me.lineno && chmod +x "$as_me.lineno" || { $as_echo "$as_me: error: cannot create $as_me.lineno; rerun with a POSIX shell" >&2 { (exit 1); exit 1; }; } # Don't try to exec as it changes $[0], causing all sort of problems # (the dirname of $[0] is not the place where we might find the # original and so on. Autoconf is especially sensitive to this). . "./$as_me.lineno" # Exit status is that of the last command. exit } if (as_dir=`dirname -- /` && test "X$as_dir" = X/) >/dev/null 2>&1; then as_dirname=dirname else as_dirname=false fi ECHO_C= ECHO_N= ECHO_T= case `echo -n x` in -n*) case `echo 'x\c'` in *c*) ECHO_T=' ';; # ECHO_T is single tab character. *) ECHO_C='\c';; esac;; *) ECHO_N='-n';; esac if expr a : '\(a\)' >/dev/null 2>&1 && test "X`expr 00001 : '.*\(...\)'`" = X001; then as_expr=expr else as_expr=false fi rm -f conf$$ conf$$.exe conf$$.file if test -d conf$$.dir; then rm -f conf$$.dir/conf$$.file else rm -f conf$$.dir mkdir conf$$.dir 2>/dev/null fi if (echo >conf$$.file) 2>/dev/null; then if ln -s conf$$.file conf$$ 2>/dev/null; then as_ln_s='ln -s' # ... but there are two gotchas: # 1) On MSYS, both `ln -s file dir' and `ln file dir' fail. # 2) DJGPP < 2.04 has no symlinks; `ln -s' creates a wrapper executable. # In both cases, we have to default to `cp -p'. ln -s conf$$.file conf$$.dir 2>/dev/null && test ! -f conf$$.exe || as_ln_s='cp -p' elif ln conf$$.file conf$$ 2>/dev/null; then as_ln_s=ln else as_ln_s='cp -p' fi else as_ln_s='cp -p' fi rm -f conf$$ conf$$.exe conf$$.dir/conf$$.file conf$$.file rmdir conf$$.dir 2>/dev/null if mkdir -p . 2>/dev/null; then as_mkdir_p=: else test -d ./-p && rmdir ./-p as_mkdir_p=false fi if test -x / >/dev/null 2>&1; then as_test_x='test -x' else if ls -dL / >/dev/null 2>&1; then as_ls_L_option=L else as_ls_L_option= fi as_test_x=' eval sh -c '\'' if test -d "$1"; then test -d "$1/."; else case $1 in -*)set "./$1";; esac; case `ls -ld'$as_ls_L_option' "$1" 2>/dev/null` in ???[sx]*):;;*)false;;esac;fi '\'' sh ' fi as_executable_p=$as_test_x # Sed expression to map a string onto a valid CPP name. as_tr_cpp="eval sed 'y%*$as_cr_letters%P$as_cr_LETTERS%;s%[^_$as_cr_alnum]%_%g'" # Sed expression to map a string onto a valid variable name. as_tr_sh="eval sed 'y%*+%pp%;s%[^_$as_cr_alnum]%_%g'" exec 7<&0 &1 # Name of the host. # hostname on some systems (SVR3.2, Linux) returns a bogus exit status, # so uname gets run too. ac_hostname=`(hostname || uname -n) 2>/dev/null | sed 1q` # # Initializations. # ac_default_prefix=/usr/local ac_clean_files= ac_config_libobj_dir=. LIBOBJS= cross_compiling=no subdirs= MFLAGS= MAKEFLAGS= SHELL=${CONFIG_SHELL-/bin/sh} # Identity of this package. PACKAGE_NAME='algol68g' PACKAGE_TARNAME='algol68g' PACKAGE_VERSION='2.4.1' PACKAGE_STRING='algol68g 2.4.1' PACKAGE_BUGREPORT='Marcel van der Veer ' ac_default_prefix=/usr/local ac_unique_file="source/a68g.h" # Factoring default headers for most tests. ac_includes_default="\ #include #ifdef HAVE_SYS_TYPES_H # include #endif #ifdef HAVE_SYS_STAT_H # include #endif #ifdef STDC_HEADERS # include # include #else # ifdef HAVE_STDLIB_H # include # endif #endif #ifdef HAVE_STRING_H # if !defined STDC_HEADERS && defined HAVE_MEMORY_H # include # endif # include #endif #ifdef HAVE_STRINGS_H # include #endif #ifdef HAVE_INTTYPES_H # include #endif #ifdef HAVE_STDINT_H # include #endif #ifdef HAVE_UNISTD_H # include #endif" ac_subst_vars='LTLIBOBJS LIBOBJS EGREP GREP CPP EXPORT_DYNAMIC_FALSE EXPORT_DYNAMIC_TRUE am__fastdepCC_FALSE am__fastdepCC_TRUE CCDEPMODE AMDEPBACKSLASH AMDEP_FALSE AMDEP_TRUE am__quote am__include DEPDIR OBJEXT EXEEXT ac_ct_CC CPPFLAGS LDFLAGS CFLAGS CC a68g_exists am__untar am__tar AMTAR am__leading_dot SET_MAKE AWK mkdir_p MKDIR_P INSTALL_STRIP_PROGRAM STRIP install_sh MAKEINFO AUTOHEADER AUTOMAKE AUTOCONF ACLOCAL VERSION PACKAGE CYGPATH_W am__isrc INSTALL_DATA INSTALL_SCRIPT INSTALL_PROGRAM target_os target_vendor target_cpu target host_os host_vendor host_cpu host build_os build_vendor build_cpu build target_alias host_alias build_alias LIBS ECHO_T ECHO_N ECHO_C DEFS mandir localedir libdir psdir pdfdir dvidir htmldir infodir docdir oldincludedir includedir localstatedir sharedstatedir sysconfdir datadir datarootdir libexecdir sbindir bindir program_transform_name prefix exec_prefix PACKAGE_BUGREPORT PACKAGE_STRING PACKAGE_VERSION PACKAGE_TARNAME PACKAGE_NAME PATH_SEPARATOR SHELL' ac_subst_files='' ac_user_opts=' enable_option_checking enable_arch enable_compiler enable_curses enable_readline enable_gsl enable_parallel enable_pic enable_prescott enable_plotutils enable_postgresql enable_dependency_tracking enable_assert ' ac_precious_vars='build_alias host_alias target_alias CC CFLAGS LDFLAGS LIBS CPPFLAGS CPP' # Initialize some variables set by options. ac_init_help= ac_init_version=false ac_unrecognized_opts= ac_unrecognized_sep= # The variables have the same names as the options, with # dashes changed to underlines. cache_file=/dev/null exec_prefix=NONE no_create= no_recursion= prefix=NONE program_prefix=NONE program_suffix=NONE program_transform_name=s,x,x, silent= site= srcdir= verbose= x_includes=NONE x_libraries=NONE # Installation directory options. # These are left unexpanded so users can "make install exec_prefix=/foo" # and all the variables that are supposed to be based on exec_prefix # by default will actually change. # Use braces instead of parens because sh, perl, etc. also accept them. # (The list follows the same order as the GNU Coding Standards.) bindir='${exec_prefix}/bin' sbindir='${exec_prefix}/sbin' libexecdir='${exec_prefix}/libexec' datarootdir='${prefix}/share' datadir='${datarootdir}' sysconfdir='${prefix}/etc' sharedstatedir='${prefix}/com' localstatedir='${prefix}/var' includedir='${prefix}/include' oldincludedir='/usr/include' docdir='${datarootdir}/doc/${PACKAGE_TARNAME}' infodir='${datarootdir}/info' htmldir='${docdir}' dvidir='${docdir}' pdfdir='${docdir}' psdir='${docdir}' libdir='${exec_prefix}/lib' localedir='${datarootdir}/locale' mandir='${datarootdir}/man' ac_prev= ac_dashdash= for ac_option do # If the previous option needs an argument, assign it. if test -n "$ac_prev"; then eval $ac_prev=\$ac_option ac_prev= continue fi case $ac_option in *=*) ac_optarg=`expr "X$ac_option" : '[^=]*=\(.*\)'` ;; *) ac_optarg=yes ;; esac # Accept the important Cygnus configure options, so we can diagnose typos. case $ac_dashdash$ac_option in --) ac_dashdash=yes ;; -bindir | --bindir | --bindi | --bind | --bin | --bi) ac_prev=bindir ;; -bindir=* | --bindir=* | --bindi=* | --bind=* | --bin=* | --bi=*) bindir=$ac_optarg ;; -build | --build | --buil | --bui | --bu) ac_prev=build_alias ;; -build=* | --build=* | --buil=* | --bui=* | --bu=*) build_alias=$ac_optarg ;; -cache-file | --cache-file | --cache-fil | --cache-fi \ | --cache-f | --cache- | --cache | --cach | --cac | --ca | --c) ac_prev=cache_file ;; -cache-file=* | --cache-file=* | --cache-fil=* | --cache-fi=* \ | --cache-f=* | --cache-=* | --cache=* | --cach=* | --cac=* | --ca=* | --c=*) cache_file=$ac_optarg ;; --config-cache | -C) cache_file=config.cache ;; -datadir | --datadir | --datadi | --datad) ac_prev=datadir ;; -datadir=* | --datadir=* | --datadi=* | --datad=*) datadir=$ac_optarg ;; -datarootdir | --datarootdir | --datarootdi | --datarootd | --dataroot \ | --dataroo | --dataro | --datar) ac_prev=datarootdir ;; -datarootdir=* | --datarootdir=* | --datarootdi=* | --datarootd=* \ | --dataroot=* | --dataroo=* | --dataro=* | --datar=*) datarootdir=$ac_optarg ;; -disable-* | --disable-*) ac_useropt=`expr "x$ac_option" : 'x-*disable-\(.*\)'` # Reject names that are not valid shell variable names. expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null && { $as_echo "$as_me: error: invalid feature name: $ac_useropt" >&2 { (exit 1); exit 1; }; } ac_useropt_orig=$ac_useropt ac_useropt=`$as_echo "$ac_useropt" | sed 's/[-+.]/_/g'` case $ac_user_opts in *" "enable_$ac_useropt" "*) ;; *) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--disable-$ac_useropt_orig" ac_unrecognized_sep=', ';; esac eval enable_$ac_useropt=no ;; -docdir | --docdir | --docdi | --doc | --do) ac_prev=docdir ;; -docdir=* | --docdir=* | --docdi=* | --doc=* | --do=*) docdir=$ac_optarg ;; -dvidir | --dvidir | --dvidi | --dvid | --dvi | --dv) ac_prev=dvidir ;; -dvidir=* | --dvidir=* | --dvidi=* | --dvid=* | --dvi=* | --dv=*) dvidir=$ac_optarg ;; -enable-* | --enable-*) ac_useropt=`expr "x$ac_option" : 'x-*enable-\([^=]*\)'` # Reject names that are not valid shell variable names. expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null && { $as_echo "$as_me: error: invalid feature name: $ac_useropt" >&2 { (exit 1); exit 1; }; } ac_useropt_orig=$ac_useropt ac_useropt=`$as_echo "$ac_useropt" | sed 's/[-+.]/_/g'` case $ac_user_opts in *" "enable_$ac_useropt" "*) ;; *) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--enable-$ac_useropt_orig" ac_unrecognized_sep=', ';; esac eval enable_$ac_useropt=\$ac_optarg ;; -exec-prefix | --exec_prefix | --exec-prefix | --exec-prefi \ | --exec-pref | --exec-pre | --exec-pr | --exec-p | --exec- \ | --exec | --exe | --ex) ac_prev=exec_prefix ;; -exec-prefix=* | --exec_prefix=* | --exec-prefix=* | --exec-prefi=* \ | --exec-pref=* | --exec-pre=* | --exec-pr=* | --exec-p=* | --exec-=* \ | --exec=* | --exe=* | --ex=*) exec_prefix=$ac_optarg ;; -gas | --gas | --ga | --g) # Obsolete; use --with-gas. with_gas=yes ;; -help | --help | --hel | --he | -h) ac_init_help=long ;; -help=r* | --help=r* | --hel=r* | --he=r* | -hr*) ac_init_help=recursive ;; -help=s* | --help=s* | --hel=s* | --he=s* | -hs*) ac_init_help=short ;; -host | --host | --hos | --ho) ac_prev=host_alias ;; -host=* | --host=* | --hos=* | --ho=*) host_alias=$ac_optarg ;; -htmldir | --htmldir | --htmldi | --htmld | --html | --htm | --ht) ac_prev=htmldir ;; -htmldir=* | --htmldir=* | --htmldi=* | --htmld=* | --html=* | --htm=* \ | --ht=*) htmldir=$ac_optarg ;; -includedir | --includedir | --includedi | --included | --include \ | --includ | --inclu | --incl | --inc) ac_prev=includedir ;; -includedir=* | --includedir=* | --includedi=* | --included=* | --include=* \ | --includ=* | --inclu=* | --incl=* | --inc=*) includedir=$ac_optarg ;; -infodir | --infodir | --infodi | --infod | --info | --inf) ac_prev=infodir ;; -infodir=* | --infodir=* | --infodi=* | --infod=* | --info=* | --inf=*) infodir=$ac_optarg ;; -libdir | --libdir | --libdi | --libd) ac_prev=libdir ;; -libdir=* | --libdir=* | --libdi=* | --libd=*) libdir=$ac_optarg ;; -libexecdir | --libexecdir | --libexecdi | --libexecd | --libexec \ | --libexe | --libex | --libe) ac_prev=libexecdir ;; -libexecdir=* | --libexecdir=* | --libexecdi=* | --libexecd=* | --libexec=* \ | --libexe=* | --libex=* | --libe=*) libexecdir=$ac_optarg ;; -localedir | --localedir | --localedi | --localed | --locale) ac_prev=localedir ;; -localedir=* | --localedir=* | --localedi=* | --localed=* | --locale=*) localedir=$ac_optarg ;; -localstatedir | --localstatedir | --localstatedi | --localstated \ | --localstate | --localstat | --localsta | --localst | --locals) ac_prev=localstatedir ;; -localstatedir=* | --localstatedir=* | --localstatedi=* | --localstated=* \ | --localstate=* | --localstat=* | --localsta=* | --localst=* | --locals=*) localstatedir=$ac_optarg ;; -mandir | --mandir | --mandi | --mand | --man | --ma | --m) ac_prev=mandir ;; -mandir=* | --mandir=* | --mandi=* | --mand=* | --man=* | --ma=* | --m=*) mandir=$ac_optarg ;; -nfp | --nfp | --nf) # Obsolete; use --without-fp. with_fp=no ;; -no-create | --no-create | --no-creat | --no-crea | --no-cre \ | --no-cr | --no-c | -n) no_create=yes ;; -no-recursion | --no-recursion | --no-recursio | --no-recursi \ | --no-recurs | --no-recur | --no-recu | --no-rec | --no-re | --no-r) no_recursion=yes ;; -oldincludedir | --oldincludedir | --oldincludedi | --oldincluded \ | --oldinclude | --oldinclud | --oldinclu | --oldincl | --oldinc \ | --oldin | --oldi | --old | --ol | --o) ac_prev=oldincludedir ;; -oldincludedir=* | --oldincludedir=* | --oldincludedi=* | --oldincluded=* \ | --oldinclude=* | --oldinclud=* | --oldinclu=* | --oldincl=* | --oldinc=* \ | --oldin=* | --oldi=* | --old=* | --ol=* | --o=*) oldincludedir=$ac_optarg ;; -prefix | --prefix | --prefi | --pref | --pre | --pr | --p) ac_prev=prefix ;; -prefix=* | --prefix=* | --prefi=* | --pref=* | --pre=* | --pr=* | --p=*) prefix=$ac_optarg ;; -program-prefix | --program-prefix | --program-prefi | --program-pref \ | --program-pre | --program-pr | --program-p) ac_prev=program_prefix ;; -program-prefix=* | --program-prefix=* | --program-prefi=* \ | --program-pref=* | --program-pre=* | --program-pr=* | --program-p=*) program_prefix=$ac_optarg ;; -program-suffix | --program-suffix | --program-suffi | --program-suff \ | --program-suf | --program-su | --program-s) ac_prev=program_suffix ;; -program-suffix=* | --program-suffix=* | --program-suffi=* \ | --program-suff=* | --program-suf=* | --program-su=* | --program-s=*) program_suffix=$ac_optarg ;; -program-transform-name | --program-transform-name \ | --program-transform-nam | --program-transform-na \ | --program-transform-n | --program-transform- \ | --program-transform | --program-transfor \ | --program-transfo | --program-transf \ | --program-trans | --program-tran \ | --progr-tra | --program-tr | --program-t) ac_prev=program_transform_name ;; -program-transform-name=* | --program-transform-name=* \ | --program-transform-nam=* | --program-transform-na=* \ | --program-transform-n=* | --program-transform-=* \ | --program-transform=* | --program-transfor=* \ | --program-transfo=* | --program-transf=* \ | --program-trans=* | --program-tran=* \ | --progr-tra=* | --program-tr=* | --program-t=*) program_transform_name=$ac_optarg ;; -pdfdir | --pdfdir | --pdfdi | --pdfd | --pdf | --pd) ac_prev=pdfdir ;; -pdfdir=* | --pdfdir=* | --pdfdi=* | --pdfd=* | --pdf=* | --pd=*) pdfdir=$ac_optarg ;; -psdir | --psdir | --psdi | --psd | --ps) ac_prev=psdir ;; -psdir=* | --psdir=* | --psdi=* | --psd=* | --ps=*) psdir=$ac_optarg ;; -q | -quiet | --quiet | --quie | --qui | --qu | --q \ | -silent | --silent | --silen | --sile | --sil) silent=yes ;; -sbindir | --sbindir | --sbindi | --sbind | --sbin | --sbi | --sb) ac_prev=sbindir ;; -sbindir=* | --sbindir=* | --sbindi=* | --sbind=* | --sbin=* \ | --sbi=* | --sb=*) sbindir=$ac_optarg ;; -sharedstatedir | --sharedstatedir | --sharedstatedi \ | --sharedstated | --sharedstate | --sharedstat | --sharedsta \ | --sharedst | --shareds | --shared | --share | --shar \ | --sha | --sh) ac_prev=sharedstatedir ;; -sharedstatedir=* | --sharedstatedir=* | --sharedstatedi=* \ | --sharedstated=* | --sharedstate=* | --sharedstat=* | --sharedsta=* \ | --sharedst=* | --shareds=* | --shared=* | --share=* | --shar=* \ | --sha=* | --sh=*) sharedstatedir=$ac_optarg ;; -site | --site | --sit) ac_prev=site ;; -site=* | --site=* | --sit=*) site=$ac_optarg ;; -srcdir | --srcdir | --srcdi | --srcd | --src | --sr) ac_prev=srcdir ;; -srcdir=* | --srcdir=* | --srcdi=* | --srcd=* | --src=* | --sr=*) srcdir=$ac_optarg ;; -sysconfdir | --sysconfdir | --sysconfdi | --sysconfd | --sysconf \ | --syscon | --sysco | --sysc | --sys | --sy) ac_prev=sysconfdir ;; -sysconfdir=* | --sysconfdir=* | --sysconfdi=* | --sysconfd=* | --sysconf=* \ | --syscon=* | --sysco=* | --sysc=* | --sys=* | --sy=*) sysconfdir=$ac_optarg ;; -target | --target | --targe | --targ | --tar | --ta | --t) ac_prev=target_alias ;; -target=* | --target=* | --targe=* | --targ=* | --tar=* | --ta=* | --t=*) target_alias=$ac_optarg ;; -v | -verbose | --verbose | --verbos | --verbo | --verb) verbose=yes ;; -version | --version | --versio | --versi | --vers | -V) ac_init_version=: ;; -with-* | --with-*) ac_useropt=`expr "x$ac_option" : 'x-*with-\([^=]*\)'` # Reject names that are not valid shell variable names. expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null && { $as_echo "$as_me: error: invalid package name: $ac_useropt" >&2 { (exit 1); exit 1; }; } ac_useropt_orig=$ac_useropt ac_useropt=`$as_echo "$ac_useropt" | sed 's/[-+.]/_/g'` case $ac_user_opts in *" "with_$ac_useropt" "*) ;; *) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--with-$ac_useropt_orig" ac_unrecognized_sep=', ';; esac eval with_$ac_useropt=\$ac_optarg ;; -without-* | --without-*) ac_useropt=`expr "x$ac_option" : 'x-*without-\(.*\)'` # Reject names that are not valid shell variable names. expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null && { $as_echo "$as_me: error: invalid package name: $ac_useropt" >&2 { (exit 1); exit 1; }; } ac_useropt_orig=$ac_useropt ac_useropt=`$as_echo "$ac_useropt" | sed 's/[-+.]/_/g'` case $ac_user_opts in *" "with_$ac_useropt" "*) ;; *) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--without-$ac_useropt_orig" ac_unrecognized_sep=', ';; esac eval with_$ac_useropt=no ;; --x) # Obsolete; use --with-x. with_x=yes ;; -x-includes | --x-includes | --x-include | --x-includ | --x-inclu \ | --x-incl | --x-inc | --x-in | --x-i) ac_prev=x_includes ;; -x-includes=* | --x-includes=* | --x-include=* | --x-includ=* | --x-inclu=* \ | --x-incl=* | --x-inc=* | --x-in=* | --x-i=*) x_includes=$ac_optarg ;; -x-libraries | --x-libraries | --x-librarie | --x-librari \ | --x-librar | --x-libra | --x-libr | --x-lib | --x-li | --x-l) ac_prev=x_libraries ;; -x-libraries=* | --x-libraries=* | --x-librarie=* | --x-librari=* \ | --x-librar=* | --x-libra=* | --x-libr=* | --x-lib=* | --x-li=* | --x-l=*) x_libraries=$ac_optarg ;; -*) { $as_echo "$as_me: error: unrecognized option: $ac_option Try \`$0 --help' for more information." >&2 { (exit 1); exit 1; }; } ;; *=*) ac_envvar=`expr "x$ac_option" : 'x\([^=]*\)='` # Reject names that are not valid shell variable names. expr "x$ac_envvar" : ".*[^_$as_cr_alnum]" >/dev/null && { $as_echo "$as_me: error: invalid variable name: $ac_envvar" >&2 { (exit 1); exit 1; }; } eval $ac_envvar=\$ac_optarg export $ac_envvar ;; *) # FIXME: should be removed in autoconf 3.0. $as_echo "$as_me: WARNING: you should use --build, --host, --target" >&2 expr "x$ac_option" : ".*[^-._$as_cr_alnum]" >/dev/null && $as_echo "$as_me: WARNING: invalid host type: $ac_option" >&2 : ${build_alias=$ac_option} ${host_alias=$ac_option} ${target_alias=$ac_option} ;; esac done if test -n "$ac_prev"; then ac_option=--`echo $ac_prev | sed 's/_/-/g'` { $as_echo "$as_me: error: missing argument to $ac_option" >&2 { (exit 1); exit 1; }; } fi if test -n "$ac_unrecognized_opts"; then case $enable_option_checking in no) ;; fatal) { $as_echo "$as_me: error: unrecognized options: $ac_unrecognized_opts" >&2 { (exit 1); exit 1; }; } ;; *) $as_echo "$as_me: WARNING: unrecognized options: $ac_unrecognized_opts" >&2 ;; esac fi # Check all directory arguments for consistency. for ac_var in exec_prefix prefix bindir sbindir libexecdir datarootdir \ datadir sysconfdir sharedstatedir localstatedir includedir \ oldincludedir docdir infodir htmldir dvidir pdfdir psdir \ libdir localedir mandir do eval ac_val=\$$ac_var # Remove trailing slashes. case $ac_val in */ ) ac_val=`expr "X$ac_val" : 'X\(.*[^/]\)' \| "X$ac_val" : 'X\(.*\)'` eval $ac_var=\$ac_val;; esac # Be sure to have absolute directory names. case $ac_val in [\\/$]* | ?:[\\/]* ) continue;; NONE | '' ) case $ac_var in *prefix ) continue;; esac;; esac { $as_echo "$as_me: error: expected an absolute directory name for --$ac_var: $ac_val" >&2 { (exit 1); exit 1; }; } done # There might be people who depend on the old broken behavior: `$host' # used to hold the argument of --host etc. # FIXME: To remove some day. build=$build_alias host=$host_alias target=$target_alias # FIXME: To remove some day. if test "x$host_alias" != x; then if test "x$build_alias" = x; then cross_compiling=maybe $as_echo "$as_me: WARNING: If you wanted to set the --build type, don't use --host. If a cross compiler is detected then cross compile mode will be used." >&2 elif test "x$build_alias" != "x$host_alias"; then cross_compiling=yes fi fi ac_tool_prefix= test -n "$host_alias" && ac_tool_prefix=$host_alias- test "$silent" = yes && exec 6>/dev/null ac_pwd=`pwd` && test -n "$ac_pwd" && ac_ls_di=`ls -di .` && ac_pwd_ls_di=`cd "$ac_pwd" && ls -di .` || { $as_echo "$as_me: error: working directory cannot be determined" >&2 { (exit 1); exit 1; }; } test "X$ac_ls_di" = "X$ac_pwd_ls_di" || { $as_echo "$as_me: error: pwd does not report name of working directory" >&2 { (exit 1); exit 1; }; } # Find the source files, if location was not specified. if test -z "$srcdir"; then ac_srcdir_defaulted=yes # Try the directory containing this script, then the parent directory. ac_confdir=`$as_dirname -- "$as_myself" || $as_expr X"$as_myself" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ X"$as_myself" : 'X\(//\)[^/]' \| \ X"$as_myself" : 'X\(//\)$' \| \ X"$as_myself" : 'X\(/\)' \| . 2>/dev/null || $as_echo X"$as_myself" | sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ s//\1/ q } /^X\(\/\/\)[^/].*/{ s//\1/ q } /^X\(\/\/\)$/{ s//\1/ q } /^X\(\/\).*/{ s//\1/ q } s/.*/./; q'` srcdir=$ac_confdir if test ! -r "$srcdir/$ac_unique_file"; then srcdir=.. fi else ac_srcdir_defaulted=no fi if test ! -r "$srcdir/$ac_unique_file"; then test "$ac_srcdir_defaulted" = yes && srcdir="$ac_confdir or .." { $as_echo "$as_me: error: cannot find sources ($ac_unique_file) in $srcdir" >&2 { (exit 1); exit 1; }; } fi ac_msg="sources are in $srcdir, but \`cd $srcdir' does not work" ac_abs_confdir=`( cd "$srcdir" && test -r "./$ac_unique_file" || { $as_echo "$as_me: error: $ac_msg" >&2 { (exit 1); exit 1; }; } pwd)` # When building in place, set srcdir=. if test "$ac_abs_confdir" = "$ac_pwd"; then srcdir=. fi # Remove unnecessary trailing slashes from srcdir. # Double slashes in file names in object file debugging info # mess up M-x gdb in Emacs. case $srcdir in */) srcdir=`expr "X$srcdir" : 'X\(.*[^/]\)' \| "X$srcdir" : 'X\(.*\)'`;; esac for ac_var in $ac_precious_vars; do eval ac_env_${ac_var}_set=\${${ac_var}+set} eval ac_env_${ac_var}_value=\$${ac_var} eval ac_cv_env_${ac_var}_set=\${${ac_var}+set} eval ac_cv_env_${ac_var}_value=\$${ac_var} done # # Report the --help message. # if test "$ac_init_help" = "long"; then # Omit some internal or obsolete options to make the list less imposing. # This message is too long to be a string in the A/UX 3.1 sh. cat <<_ACEOF \`configure' configures algol68g 2.4.1 to adapt to many kinds of systems. Usage: $0 [OPTION]... [VAR=VALUE]... To assign environment variables (e.g., CC, CFLAGS...), specify them as VAR=VALUE. See below for descriptions of some of the useful variables. Defaults for the options are specified in brackets. Configuration: -h, --help display this help and exit --help=short display options specific to this package --help=recursive display the short help of all the included packages -V, --version display version information and exit -q, --quiet, --silent do not print \`checking...' messages --cache-file=FILE cache test results in FILE [disabled] -C, --config-cache alias for \`--cache-file=config.cache' -n, --no-create do not create output files --srcdir=DIR find the sources in DIR [configure dir or \`..'] Installation directories: --prefix=PREFIX install architecture-independent files in PREFIX [$ac_default_prefix] --exec-prefix=EPREFIX install architecture-dependent files in EPREFIX [PREFIX] By default, \`make install' will install all the files in \`$ac_default_prefix/bin', \`$ac_default_prefix/lib' etc. You can specify an installation prefix other than \`$ac_default_prefix' using \`--prefix', for instance \`--prefix=\$HOME'. For better control, use the options below. Fine tuning of the installation directories: --bindir=DIR user executables [EPREFIX/bin] --sbindir=DIR system admin executables [EPREFIX/sbin] --libexecdir=DIR program executables [EPREFIX/libexec] --sysconfdir=DIR read-only single-machine data [PREFIX/etc] --sharedstatedir=DIR modifiable architecture-independent data [PREFIX/com] --localstatedir=DIR modifiable single-machine data [PREFIX/var] --libdir=DIR object code libraries [EPREFIX/lib] --includedir=DIR C header files [PREFIX/include] --oldincludedir=DIR C header files for non-gcc [/usr/include] --datarootdir=DIR read-only arch.-independent data root [PREFIX/share] --datadir=DIR read-only architecture-independent data [DATAROOTDIR] --infodir=DIR info documentation [DATAROOTDIR/info] --localedir=DIR locale-dependent data [DATAROOTDIR/locale] --mandir=DIR man documentation [DATAROOTDIR/man] --docdir=DIR documentation root [DATAROOTDIR/doc/algol68g] --htmldir=DIR html documentation [DOCDIR] --dvidir=DIR dvi documentation [DOCDIR] --pdfdir=DIR pdf documentation [DOCDIR] --psdir=DIR ps documentation [DOCDIR] _ACEOF cat <<\_ACEOF Program names: --program-prefix=PREFIX prepend PREFIX to installed program names --program-suffix=SUFFIX append SUFFIX to installed program names --program-transform-name=PROGRAM run sed PROGRAM on installed program names System types: --build=BUILD configure for building on BUILD [guessed] --host=HOST cross-compile to build programs to run on HOST [BUILD] --target=TARGET configure for building compilers for TARGET [HOST] _ACEOF fi if test -n "$ac_init_help"; then case $ac_init_help in short | recursive ) echo "Configuration of algol68g 2.4.1:";; esac cat <<\_ACEOF Optional Features: --disable-option-checking ignore unrecognized --enable/--with options --disable-FEATURE do not include FEATURE (same as --enable-FEATURE=no) --enable-FEATURE[=ARG] include FEATURE [ARG=yes] --enable-arch=cpu if using gcc, enable emitting architecture-tuned assembly code (default is "no") --enable-compiler enable unit compiler (default is "yes") --enable-curses if installed, enable curses library (default is "yes") --enable-readline if installed, enable readline library (default is "yes") --enable-gsl if installed, enable GNU Scientific Library (default is "yes") --enable-parallel enable Algol 68 parallel-clause (default is "yes") --enable-pic=option if using gcc, enable option to generate PIC (default is "-fPIC") --enable-prescott if using gcc, enable optimisation for P4 Prescott (default is "no") --enable-plotutils if installed, enable GNU plotting utilities (default is "yes") --enable-postgresql if installed, enable PostgreSQL (default is "yes") --disable-dependency-tracking speeds up one-time build --enable-dependency-tracking do not reject slow dependency extractors --disable-assert turn off assertions Some influential environment variables: CC C compiler command CFLAGS C compiler flags LDFLAGS linker flags, e.g. -L if you have libraries in a nonstandard directory LIBS libraries to pass to the linker, e.g. -l CPPFLAGS C/C++/Objective C preprocessor flags, e.g. -I if you have headers in a nonstandard directory CPP C preprocessor Use these variables to override the choices made by `configure' or to help it to find libraries and programs with nonstandard names/locations. Report bugs to >. _ACEOF ac_status=$? fi if test "$ac_init_help" = "recursive"; then # If there are subdirs, report their specific --help. for ac_dir in : $ac_subdirs_all; do test "x$ac_dir" = x: && continue test -d "$ac_dir" || { cd "$srcdir" && ac_pwd=`pwd` && srcdir=. && test -d "$ac_dir"; } || continue ac_builddir=. case "$ac_dir" in .) ac_dir_suffix= ac_top_builddir_sub=. ac_top_build_prefix= ;; *) ac_dir_suffix=/`$as_echo "$ac_dir" | sed 's|^\.[\\/]||'` # A ".." for each directory in $ac_dir_suffix. ac_top_builddir_sub=`$as_echo "$ac_dir_suffix" | sed 's|/[^\\/]*|/..|g;s|/||'` case $ac_top_builddir_sub in "") ac_top_builddir_sub=. ac_top_build_prefix= ;; *) ac_top_build_prefix=$ac_top_builddir_sub/ ;; esac ;; esac ac_abs_top_builddir=$ac_pwd ac_abs_builddir=$ac_pwd$ac_dir_suffix # for backward compatibility: ac_top_builddir=$ac_top_build_prefix case $srcdir in .) # We are building in place. ac_srcdir=. ac_top_srcdir=$ac_top_builddir_sub ac_abs_top_srcdir=$ac_pwd ;; [\\/]* | ?:[\\/]* ) # Absolute name. ac_srcdir=$srcdir$ac_dir_suffix; ac_top_srcdir=$srcdir ac_abs_top_srcdir=$srcdir ;; *) # Relative name. ac_srcdir=$ac_top_build_prefix$srcdir$ac_dir_suffix ac_top_srcdir=$ac_top_build_prefix$srcdir ac_abs_top_srcdir=$ac_pwd/$srcdir ;; esac ac_abs_srcdir=$ac_abs_top_srcdir$ac_dir_suffix cd "$ac_dir" || { ac_status=$?; continue; } # Check for guested configure. if test -f "$ac_srcdir/configure.gnu"; then echo && $SHELL "$ac_srcdir/configure.gnu" --help=recursive elif test -f "$ac_srcdir/configure"; then echo && $SHELL "$ac_srcdir/configure" --help=recursive else $as_echo "$as_me: WARNING: no configuration information is in $ac_dir" >&2 fi || ac_status=$? cd "$ac_pwd" || { ac_status=$?; break; } done fi test -n "$ac_init_help" && exit $ac_status if $ac_init_version; then cat <<\_ACEOF algol68g configure 2.4.1 generated by GNU Autoconf 2.63 Copyright (C) 1992, 1993, 1994, 1995, 1996, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 Free Software Foundation, Inc. This configure script is free software; the Free Software Foundation gives unlimited permission to copy, distribute and modify it. _ACEOF exit fi cat >config.log <<_ACEOF This file contains any messages produced by compilers while running configure, to aid debugging if configure makes a mistake. It was created by algol68g $as_me 2.4.1, which was generated by GNU Autoconf 2.63. Invocation command line was $ $0 $@ _ACEOF exec 5>>config.log { cat <<_ASUNAME ## --------- ## ## Platform. ## ## --------- ## hostname = `(hostname || uname -n) 2>/dev/null | sed 1q` uname -m = `(uname -m) 2>/dev/null || echo unknown` uname -r = `(uname -r) 2>/dev/null || echo unknown` uname -s = `(uname -s) 2>/dev/null || echo unknown` uname -v = `(uname -v) 2>/dev/null || echo unknown` /usr/bin/uname -p = `(/usr/bin/uname -p) 2>/dev/null || echo unknown` /bin/uname -X = `(/bin/uname -X) 2>/dev/null || echo unknown` /bin/arch = `(/bin/arch) 2>/dev/null || echo unknown` /usr/bin/arch -k = `(/usr/bin/arch -k) 2>/dev/null || echo unknown` /usr/convex/getsysinfo = `(/usr/convex/getsysinfo) 2>/dev/null || echo unknown` /usr/bin/hostinfo = `(/usr/bin/hostinfo) 2>/dev/null || echo unknown` /bin/machine = `(/bin/machine) 2>/dev/null || echo unknown` /usr/bin/oslevel = `(/usr/bin/oslevel) 2>/dev/null || echo unknown` /bin/universe = `(/bin/universe) 2>/dev/null || echo unknown` _ASUNAME as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. $as_echo "PATH: $as_dir" done IFS=$as_save_IFS } >&5 cat >&5 <<_ACEOF ## ----------- ## ## Core tests. ## ## ----------- ## _ACEOF # Keep a trace of the command line. # Strip out --no-create and --no-recursion so they do not pile up. # Strip out --silent because we don't want to record it for future runs. # Also quote any args containing shell meta-characters. # Make two passes to allow for proper duplicate-argument suppression. ac_configure_args= ac_configure_args0= ac_configure_args1= ac_must_keep_next=false for ac_pass in 1 2 do for ac_arg do case $ac_arg in -no-create | --no-c* | -n | -no-recursion | --no-r*) continue ;; -q | -quiet | --quiet | --quie | --qui | --qu | --q \ | -silent | --silent | --silen | --sile | --sil) continue ;; *\'*) ac_arg=`$as_echo "$ac_arg" | sed "s/'/'\\\\\\\\''/g"` ;; esac case $ac_pass in 1) ac_configure_args0="$ac_configure_args0 '$ac_arg'" ;; 2) ac_configure_args1="$ac_configure_args1 '$ac_arg'" if test $ac_must_keep_next = true; then ac_must_keep_next=false # Got value, back to normal. else case $ac_arg in *=* | --config-cache | -C | -disable-* | --disable-* \ | -enable-* | --enable-* | -gas | --g* | -nfp | --nf* \ | -q | -quiet | --q* | -silent | --sil* | -v | -verb* \ | -with-* | --with-* | -without-* | --without-* | --x) case "$ac_configure_args0 " in "$ac_configure_args1"*" '$ac_arg' "* ) continue ;; esac ;; -* ) ac_must_keep_next=true ;; esac fi ac_configure_args="$ac_configure_args '$ac_arg'" ;; esac done done $as_unset ac_configure_args0 || test "${ac_configure_args0+set}" != set || { ac_configure_args0=; export ac_configure_args0; } $as_unset ac_configure_args1 || test "${ac_configure_args1+set}" != set || { ac_configure_args1=; export ac_configure_args1; } # When interrupted or exit'd, cleanup temporary files, and complete # config.log. We remove comments because anyway the quotes in there # would cause problems or look ugly. # WARNING: Use '\'' to represent an apostrophe within the trap. # WARNING: Do not start the trap code with a newline, due to a FreeBSD 4.0 bug. trap 'exit_status=$? # Save into config.log some information that might help in debugging. { echo cat <<\_ASBOX ## ---------------- ## ## Cache variables. ## ## ---------------- ## _ASBOX echo # The following way of writing the cache mishandles newlines in values, ( for ac_var in `(set) 2>&1 | sed -n '\''s/^\([a-zA-Z_][a-zA-Z0-9_]*\)=.*/\1/p'\''`; do eval ac_val=\$$ac_var case $ac_val in #( *${as_nl}*) case $ac_var in #( *_cv_*) { $as_echo "$as_me:$LINENO: WARNING: cache variable $ac_var contains a newline" >&5 $as_echo "$as_me: WARNING: cache variable $ac_var contains a newline" >&2;} ;; esac case $ac_var in #( _ | IFS | as_nl) ;; #( BASH_ARGV | BASH_SOURCE) eval $ac_var= ;; #( *) $as_unset $ac_var ;; esac ;; esac done (set) 2>&1 | case $as_nl`(ac_space='\'' '\''; set) 2>&1` in #( *${as_nl}ac_space=\ *) sed -n \ "s/'\''/'\''\\\\'\'''\''/g; s/^\\([_$as_cr_alnum]*_cv_[_$as_cr_alnum]*\\)=\\(.*\\)/\\1='\''\\2'\''/p" ;; #( *) sed -n "/^[_$as_cr_alnum]*_cv_[_$as_cr_alnum]*=/p" ;; esac | sort ) echo cat <<\_ASBOX ## ----------------- ## ## Output variables. ## ## ----------------- ## _ASBOX echo for ac_var in $ac_subst_vars do eval ac_val=\$$ac_var case $ac_val in *\'\''*) ac_val=`$as_echo "$ac_val" | sed "s/'\''/'\''\\\\\\\\'\'''\''/g"`;; esac $as_echo "$ac_var='\''$ac_val'\''" done | sort echo if test -n "$ac_subst_files"; then cat <<\_ASBOX ## ------------------- ## ## File substitutions. ## ## ------------------- ## _ASBOX echo for ac_var in $ac_subst_files do eval ac_val=\$$ac_var case $ac_val in *\'\''*) ac_val=`$as_echo "$ac_val" | sed "s/'\''/'\''\\\\\\\\'\'''\''/g"`;; esac $as_echo "$ac_var='\''$ac_val'\''" done | sort echo fi if test -s confdefs.h; then cat <<\_ASBOX ## ----------- ## ## confdefs.h. ## ## ----------- ## _ASBOX echo cat confdefs.h echo fi test "$ac_signal" != 0 && $as_echo "$as_me: caught signal $ac_signal" $as_echo "$as_me: exit $exit_status" } >&5 rm -f core *.core core.conftest.* && rm -f -r conftest* confdefs* conf$$* $ac_clean_files && exit $exit_status ' 0 for ac_signal in 1 2 13 15; do trap 'ac_signal='$ac_signal'; { (exit 1); exit 1; }' $ac_signal done ac_signal=0 # confdefs.h avoids OS command line length limits that DEFS can exceed. rm -f -r conftest* confdefs.h # Predefined preprocessor variables. cat >>confdefs.h <<_ACEOF #define PACKAGE_NAME "$PACKAGE_NAME" _ACEOF cat >>confdefs.h <<_ACEOF #define PACKAGE_TARNAME "$PACKAGE_TARNAME" _ACEOF cat >>confdefs.h <<_ACEOF #define PACKAGE_VERSION "$PACKAGE_VERSION" _ACEOF cat >>confdefs.h <<_ACEOF #define PACKAGE_STRING "$PACKAGE_STRING" _ACEOF cat >>confdefs.h <<_ACEOF #define PACKAGE_BUGREPORT "$PACKAGE_BUGREPORT" _ACEOF # Let the site file select an alternate cache file if it wants to. # Prefer an explicitly selected file to automatically selected ones. ac_site_file1=NONE ac_site_file2=NONE if test -n "$CONFIG_SITE"; then ac_site_file1=$CONFIG_SITE elif test "x$prefix" != xNONE; then ac_site_file1=$prefix/share/config.site ac_site_file2=$prefix/etc/config.site else ac_site_file1=$ac_default_prefix/share/config.site ac_site_file2=$ac_default_prefix/etc/config.site fi for ac_site_file in "$ac_site_file1" "$ac_site_file2" do test "x$ac_site_file" = xNONE && continue if test -r "$ac_site_file"; then { $as_echo "$as_me:$LINENO: loading site script $ac_site_file" >&5 $as_echo "$as_me: loading site script $ac_site_file" >&6;} sed 's/^/| /' "$ac_site_file" >&5 . "$ac_site_file" fi done if test -r "$cache_file"; then # Some versions of bash will fail to source /dev/null (special # files actually), so we avoid doing that. if test -f "$cache_file"; then { $as_echo "$as_me:$LINENO: loading cache $cache_file" >&5 $as_echo "$as_me: loading cache $cache_file" >&6;} case $cache_file in [\\/]* | ?:[\\/]* ) . "$cache_file";; *) . "./$cache_file";; esac fi else { $as_echo "$as_me:$LINENO: creating cache $cache_file" >&5 $as_echo "$as_me: creating cache $cache_file" >&6;} >$cache_file fi # Check that the precious variables saved in the cache have kept the same # value. ac_cache_corrupted=false for ac_var in $ac_precious_vars; do eval ac_old_set=\$ac_cv_env_${ac_var}_set eval ac_new_set=\$ac_env_${ac_var}_set eval ac_old_val=\$ac_cv_env_${ac_var}_value eval ac_new_val=\$ac_env_${ac_var}_value case $ac_old_set,$ac_new_set in set,) { $as_echo "$as_me:$LINENO: error: \`$ac_var' was set to \`$ac_old_val' in the previous run" >&5 $as_echo "$as_me: error: \`$ac_var' was set to \`$ac_old_val' in the previous run" >&2;} ac_cache_corrupted=: ;; ,set) { $as_echo "$as_me:$LINENO: error: \`$ac_var' was not set in the previous run" >&5 $as_echo "$as_me: error: \`$ac_var' was not set in the previous run" >&2;} ac_cache_corrupted=: ;; ,);; *) if test "x$ac_old_val" != "x$ac_new_val"; then # differences in whitespace do not lead to failure. ac_old_val_w=`echo x $ac_old_val` ac_new_val_w=`echo x $ac_new_val` if test "$ac_old_val_w" != "$ac_new_val_w"; then { $as_echo "$as_me:$LINENO: error: \`$ac_var' has changed since the previous run:" >&5 $as_echo "$as_me: error: \`$ac_var' has changed since the previous run:" >&2;} ac_cache_corrupted=: else { $as_echo "$as_me:$LINENO: warning: ignoring whitespace changes in \`$ac_var' since the previous run:" >&5 $as_echo "$as_me: warning: ignoring whitespace changes in \`$ac_var' since the previous run:" >&2;} eval $ac_var=\$ac_old_val fi { $as_echo "$as_me:$LINENO: former value: \`$ac_old_val'" >&5 $as_echo "$as_me: former value: \`$ac_old_val'" >&2;} { $as_echo "$as_me:$LINENO: current value: \`$ac_new_val'" >&5 $as_echo "$as_me: current value: \`$ac_new_val'" >&2;} fi;; esac # Pass precious variables to config.status. if test "$ac_new_set" = set; then case $ac_new_val in *\'*) ac_arg=$ac_var=`$as_echo "$ac_new_val" | sed "s/'/'\\\\\\\\''/g"` ;; *) ac_arg=$ac_var=$ac_new_val ;; esac case " $ac_configure_args " in *" '$ac_arg' "*) ;; # Avoid dups. Use of quotes ensures accuracy. *) ac_configure_args="$ac_configure_args '$ac_arg'" ;; esac fi done if $ac_cache_corrupted; then { $as_echo "$as_me:$LINENO: error: in \`$ac_pwd':" >&5 $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} { $as_echo "$as_me:$LINENO: error: changes in the environment can compromise the build" >&5 $as_echo "$as_me: error: changes in the environment can compromise the build" >&2;} { { $as_echo "$as_me:$LINENO: error: run \`make distclean' and/or \`rm $cache_file' and start over" >&5 $as_echo "$as_me: error: run \`make distclean' and/or \`rm $cache_file' and start over" >&2;} { (exit 1); exit 1; }; } fi ac_ext=c ac_cpp='$CPP $CPPFLAGS' ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' ac_compiler_gnu=$ac_cv_c_compiler_gnu # # Algol 68 Genie "configure.ac" from "a68g-tools". # # Check whether compiler supports $1 as a command-line option. # If it does, add the string to CFLAGS. # Check whether $1 is in GNU plotutils. # Check whether $1 is in GNU GSL. # Check whether $1 is in PostgreSQL. # Check whether $1 is in pthread. # Check whether $1 is in dl. # # Platform ids. # { $as_echo "$as_me:$LINENO: host system..." >&5 $as_echo "$as_me: host system..." >&6;} ac_aux_dir= for ac_dir in "$srcdir" "$srcdir/.." "$srcdir/../.."; do if test -f "$ac_dir/install-sh"; then ac_aux_dir=$ac_dir ac_install_sh="$ac_aux_dir/install-sh -c" break elif test -f "$ac_dir/install.sh"; then ac_aux_dir=$ac_dir ac_install_sh="$ac_aux_dir/install.sh -c" break elif test -f "$ac_dir/shtool"; then ac_aux_dir=$ac_dir ac_install_sh="$ac_aux_dir/shtool install -c" break fi done if test -z "$ac_aux_dir"; then { { $as_echo "$as_me:$LINENO: error: cannot find install-sh or install.sh in \"$srcdir\" \"$srcdir/..\" \"$srcdir/../..\"" >&5 $as_echo "$as_me: error: cannot find install-sh or install.sh in \"$srcdir\" \"$srcdir/..\" \"$srcdir/../..\"" >&2;} { (exit 1); exit 1; }; } fi # These three variables are undocumented and unsupported, # and are intended to be withdrawn in a future Autoconf release. # They can cause serious problems if a builder's source tree is in a directory # whose full name contains unusual characters. ac_config_guess="$SHELL $ac_aux_dir/config.guess" # Please don't use this var. ac_config_sub="$SHELL $ac_aux_dir/config.sub" # Please don't use this var. ac_configure="$SHELL $ac_aux_dir/configure" # Please don't use this var. # Make sure we can run config.sub. $SHELL "$ac_aux_dir/config.sub" sun4 >/dev/null 2>&1 || { { $as_echo "$as_me:$LINENO: error: cannot run $SHELL $ac_aux_dir/config.sub" >&5 $as_echo "$as_me: error: cannot run $SHELL $ac_aux_dir/config.sub" >&2;} { (exit 1); exit 1; }; } { $as_echo "$as_me:$LINENO: checking build system type" >&5 $as_echo_n "checking build system type... " >&6; } if test "${ac_cv_build+set}" = set; then $as_echo_n "(cached) " >&6 else ac_build_alias=$build_alias test "x$ac_build_alias" = x && ac_build_alias=`$SHELL "$ac_aux_dir/config.guess"` test "x$ac_build_alias" = x && { { $as_echo "$as_me:$LINENO: error: cannot guess build type; you must specify one" >&5 $as_echo "$as_me: error: cannot guess build type; you must specify one" >&2;} { (exit 1); exit 1; }; } ac_cv_build=`$SHELL "$ac_aux_dir/config.sub" $ac_build_alias` || { { $as_echo "$as_me:$LINENO: error: $SHELL $ac_aux_dir/config.sub $ac_build_alias failed" >&5 $as_echo "$as_me: error: $SHELL $ac_aux_dir/config.sub $ac_build_alias failed" >&2;} { (exit 1); exit 1; }; } fi { $as_echo "$as_me:$LINENO: result: $ac_cv_build" >&5 $as_echo "$ac_cv_build" >&6; } case $ac_cv_build in *-*-*) ;; *) { { $as_echo "$as_me:$LINENO: error: invalid value of canonical build" >&5 $as_echo "$as_me: error: invalid value of canonical build" >&2;} { (exit 1); exit 1; }; };; esac build=$ac_cv_build ac_save_IFS=$IFS; IFS='-' set x $ac_cv_build shift build_cpu=$1 build_vendor=$2 shift; shift # Remember, the first character of IFS is used to create $*, # except with old shells: build_os=$* IFS=$ac_save_IFS case $build_os in *\ *) build_os=`echo "$build_os" | sed 's/ /-/g'`;; esac { $as_echo "$as_me:$LINENO: checking host system type" >&5 $as_echo_n "checking host system type... " >&6; } if test "${ac_cv_host+set}" = set; then $as_echo_n "(cached) " >&6 else if test "x$host_alias" = x; then ac_cv_host=$ac_cv_build else ac_cv_host=`$SHELL "$ac_aux_dir/config.sub" $host_alias` || { { $as_echo "$as_me:$LINENO: error: $SHELL $ac_aux_dir/config.sub $host_alias failed" >&5 $as_echo "$as_me: error: $SHELL $ac_aux_dir/config.sub $host_alias failed" >&2;} { (exit 1); exit 1; }; } fi fi { $as_echo "$as_me:$LINENO: result: $ac_cv_host" >&5 $as_echo "$ac_cv_host" >&6; } case $ac_cv_host in *-*-*) ;; *) { { $as_echo "$as_me:$LINENO: error: invalid value of canonical host" >&5 $as_echo "$as_me: error: invalid value of canonical host" >&2;} { (exit 1); exit 1; }; };; esac host=$ac_cv_host ac_save_IFS=$IFS; IFS='-' set x $ac_cv_host shift host_cpu=$1 host_vendor=$2 shift; shift # Remember, the first character of IFS is used to create $*, # except with old shells: host_os=$* IFS=$ac_save_IFS case $host_os in *\ *) host_os=`echo "$host_os" | sed 's/ /-/g'`;; esac { $as_echo "$as_me:$LINENO: checking target system type" >&5 $as_echo_n "checking target system type... " >&6; } if test "${ac_cv_target+set}" = set; then $as_echo_n "(cached) " >&6 else if test "x$target_alias" = x; then ac_cv_target=$ac_cv_host else ac_cv_target=`$SHELL "$ac_aux_dir/config.sub" $target_alias` || { { $as_echo "$as_me:$LINENO: error: $SHELL $ac_aux_dir/config.sub $target_alias failed" >&5 $as_echo "$as_me: error: $SHELL $ac_aux_dir/config.sub $target_alias failed" >&2;} { (exit 1); exit 1; }; } fi fi { $as_echo "$as_me:$LINENO: result: $ac_cv_target" >&5 $as_echo "$ac_cv_target" >&6; } case $ac_cv_target in *-*-*) ;; *) { { $as_echo "$as_me:$LINENO: error: invalid value of canonical target" >&5 $as_echo "$as_me: error: invalid value of canonical target" >&2;} { (exit 1); exit 1; }; };; esac target=$ac_cv_target ac_save_IFS=$IFS; IFS='-' set x $ac_cv_target shift target_cpu=$1 target_vendor=$2 shift; shift # Remember, the first character of IFS is used to create $*, # except with old shells: target_os=$* IFS=$ac_save_IFS case $target_os in *\ *) target_os=`echo "$target_os" | sed 's/ /-/g'`;; esac # The aliases save the names the user supplied, while $host etc. # will get canonicalized. test -n "$target_alias" && test "$program_prefix$program_suffix$program_transform_name" = \ NONENONEs,x,x, && program_prefix=${target_alias}- { $as_echo "$as_me:$LINENO: checking platform" >&5 $as_echo_n "checking platform... " >&6; } case "$host" in # # Linux. # *86-*-gnu | *86_64-*-gnu | *86-*-linux* | *86_64-*-linux*) cat >>confdefs.h <<\_ACEOF #define HAVE_LINUX 1 _ACEOF cat >>confdefs.h <<\_ACEOF #define HAVE_IEEE_754 1 _ACEOF { $as_echo "$as_me:$LINENO: result: linux" >&5 $as_echo "linux" >&6; } ;; # # Mac OS X. # *86-*-*darwin* | *86_64-*-*darwin*) cat >>confdefs.h <<\_ACEOF #define HAVE_MAC_OS_X 1 _ACEOF cat >>confdefs.h <<\_ACEOF #define HAVE_IEEE_754 1 _ACEOF { $as_echo "$as_me:$LINENO: result: mac os x" >&5 $as_echo "mac os x" >&6; } ;; # # FreeBSD. # *86-*-freebsd* | *86_64-*-freebsd*) cat >>confdefs.h <<\_ACEOF #define HAVE_FREEBSD 1 _ACEOF cat >>confdefs.h <<\_ACEOF #define HAVE_IEEE_754 1 _ACEOF { $as_echo "$as_me:$LINENO: result: freebsd" >&5 $as_echo "freebsd" >&6; } ;; # # NetBSD. # *86-*-netbsd* | *86_64-*-netbsd*) cat >>confdefs.h <<\_ACEOF #define HAVE_NETBSD 1 _ACEOF cat >>confdefs.h <<\_ACEOF #define HAVE_IEEE_754 1 _ACEOF { $as_echo "$as_me:$LINENO: result: netbsd" >&5 $as_echo "netbsd" >&6; } ;; # # OpenBSD. # *86-*-openbsd* | *86_64-*-openbsd*) cat >>confdefs.h <<\_ACEOF #define HAVE_OPENBSD 1 _ACEOF { $as_echo "$as_me:$LINENO: WARNING: configuring interpreter-only on OpenBSD" >&5 $as_echo "$as_me: WARNING: configuring interpreter-only on OpenBSD" >&2;} { $as_echo "$as_me:$LINENO: result: openbsd" >&5 $as_echo "openbsd" >&6; } enable_compiler=no ;; # # Others, untested. # *) cat >>confdefs.h <<\_ACEOF #define HAVE_UNTESTED 1 _ACEOF { $as_echo "$as_me:$LINENO: WARNING: configuring interpreter-only on untested platform" >&5 $as_echo "$as_me: WARNING: configuring interpreter-only on untested platform" >&2;} { $as_echo "$as_me:$LINENO: result: interpreter-only" >&5 $as_echo "interpreter-only" >&6; } enable_compiler=no ;; esac # # Extra options. # # Check whether --enable-arch was given. if test "${enable_arch+set}" = set; then enableval=$enable_arch; else enable_arch=no fi # Check whether --enable-compiler was given. if test "${enable_compiler+set}" = set; then enableval=$enable_compiler; else enable_compiler=yes fi # Check whether --enable-curses was given. if test "${enable_curses+set}" = set; then enableval=$enable_curses; else enable_curses=yes fi # Check whether --enable-readline was given. if test "${enable_readline+set}" = set; then enableval=$enable_readline; else enable_readline=yes fi # Check whether --enable-gsl was given. if test "${enable_gsl+set}" = set; then enableval=$enable_gsl; else enable_gsl=yes fi # Check whether --enable-parallel was given. if test "${enable_parallel+set}" = set; then enableval=$enable_parallel; else enable_parallel=yes fi # Check whether --enable-pic was given. if test "${enable_pic+set}" = set; then enableval=$enable_pic; else enable_pic="-fPIC" fi # Check whether --enable-prescott was given. if test "${enable_prescott+set}" = set; then enableval=$enable_prescott; else enable_prescott=no fi # Check whether --enable-plotutils was given. if test "${enable_plotutils+set}" = set; then enableval=$enable_plotutils; else enable_plotutils=yes fi # Check whether --enable-postgresql was given. if test "${enable_postgresql+set}" = set; then enableval=$enable_postgresql; else enable_postgresql=yes fi # # Initialisation. # { $as_echo "$as_me:$LINENO: initialising..." >&5 $as_echo "$as_me: initialising..." >&6;} am__api_version='1.10' # Find a good install program. We prefer a C program (faster), # so one script is as good as another. But avoid the broken or # incompatible versions: # SysV /etc/install, /usr/sbin/install # SunOS /usr/etc/install # IRIX /sbin/install # AIX /bin/install # AmigaOS /C/install, which installs bootblocks on floppy discs # AIX 4 /usr/bin/installbsd, which doesn't work without a -g flag # AFS /usr/afsws/bin/install, which mishandles nonexistent args # SVR4 /usr/ucb/install, which tries to use the nonexistent group "staff" # OS/2's system install, which has a completely different semantic # ./install, which can be erroneously created by make from ./install.sh. # Reject install programs that cannot install multiple files. { $as_echo "$as_me:$LINENO: checking for a BSD-compatible install" >&5 $as_echo_n "checking for a BSD-compatible install... " >&6; } if test -z "$INSTALL"; then if test "${ac_cv_path_install+set}" = set; then $as_echo_n "(cached) " >&6 else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. # Account for people who put trailing slashes in PATH elements. case $as_dir/ in ./ | .// | /cC/* | \ /etc/* | /usr/sbin/* | /usr/etc/* | /sbin/* | /usr/afsws/bin/* | \ ?:\\/os2\\/install\\/* | ?:\\/OS2\\/INSTALL\\/* | \ /usr/ucb/* ) ;; *) # OSF1 and SCO ODT 3.0 have their own names for install. # Don't use installbsd from OSF since it installs stuff as root # by default. for ac_prog in ginstall scoinst install; do for ac_exec_ext in '' $ac_executable_extensions; do if { test -f "$as_dir/$ac_prog$ac_exec_ext" && $as_test_x "$as_dir/$ac_prog$ac_exec_ext"; }; then if test $ac_prog = install && grep dspmsg "$as_dir/$ac_prog$ac_exec_ext" >/dev/null 2>&1; then # AIX install. It has an incompatible calling convention. : elif test $ac_prog = install && grep pwplus "$as_dir/$ac_prog$ac_exec_ext" >/dev/null 2>&1; then # program-specific install script used by HP pwplus--don't use. : else rm -rf conftest.one conftest.two conftest.dir echo one > conftest.one echo two > conftest.two mkdir conftest.dir if "$as_dir/$ac_prog$ac_exec_ext" -c conftest.one conftest.two "`pwd`/conftest.dir" && test -s conftest.one && test -s conftest.two && test -s conftest.dir/conftest.one && test -s conftest.dir/conftest.two then ac_cv_path_install="$as_dir/$ac_prog$ac_exec_ext -c" break 3 fi fi fi done done ;; esac done IFS=$as_save_IFS rm -rf conftest.one conftest.two conftest.dir fi if test "${ac_cv_path_install+set}" = set; then INSTALL=$ac_cv_path_install else # As a last resort, use the slow shell script. Don't cache a # value for INSTALL within a source directory, because that will # break other packages using the cache if that directory is # removed, or if the value is a relative name. INSTALL=$ac_install_sh fi fi { $as_echo "$as_me:$LINENO: result: $INSTALL" >&5 $as_echo "$INSTALL" >&6; } # Use test -z because SunOS4 sh mishandles braces in ${var-val}. # It thinks the first close brace ends the variable substitution. test -z "$INSTALL_PROGRAM" && INSTALL_PROGRAM='${INSTALL}' test -z "$INSTALL_SCRIPT" && INSTALL_SCRIPT='${INSTALL}' test -z "$INSTALL_DATA" && INSTALL_DATA='${INSTALL} -m 644' { $as_echo "$as_me:$LINENO: checking whether build environment is sane" >&5 $as_echo_n "checking whether build environment is sane... " >&6; } # Just in case sleep 1 echo timestamp > conftest.file # Do `set' in a subshell so we don't clobber the current shell's # arguments. Must try -L first in case configure is actually a # symlink; some systems play weird games with the mod time of symlinks # (eg FreeBSD returns the mod time of the symlink's containing # directory). if ( set X `ls -Lt $srcdir/configure conftest.file 2> /dev/null` if test "$*" = "X"; then # -L didn't work. set X `ls -t $srcdir/configure conftest.file` fi rm -f conftest.file if test "$*" != "X $srcdir/configure conftest.file" \ && test "$*" != "X conftest.file $srcdir/configure"; then # If neither matched, then we have a broken ls. This can happen # if, for instance, CONFIG_SHELL is bash and it inherits a # broken ls alias from the environment. This has actually # happened. Such a system could not be considered "sane". { { $as_echo "$as_me:$LINENO: error: ls -t appears to fail. Make sure there is not a broken alias in your environment" >&5 $as_echo "$as_me: error: ls -t appears to fail. Make sure there is not a broken alias in your environment" >&2;} { (exit 1); exit 1; }; } fi test "$2" = conftest.file ) then # Ok. : else { { $as_echo "$as_me:$LINENO: error: newly created file is older than distributed files! Check your system clock" >&5 $as_echo "$as_me: error: newly created file is older than distributed files! Check your system clock" >&2;} { (exit 1); exit 1; }; } fi { $as_echo "$as_me:$LINENO: result: yes" >&5 $as_echo "yes" >&6; } test "$program_prefix" != NONE && program_transform_name="s&^&$program_prefix&;$program_transform_name" # Use a double $ so make ignores it. test "$program_suffix" != NONE && program_transform_name="s&\$&$program_suffix&;$program_transform_name" # Double any \ or $. # By default was `s,x,x', remove it if useless. ac_script='s/[\\$]/&&/g;s/;s,x,x,$//' program_transform_name=`$as_echo "$program_transform_name" | sed "$ac_script"` # expand $ac_aux_dir to an absolute path am_aux_dir=`cd $ac_aux_dir && pwd` test x"${MISSING+set}" = xset || MISSING="\${SHELL} $am_aux_dir/missing" # Use eval to expand $SHELL if eval "$MISSING --run true"; then am_missing_run="$MISSING --run " else am_missing_run= { $as_echo "$as_me:$LINENO: WARNING: \`missing' script is too old or missing" >&5 $as_echo "$as_me: WARNING: \`missing' script is too old or missing" >&2;} fi { $as_echo "$as_me:$LINENO: checking for a thread-safe mkdir -p" >&5 $as_echo_n "checking for a thread-safe mkdir -p... " >&6; } if test -z "$MKDIR_P"; then if test "${ac_cv_path_mkdir+set}" = set; then $as_echo_n "(cached) " >&6 else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH$PATH_SEPARATOR/opt/sfw/bin do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_prog in mkdir gmkdir; do for ac_exec_ext in '' $ac_executable_extensions; do { test -f "$as_dir/$ac_prog$ac_exec_ext" && $as_test_x "$as_dir/$ac_prog$ac_exec_ext"; } || continue case `"$as_dir/$ac_prog$ac_exec_ext" --version 2>&1` in #( 'mkdir (GNU coreutils) '* | \ 'mkdir (coreutils) '* | \ 'mkdir (fileutils) '4.1*) ac_cv_path_mkdir=$as_dir/$ac_prog$ac_exec_ext break 3;; esac done done done IFS=$as_save_IFS fi if test "${ac_cv_path_mkdir+set}" = set; then MKDIR_P="$ac_cv_path_mkdir -p" else # As a last resort, use the slow shell script. Don't cache a # value for MKDIR_P within a source directory, because that will # break other packages using the cache if that directory is # removed, or if the value is a relative name. test -d ./--version && rmdir ./--version MKDIR_P="$ac_install_sh -d" fi fi { $as_echo "$as_me:$LINENO: result: $MKDIR_P" >&5 $as_echo "$MKDIR_P" >&6; } mkdir_p="$MKDIR_P" case $mkdir_p in [\\/$]* | ?:[\\/]*) ;; */*) mkdir_p="\$(top_builddir)/$mkdir_p" ;; esac for ac_prog in gawk mawk nawk awk do # Extract the first word of "$ac_prog", so it can be a program name with args. set dummy $ac_prog; ac_word=$2 { $as_echo "$as_me:$LINENO: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if test "${ac_cv_prog_AWK+set}" = set; then $as_echo_n "(cached) " >&6 else if test -n "$AWK"; then ac_cv_prog_AWK="$AWK" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then ac_cv_prog_AWK="$ac_prog" $as_echo "$as_me:$LINENO: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS fi fi AWK=$ac_cv_prog_AWK if test -n "$AWK"; then { $as_echo "$as_me:$LINENO: result: $AWK" >&5 $as_echo "$AWK" >&6; } else { $as_echo "$as_me:$LINENO: result: no" >&5 $as_echo "no" >&6; } fi test -n "$AWK" && break done { $as_echo "$as_me:$LINENO: checking whether ${MAKE-make} sets \$(MAKE)" >&5 $as_echo_n "checking whether ${MAKE-make} sets \$(MAKE)... " >&6; } set x ${MAKE-make} ac_make=`$as_echo "$2" | sed 's/+/p/g; s/[^a-zA-Z0-9_]/_/g'` if { as_var=ac_cv_prog_make_${ac_make}_set; eval "test \"\${$as_var+set}\" = set"; }; then $as_echo_n "(cached) " >&6 else cat >conftest.make <<\_ACEOF SHELL = /bin/sh all: @echo '@@@%%%=$(MAKE)=@@@%%%' _ACEOF # GNU make sometimes prints "make[1]: Entering...", which would confuse us. case `${MAKE-make} -f conftest.make 2>/dev/null` in *@@@%%%=?*=@@@%%%*) eval ac_cv_prog_make_${ac_make}_set=yes;; *) eval ac_cv_prog_make_${ac_make}_set=no;; esac rm -f conftest.make fi if eval test \$ac_cv_prog_make_${ac_make}_set = yes; then { $as_echo "$as_me:$LINENO: result: yes" >&5 $as_echo "yes" >&6; } SET_MAKE= else { $as_echo "$as_me:$LINENO: result: no" >&5 $as_echo "no" >&6; } SET_MAKE="MAKE=${MAKE-make}" fi rm -rf .tst 2>/dev/null mkdir .tst 2>/dev/null if test -d .tst; then am__leading_dot=. else am__leading_dot=_ fi rmdir .tst 2>/dev/null if test "`cd $srcdir && pwd`" != "`pwd`"; then # Use -I$(srcdir) only when $(srcdir) != ., so that make's output # is not polluted with repeated "-I." am__isrc=' -I$(srcdir)' # test to see if srcdir already configured if test -f $srcdir/config.status; then { { $as_echo "$as_me:$LINENO: error: source directory already configured; run \"make distclean\" there first" >&5 $as_echo "$as_me: error: source directory already configured; run \"make distclean\" there first" >&2;} { (exit 1); exit 1; }; } fi fi # test whether we have cygpath if test -z "$CYGPATH_W"; then if (cygpath --version) >/dev/null 2>/dev/null; then CYGPATH_W='cygpath -w' else CYGPATH_W=echo fi fi # Define the identity of the package. PACKAGE='algol68g' VERSION='2.4.1' cat >>confdefs.h <<_ACEOF #define PACKAGE "$PACKAGE" _ACEOF cat >>confdefs.h <<_ACEOF #define VERSION "$VERSION" _ACEOF # Some tools Automake needs. ACLOCAL=${ACLOCAL-"${am_missing_run}aclocal-${am__api_version}"} AUTOCONF=${AUTOCONF-"${am_missing_run}autoconf"} AUTOMAKE=${AUTOMAKE-"${am_missing_run}automake-${am__api_version}"} AUTOHEADER=${AUTOHEADER-"${am_missing_run}autoheader"} MAKEINFO=${MAKEINFO-"${am_missing_run}makeinfo"} install_sh=${install_sh-"\$(SHELL) $am_aux_dir/install-sh"} # Installed binaries are usually stripped using `strip' when the user # run `make install-strip'. However `strip' might not be the right # tool to use in cross-compilation environments, therefore Automake # will honor the `STRIP' environment variable to overrule this program. if test "$cross_compiling" != no; then if test -n "$ac_tool_prefix"; then # Extract the first word of "${ac_tool_prefix}strip", so it can be a program name with args. set dummy ${ac_tool_prefix}strip; ac_word=$2 { $as_echo "$as_me:$LINENO: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if test "${ac_cv_prog_STRIP+set}" = set; then $as_echo_n "(cached) " >&6 else if test -n "$STRIP"; then ac_cv_prog_STRIP="$STRIP" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then ac_cv_prog_STRIP="${ac_tool_prefix}strip" $as_echo "$as_me:$LINENO: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS fi fi STRIP=$ac_cv_prog_STRIP if test -n "$STRIP"; then { $as_echo "$as_me:$LINENO: result: $STRIP" >&5 $as_echo "$STRIP" >&6; } else { $as_echo "$as_me:$LINENO: result: no" >&5 $as_echo "no" >&6; } fi fi if test -z "$ac_cv_prog_STRIP"; then ac_ct_STRIP=$STRIP # Extract the first word of "strip", so it can be a program name with args. set dummy strip; ac_word=$2 { $as_echo "$as_me:$LINENO: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if test "${ac_cv_prog_ac_ct_STRIP+set}" = set; then $as_echo_n "(cached) " >&6 else if test -n "$ac_ct_STRIP"; then ac_cv_prog_ac_ct_STRIP="$ac_ct_STRIP" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then ac_cv_prog_ac_ct_STRIP="strip" $as_echo "$as_me:$LINENO: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS fi fi ac_ct_STRIP=$ac_cv_prog_ac_ct_STRIP if test -n "$ac_ct_STRIP"; then { $as_echo "$as_me:$LINENO: result: $ac_ct_STRIP" >&5 $as_echo "$ac_ct_STRIP" >&6; } else { $as_echo "$as_me:$LINENO: result: no" >&5 $as_echo "no" >&6; } fi if test "x$ac_ct_STRIP" = x; then STRIP=":" else case $cross_compiling:$ac_tool_warned in yes:) { $as_echo "$as_me:$LINENO: WARNING: using cross tools not prefixed with host triplet" >&5 $as_echo "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;} ac_tool_warned=yes ;; esac STRIP=$ac_ct_STRIP fi else STRIP="$ac_cv_prog_STRIP" fi fi INSTALL_STRIP_PROGRAM="\$(install_sh) -c -s" # We need awk for the "check" target. The system "awk" is bad on # some platforms. # Always define AMTAR for backward compatibility. AMTAR=${AMTAR-"${am_missing_run}tar"} am__tar='${AMTAR} chof - "$$tardir"'; am__untar='${AMTAR} xf -' ac_config_headers="$ac_config_headers source/a68g-config.h" # Find a good install program. We prefer a C program (faster), # so one script is as good as another. But avoid the broken or # incompatible versions: # SysV /etc/install, /usr/sbin/install # SunOS /usr/etc/install # IRIX /sbin/install # AIX /bin/install # AmigaOS /C/install, which installs bootblocks on floppy discs # AIX 4 /usr/bin/installbsd, which doesn't work without a -g flag # AFS /usr/afsws/bin/install, which mishandles nonexistent args # SVR4 /usr/ucb/install, which tries to use the nonexistent group "staff" # OS/2's system install, which has a completely different semantic # ./install, which can be erroneously created by make from ./install.sh. # Reject install programs that cannot install multiple files. { $as_echo "$as_me:$LINENO: checking for a BSD-compatible install" >&5 $as_echo_n "checking for a BSD-compatible install... " >&6; } if test -z "$INSTALL"; then if test "${ac_cv_path_install+set}" = set; then $as_echo_n "(cached) " >&6 else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. # Account for people who put trailing slashes in PATH elements. case $as_dir/ in ./ | .// | /cC/* | \ /etc/* | /usr/sbin/* | /usr/etc/* | /sbin/* | /usr/afsws/bin/* | \ ?:\\/os2\\/install\\/* | ?:\\/OS2\\/INSTALL\\/* | \ /usr/ucb/* ) ;; *) # OSF1 and SCO ODT 3.0 have their own names for install. # Don't use installbsd from OSF since it installs stuff as root # by default. for ac_prog in ginstall scoinst install; do for ac_exec_ext in '' $ac_executable_extensions; do if { test -f "$as_dir/$ac_prog$ac_exec_ext" && $as_test_x "$as_dir/$ac_prog$ac_exec_ext"; }; then if test $ac_prog = install && grep dspmsg "$as_dir/$ac_prog$ac_exec_ext" >/dev/null 2>&1; then # AIX install. It has an incompatible calling convention. : elif test $ac_prog = install && grep pwplus "$as_dir/$ac_prog$ac_exec_ext" >/dev/null 2>&1; then # program-specific install script used by HP pwplus--don't use. : else rm -rf conftest.one conftest.two conftest.dir echo one > conftest.one echo two > conftest.two mkdir conftest.dir if "$as_dir/$ac_prog$ac_exec_ext" -c conftest.one conftest.two "`pwd`/conftest.dir" && test -s conftest.one && test -s conftest.two && test -s conftest.dir/conftest.one && test -s conftest.dir/conftest.two then ac_cv_path_install="$as_dir/$ac_prog$ac_exec_ext -c" break 3 fi fi fi done done ;; esac done IFS=$as_save_IFS rm -rf conftest.one conftest.two conftest.dir fi if test "${ac_cv_path_install+set}" = set; then INSTALL=$ac_cv_path_install else # As a last resort, use the slow shell script. Don't cache a # value for INSTALL within a source directory, because that will # break other packages using the cache if that directory is # removed, or if the value is a relative name. INSTALL=$ac_install_sh fi fi { $as_echo "$as_me:$LINENO: result: $INSTALL" >&5 $as_echo "$INSTALL" >&6; } # Use test -z because SunOS4 sh mishandles braces in ${var-val}. # It thinks the first close brace ends the variable substitution. test -z "$INSTALL_PROGRAM" && INSTALL_PROGRAM='${INSTALL}' test -z "$INSTALL_SCRIPT" && INSTALL_SCRIPT='${INSTALL}' test -z "$INSTALL_DATA" && INSTALL_DATA='${INSTALL} -m 644' # Extract the first word of "a68g", so it can be a program name with args. set dummy a68g; ac_word=$2 { $as_echo "$as_me:$LINENO: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if test "${ac_cv_prog_a68g_exists+set}" = set; then $as_echo_n "(cached) " >&6 else if test -n "$a68g_exists"; then ac_cv_prog_a68g_exists="$a68g_exists" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then ac_cv_prog_a68g_exists=""yes"" $as_echo "$as_me:$LINENO: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS fi fi a68g_exists=$ac_cv_prog_a68g_exists if test -n "$a68g_exists"; then { $as_echo "$as_me:$LINENO: result: $a68g_exists" >&5 $as_echo "$a68g_exists" >&6; } else { $as_echo "$as_me:$LINENO: result: no" >&5 $as_echo "no" >&6; } fi # # C compiler. # { $as_echo "$as_me:$LINENO: C compiler..." >&5 $as_echo "$as_me: C compiler..." >&6;} ac_ext=c ac_cpp='$CPP $CPPFLAGS' ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' ac_compiler_gnu=$ac_cv_c_compiler_gnu ac_ext=c ac_cpp='$CPP $CPPFLAGS' ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' ac_compiler_gnu=$ac_cv_c_compiler_gnu if test -n "$ac_tool_prefix"; then for ac_prog in clang gcc cc do # Extract the first word of "$ac_tool_prefix$ac_prog", so it can be a program name with args. set dummy $ac_tool_prefix$ac_prog; ac_word=$2 { $as_echo "$as_me:$LINENO: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if test "${ac_cv_prog_CC+set}" = set; then $as_echo_n "(cached) " >&6 else if test -n "$CC"; then ac_cv_prog_CC="$CC" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then ac_cv_prog_CC="$ac_tool_prefix$ac_prog" $as_echo "$as_me:$LINENO: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS fi fi CC=$ac_cv_prog_CC if test -n "$CC"; then { $as_echo "$as_me:$LINENO: result: $CC" >&5 $as_echo "$CC" >&6; } else { $as_echo "$as_me:$LINENO: result: no" >&5 $as_echo "no" >&6; } fi test -n "$CC" && break done fi if test -z "$CC"; then ac_ct_CC=$CC for ac_prog in clang gcc cc do # Extract the first word of "$ac_prog", so it can be a program name with args. set dummy $ac_prog; ac_word=$2 { $as_echo "$as_me:$LINENO: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if test "${ac_cv_prog_ac_ct_CC+set}" = set; then $as_echo_n "(cached) " >&6 else if test -n "$ac_ct_CC"; then ac_cv_prog_ac_ct_CC="$ac_ct_CC" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then ac_cv_prog_ac_ct_CC="$ac_prog" $as_echo "$as_me:$LINENO: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS fi fi ac_ct_CC=$ac_cv_prog_ac_ct_CC if test -n "$ac_ct_CC"; then { $as_echo "$as_me:$LINENO: result: $ac_ct_CC" >&5 $as_echo "$ac_ct_CC" >&6; } else { $as_echo "$as_me:$LINENO: result: no" >&5 $as_echo "no" >&6; } fi test -n "$ac_ct_CC" && break done if test "x$ac_ct_CC" = x; then CC="" else case $cross_compiling:$ac_tool_warned in yes:) { $as_echo "$as_me:$LINENO: WARNING: using cross tools not prefixed with host triplet" >&5 $as_echo "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;} ac_tool_warned=yes ;; esac CC=$ac_ct_CC fi fi test -z "$CC" && { { $as_echo "$as_me:$LINENO: error: in \`$ac_pwd':" >&5 $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} { { $as_echo "$as_me:$LINENO: error: no acceptable C compiler found in \$PATH See \`config.log' for more details." >&5 $as_echo "$as_me: error: no acceptable C compiler found in \$PATH See \`config.log' for more details." >&2;} { (exit 1); exit 1; }; }; } # Provide some information about the compiler. $as_echo "$as_me:$LINENO: checking for C compiler version" >&5 set X $ac_compile ac_compiler=$2 { (ac_try="$ac_compiler --version >&5" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compiler --version >&5") 2>&5 ac_status=$? $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } { (ac_try="$ac_compiler -v >&5" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compiler -v >&5") 2>&5 ac_status=$? $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } { (ac_try="$ac_compiler -V >&5" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compiler -V >&5") 2>&5 ac_status=$? $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ int main () { ; return 0; } _ACEOF ac_clean_files_save=$ac_clean_files ac_clean_files="$ac_clean_files a.out a.out.dSYM a.exe b.out" # Try to create an executable without -o first, disregard a.out. # It will help us diagnose broken compilers, and finding out an intuition # of exeext. { $as_echo "$as_me:$LINENO: checking for C compiler default output file name" >&5 $as_echo_n "checking for C compiler default output file name... " >&6; } ac_link_default=`$as_echo "$ac_link" | sed 's/ -o *conftest[^ ]*//'` # The possible output files: ac_files="a.out conftest.exe conftest a.exe a_out.exe b.out conftest.*" ac_rmfiles= for ac_file in $ac_files do case $ac_file in *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.map | *.inf | *.dSYM | *.o | *.obj ) ;; * ) ac_rmfiles="$ac_rmfiles $ac_file";; esac done rm -f $ac_rmfiles if { (ac_try="$ac_link_default" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link_default") 2>&5 ac_status=$? $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; then # Autoconf-2.13 could set the ac_cv_exeext variable to `no'. # So ignore a value of `no', otherwise this would lead to `EXEEXT = no' # in a Makefile. We should not override ac_cv_exeext if it was cached, # so that the user can short-circuit this test for compilers unknown to # Autoconf. for ac_file in $ac_files '' do test -f "$ac_file" || continue case $ac_file in *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.map | *.inf | *.dSYM | *.o | *.obj ) ;; [ab].out ) # We found the default executable, but exeext='' is most # certainly right. break;; *.* ) if test "${ac_cv_exeext+set}" = set && test "$ac_cv_exeext" != no; then :; else ac_cv_exeext=`expr "$ac_file" : '[^.]*\(\..*\)'` fi # We set ac_cv_exeext here because the later test for it is not # safe: cross compilers may not add the suffix if given an `-o' # argument, so we may need to know it at that point already. # Even if this section looks crufty: it has the advantage of # actually working. break;; * ) break;; esac done test "$ac_cv_exeext" = no && ac_cv_exeext= else ac_file='' fi { $as_echo "$as_me:$LINENO: result: $ac_file" >&5 $as_echo "$ac_file" >&6; } if test -z "$ac_file"; then $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 { { $as_echo "$as_me:$LINENO: error: in \`$ac_pwd':" >&5 $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} { { $as_echo "$as_me:$LINENO: error: C compiler cannot create executables See \`config.log' for more details." >&5 $as_echo "$as_me: error: C compiler cannot create executables See \`config.log' for more details." >&2;} { (exit 77); exit 77; }; }; } fi ac_exeext=$ac_cv_exeext # Check that the compiler produces executables we can run. If not, either # the compiler is broken, or we cross compile. { $as_echo "$as_me:$LINENO: checking whether the C compiler works" >&5 $as_echo_n "checking whether the C compiler works... " >&6; } # FIXME: These cross compiler hacks should be removed for Autoconf 3.0 # If not cross compiling, check that we can run a simple program. if test "$cross_compiling" != yes; then if { ac_try='./$ac_file' { (case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_try") 2>&5 ac_status=$? $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then cross_compiling=no else if test "$cross_compiling" = maybe; then cross_compiling=yes else { { $as_echo "$as_me:$LINENO: error: in \`$ac_pwd':" >&5 $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} { { $as_echo "$as_me:$LINENO: error: cannot run C compiled programs. If you meant to cross compile, use \`--host'. See \`config.log' for more details." >&5 $as_echo "$as_me: error: cannot run C compiled programs. If you meant to cross compile, use \`--host'. See \`config.log' for more details." >&2;} { (exit 1); exit 1; }; }; } fi fi fi { $as_echo "$as_me:$LINENO: result: yes" >&5 $as_echo "yes" >&6; } rm -f -r a.out a.out.dSYM a.exe conftest$ac_cv_exeext b.out ac_clean_files=$ac_clean_files_save # Check that the compiler produces executables we can run. If not, either # the compiler is broken, or we cross compile. { $as_echo "$as_me:$LINENO: checking whether we are cross compiling" >&5 $as_echo_n "checking whether we are cross compiling... " >&6; } { $as_echo "$as_me:$LINENO: result: $cross_compiling" >&5 $as_echo "$cross_compiling" >&6; } { $as_echo "$as_me:$LINENO: checking for suffix of executables" >&5 $as_echo_n "checking for suffix of executables... " >&6; } if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>&5 ac_status=$? $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; then # If both `conftest.exe' and `conftest' are `present' (well, observable) # catch `conftest.exe'. For instance with Cygwin, `ls conftest' will # work properly (i.e., refer to `conftest.exe'), while it won't with # `rm'. for ac_file in conftest.exe conftest conftest.*; do test -f "$ac_file" || continue case $ac_file in *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.map | *.inf | *.dSYM | *.o | *.obj ) ;; *.* ) ac_cv_exeext=`expr "$ac_file" : '[^.]*\(\..*\)'` break;; * ) break;; esac done else { { $as_echo "$as_me:$LINENO: error: in \`$ac_pwd':" >&5 $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} { { $as_echo "$as_me:$LINENO: error: cannot compute suffix of executables: cannot compile and link See \`config.log' for more details." >&5 $as_echo "$as_me: error: cannot compute suffix of executables: cannot compile and link See \`config.log' for more details." >&2;} { (exit 1); exit 1; }; }; } fi rm -f conftest$ac_cv_exeext { $as_echo "$as_me:$LINENO: result: $ac_cv_exeext" >&5 $as_echo "$ac_cv_exeext" >&6; } rm -f conftest.$ac_ext EXEEXT=$ac_cv_exeext ac_exeext=$EXEEXT { $as_echo "$as_me:$LINENO: checking for suffix of object files" >&5 $as_echo_n "checking for suffix of object files... " >&6; } if test "${ac_cv_objext+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ int main () { ; return 0; } _ACEOF rm -f conftest.o conftest.obj if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>&5 ac_status=$? $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; then for ac_file in conftest.o conftest.obj conftest.*; do test -f "$ac_file" || continue; case $ac_file in *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.map | *.inf | *.dSYM ) ;; *) ac_cv_objext=`expr "$ac_file" : '.*\.\(.*\)'` break;; esac done else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 { { $as_echo "$as_me:$LINENO: error: in \`$ac_pwd':" >&5 $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} { { $as_echo "$as_me:$LINENO: error: cannot compute suffix of object files: cannot compile See \`config.log' for more details." >&5 $as_echo "$as_me: error: cannot compute suffix of object files: cannot compile See \`config.log' for more details." >&2;} { (exit 1); exit 1; }; }; } fi rm -f conftest.$ac_cv_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_objext" >&5 $as_echo "$ac_cv_objext" >&6; } OBJEXT=$ac_cv_objext ac_objext=$OBJEXT { $as_echo "$as_me:$LINENO: checking whether we are using the GNU C compiler" >&5 $as_echo_n "checking whether we are using the GNU C compiler... " >&6; } if test "${ac_cv_c_compiler_gnu+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ int main () { #ifndef __GNUC__ choke me #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_compiler_gnu=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_compiler_gnu=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext ac_cv_c_compiler_gnu=$ac_compiler_gnu fi { $as_echo "$as_me:$LINENO: result: $ac_cv_c_compiler_gnu" >&5 $as_echo "$ac_cv_c_compiler_gnu" >&6; } if test $ac_compiler_gnu = yes; then GCC=yes else GCC= fi ac_test_CFLAGS=${CFLAGS+set} ac_save_CFLAGS=$CFLAGS { $as_echo "$as_me:$LINENO: checking whether $CC accepts -g" >&5 $as_echo_n "checking whether $CC accepts -g... " >&6; } if test "${ac_cv_prog_cc_g+set}" = set; then $as_echo_n "(cached) " >&6 else ac_save_c_werror_flag=$ac_c_werror_flag ac_c_werror_flag=yes ac_cv_prog_cc_g=no CFLAGS="-g" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ int main () { ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_prog_cc_g=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 CFLAGS="" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ int main () { ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then : else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_c_werror_flag=$ac_save_c_werror_flag CFLAGS="-g" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ int main () { ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_prog_cc_g=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext ac_c_werror_flag=$ac_save_c_werror_flag fi { $as_echo "$as_me:$LINENO: result: $ac_cv_prog_cc_g" >&5 $as_echo "$ac_cv_prog_cc_g" >&6; } if test "$ac_test_CFLAGS" = set; then CFLAGS=$ac_save_CFLAGS elif test $ac_cv_prog_cc_g = yes; then if test "$GCC" = yes; then CFLAGS="-g -O2" else CFLAGS="-g" fi else if test "$GCC" = yes; then CFLAGS="-O2" else CFLAGS= fi fi { $as_echo "$as_me:$LINENO: checking for $CC option to accept ISO C89" >&5 $as_echo_n "checking for $CC option to accept ISO C89... " >&6; } if test "${ac_cv_prog_cc_c89+set}" = set; then $as_echo_n "(cached) " >&6 else ac_cv_prog_cc_c89=no ac_save_CC=$CC cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include /* Most of the following tests are stolen from RCS 5.7's src/conf.sh. */ struct buf { int x; }; FILE * (*rcsopen) (struct buf *, struct stat *, int); static char *e (p, i) char **p; int i; { return p[i]; } static char *f (char * (*g) (char **, int), char **p, ...) { char *s; va_list v; va_start (v,p); s = g (p, va_arg (v,int)); va_end (v); return s; } /* OSF 4.0 Compaq cc is some sort of almost-ANSI by default. It has function prototypes and stuff, but not '\xHH' hex character constants. These don't provoke an error unfortunately, instead are silently treated as 'x'. The following induces an error, until -std is added to get proper ANSI mode. Curiously '\x00'!='x' always comes out true, for an array size at least. It's necessary to write '\x00'==0 to get something that's true only with -std. */ int osf4_cc_array ['\x00' == 0 ? 1 : -1]; /* IBM C 6 for AIX is almost-ANSI by default, but it replaces macro parameters inside strings and character constants. */ #define FOO(x) 'x' int xlc6_cc_array[FOO(a) == 'x' ? 1 : -1]; int test (int i, double x); struct s1 {int (*f) (int a);}; struct s2 {int (*f) (double a);}; int pairnames (int, char **, FILE *(*)(struct buf *, struct stat *, int), int, int); int argc; char **argv; int main () { return f (e, argv, 0) != argv[0] || f (e, argv, 1) != argv[1]; ; return 0; } _ACEOF for ac_arg in '' -qlanglvl=extc89 -qlanglvl=ansi -std \ -Ae "-Aa -D_HPUX_SOURCE" "-Xc -D__EXTENSIONS__" do CC="$ac_save_CC $ac_arg" rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_prog_cc_c89=$ac_arg else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 fi rm -f core conftest.err conftest.$ac_objext test "x$ac_cv_prog_cc_c89" != "xno" && break done rm -f conftest.$ac_ext CC=$ac_save_CC fi # AC_CACHE_VAL case "x$ac_cv_prog_cc_c89" in x) { $as_echo "$as_me:$LINENO: result: none needed" >&5 $as_echo "none needed" >&6; } ;; xno) { $as_echo "$as_me:$LINENO: result: unsupported" >&5 $as_echo "unsupported" >&6; } ;; *) CC="$CC $ac_cv_prog_cc_c89" { $as_echo "$as_me:$LINENO: result: $ac_cv_prog_cc_c89" >&5 $as_echo "$ac_cv_prog_cc_c89" >&6; } ;; esac ac_ext=c ac_cpp='$CPP $CPPFLAGS' ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' ac_compiler_gnu=$ac_cv_c_compiler_gnu DEPDIR="${am__leading_dot}deps" ac_config_commands="$ac_config_commands depfiles" am_make=${MAKE-make} cat > confinc << 'END' am__doit: @echo done .PHONY: am__doit END # If we don't find an include directive, just comment out the code. { $as_echo "$as_me:$LINENO: checking for style of include used by $am_make" >&5 $as_echo_n "checking for style of include used by $am_make... " >&6; } am__include="#" am__quote= _am_result=none # First try GNU make style include. echo "include confinc" > confmf # We grep out `Entering directory' and `Leaving directory' # messages which can occur if `w' ends up in MAKEFLAGS. # In particular we don't look at `^make:' because GNU make might # be invoked under some other name (usually "gmake"), in which # case it prints its new name instead of `make'. if test "`$am_make -s -f confmf 2> /dev/null | grep -v 'ing directory'`" = "done"; then am__include=include am__quote= _am_result=GNU fi # Now try BSD make style include. if test "$am__include" = "#"; then echo '.include "confinc"' > confmf if test "`$am_make -s -f confmf 2> /dev/null`" = "done"; then am__include=.include am__quote="\"" _am_result=BSD fi fi { $as_echo "$as_me:$LINENO: result: $_am_result" >&5 $as_echo "$_am_result" >&6; } rm -f confinc confmf # Check whether --enable-dependency-tracking was given. if test "${enable_dependency_tracking+set}" = set; then enableval=$enable_dependency_tracking; fi if test "x$enable_dependency_tracking" != xno; then am_depcomp="$ac_aux_dir/depcomp" AMDEPBACKSLASH='\' fi if test "x$enable_dependency_tracking" != xno; then AMDEP_TRUE= AMDEP_FALSE='#' else AMDEP_TRUE='#' AMDEP_FALSE= fi depcc="$CC" am_compiler_list= { $as_echo "$as_me:$LINENO: checking dependency style of $depcc" >&5 $as_echo_n "checking dependency style of $depcc... " >&6; } if test "${am_cv_CC_dependencies_compiler_type+set}" = set; then $as_echo_n "(cached) " >&6 else if test -z "$AMDEP_TRUE" && test -f "$am_depcomp"; then # We make a subdir and do the tests there. Otherwise we can end up # making bogus files that we don't know about and never remove. For # instance it was reported that on HP-UX the gcc test will end up # making a dummy file named `D' -- because `-MD' means `put the output # in D'. mkdir conftest.dir # Copy depcomp to subdir because otherwise we won't find it if we're # using a relative directory. cp "$am_depcomp" conftest.dir cd conftest.dir # We will build objects and dependencies in a subdirectory because # it helps to detect inapplicable dependency modes. For instance # both Tru64's cc and ICC support -MD to output dependencies as a # side effect of compilation, but ICC will put the dependencies in # the current directory while Tru64 will put them in the object # directory. mkdir sub am_cv_CC_dependencies_compiler_type=none if test "$am_compiler_list" = ""; then am_compiler_list=`sed -n 's/^#*\([a-zA-Z0-9]*\))$/\1/p' < ./depcomp` fi for depmode in $am_compiler_list; do # Setup a source with many dependencies, because some compilers # like to wrap large dependency lists on column 80 (with \), and # we should not choose a depcomp mode which is confused by this. # # We need to recreate these files for each test, as the compiler may # overwrite some of them when testing with obscure command lines. # This happens at least with the AIX C compiler. : > sub/conftest.c for i in 1 2 3 4 5 6; do echo '#include "conftst'$i'.h"' >> sub/conftest.c # Using `: > sub/conftst$i.h' creates only sub/conftst1.h with # Solaris 8's {/usr,}/bin/sh. touch sub/conftst$i.h done echo "${am__include} ${am__quote}sub/conftest.Po${am__quote}" > confmf case $depmode in nosideeffect) # after this tag, mechanisms are not by side-effect, so they'll # only be used when explicitly requested if test "x$enable_dependency_tracking" = xyes; then continue else break fi ;; none) break ;; esac # We check with `-c' and `-o' for the sake of the "dashmstdout" # mode. It turns out that the SunPro C++ compiler does not properly # handle `-M -o', and we need to detect this. if depmode=$depmode \ source=sub/conftest.c object=sub/conftest.${OBJEXT-o} \ depfile=sub/conftest.Po tmpdepfile=sub/conftest.TPo \ $SHELL ./depcomp $depcc -c -o sub/conftest.${OBJEXT-o} sub/conftest.c \ >/dev/null 2>conftest.err && grep sub/conftst1.h sub/conftest.Po > /dev/null 2>&1 && grep sub/conftst6.h sub/conftest.Po > /dev/null 2>&1 && grep sub/conftest.${OBJEXT-o} sub/conftest.Po > /dev/null 2>&1 && ${MAKE-make} -s -f confmf > /dev/null 2>&1; then # icc doesn't choke on unknown options, it will just issue warnings # or remarks (even with -Werror). So we grep stderr for any message # that says an option was ignored or not supported. # When given -MP, icc 7.0 and 7.1 complain thusly: # icc: Command line warning: ignoring option '-M'; no argument required # The diagnosis changed in icc 8.0: # icc: Command line remark: option '-MP' not supported if (grep 'ignoring option' conftest.err || grep 'not supported' conftest.err) >/dev/null 2>&1; then :; else am_cv_CC_dependencies_compiler_type=$depmode break fi fi done cd .. rm -rf conftest.dir else am_cv_CC_dependencies_compiler_type=none fi fi { $as_echo "$as_me:$LINENO: result: $am_cv_CC_dependencies_compiler_type" >&5 $as_echo "$am_cv_CC_dependencies_compiler_type" >&6; } CCDEPMODE=depmode=$am_cv_CC_dependencies_compiler_type if test "x$enable_dependency_tracking" != xno \ && test "$am_cv_CC_dependencies_compiler_type" = gcc3; then am__fastdepCC_TRUE= am__fastdepCC_FALSE='#' else am__fastdepCC_TRUE='#' am__fastdepCC_FALSE= fi if test "x$GCC" != "xyes"; then a68g_ac_compiler=no { $as_echo "$as_me:$LINENO: WARNING: gcc is the preferred C compiler; configuring interpreter-only" >&5 $as_echo "$as_me: WARNING: gcc is the preferred C compiler; configuring interpreter-only" >&2;} else cat >>confdefs.h <<\_ACEOF #define HAVE_GCC 1 _ACEOF if test "x$enable_prescott" != "xno"; then CFLAGS="-O3 -fomit-frame-pointer -march=prescott -funroll-loops" enable_pic="no" fi { $as_echo "$as_me:$LINENO: checking whether $CC accepts -pedantic" >&5 $as_echo_n "checking whether $CC accepts -pedantic... " >&6; } a68g_ac_save_CFLAGS=$CFLAGS CFLAGS="$a68g_ac_save_CFLAGS -pedantic" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ int main () { ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then { $as_echo "$as_me:$LINENO: result: yes" >&5 $as_echo "yes" >&6; } else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 CFLAGS="$a68g_ac_save_CFLAGS" { $as_echo "$as_me:$LINENO: result: no" >&5 $as_echo "no" >&6; } fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext { $as_echo "$as_me:$LINENO: checking whether $CC accepts -W" >&5 $as_echo_n "checking whether $CC accepts -W... " >&6; } a68g_ac_save_CFLAGS=$CFLAGS CFLAGS="$a68g_ac_save_CFLAGS -W" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ int main () { ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then { $as_echo "$as_me:$LINENO: result: yes" >&5 $as_echo "yes" >&6; } else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 CFLAGS="$a68g_ac_save_CFLAGS" { $as_echo "$as_me:$LINENO: result: no" >&5 $as_echo "no" >&6; } fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext { $as_echo "$as_me:$LINENO: checking whether $CC accepts -Wall" >&5 $as_echo_n "checking whether $CC accepts -Wall... " >&6; } a68g_ac_save_CFLAGS=$CFLAGS CFLAGS="$a68g_ac_save_CFLAGS -Wall" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ int main () { ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then { $as_echo "$as_me:$LINENO: result: yes" >&5 $as_echo "yes" >&6; } else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 CFLAGS="$a68g_ac_save_CFLAGS" { $as_echo "$as_me:$LINENO: result: no" >&5 $as_echo "no" >&6; } fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext { $as_echo "$as_me:$LINENO: checking whether $CC accepts -Wextra" >&5 $as_echo_n "checking whether $CC accepts -Wextra... " >&6; } a68g_ac_save_CFLAGS=$CFLAGS CFLAGS="$a68g_ac_save_CFLAGS -Wextra" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ int main () { ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then { $as_echo "$as_me:$LINENO: result: yes" >&5 $as_echo "yes" >&6; } else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 CFLAGS="$a68g_ac_save_CFLAGS" { $as_echo "$as_me:$LINENO: result: no" >&5 $as_echo "no" >&6; } fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext { $as_echo "$as_me:$LINENO: checking whether $CC accepts -Wshadow" >&5 $as_echo_n "checking whether $CC accepts -Wshadow... " >&6; } a68g_ac_save_CFLAGS=$CFLAGS CFLAGS="$a68g_ac_save_CFLAGS -Wshadow" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ int main () { ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then { $as_echo "$as_me:$LINENO: result: yes" >&5 $as_echo "yes" >&6; } else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 CFLAGS="$a68g_ac_save_CFLAGS" { $as_echo "$as_me:$LINENO: result: no" >&5 $as_echo "no" >&6; } fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext # A68G_AC_PROG_CC_CFLAGS([-Wconversion]) Too much warnings! { $as_echo "$as_me:$LINENO: checking whether $CC accepts -Wstrict-prototypes" >&5 $as_echo_n "checking whether $CC accepts -Wstrict-prototypes... " >&6; } a68g_ac_save_CFLAGS=$CFLAGS CFLAGS="$a68g_ac_save_CFLAGS -Wstrict-prototypes" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ int main () { ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then { $as_echo "$as_me:$LINENO: result: yes" >&5 $as_echo "yes" >&6; } else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 CFLAGS="$a68g_ac_save_CFLAGS" { $as_echo "$as_me:$LINENO: result: no" >&5 $as_echo "no" >&6; } fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext { $as_echo "$as_me:$LINENO: checking whether $CC accepts -Wchar-subscripts" >&5 $as_echo_n "checking whether $CC accepts -Wchar-subscripts... " >&6; } a68g_ac_save_CFLAGS=$CFLAGS CFLAGS="$a68g_ac_save_CFLAGS -Wchar-subscripts" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ int main () { ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then { $as_echo "$as_me:$LINENO: result: yes" >&5 $as_echo "yes" >&6; } else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 CFLAGS="$a68g_ac_save_CFLAGS" { $as_echo "$as_me:$LINENO: result: no" >&5 $as_echo "no" >&6; } fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext # # Test on gcc capabilities. # # # Check -Wl,--export-dynamic, needed for creating shared objects. # # Check whether we can link to a particular function, not just whether we can link. # In fact, we must actually check that the resulting program runs. # a68g_ac_arg="-Wl,--export-dynamic" { $as_echo "$as_me:$LINENO: checking if $CC accepts $a68g_ac_arg" >&5 $as_echo_n "checking if $CC accepts $a68g_ac_arg... " >&6; } a68g_ac_save_LDFLAGS=$LDFLAGS LDFLAGS="$a68g_ac_save_LDFLAGS $a68g_ac_arg" if test "$cross_compiling" = yes; then { $as_echo "$as_me:$LINENO: result: assuming no" >&5 $as_echo "assuming no" >&6; } { $as_echo "$as_me:$LINENO: WARNING: --export-dynamic is not accepted; configuring interpreter-only" >&5 $as_echo "$as_me: WARNING: --export-dynamic is not accepted; configuring interpreter-only" >&2;} a68g_ac_compiler=no LDFLAGS=$a68g_ac_save_LDFLAGS else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ extern void exit (); void (*fptr) () = exit; int main () { ; return 0; } _ACEOF rm -f conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>&5 ac_status=$? $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='./conftest$ac_exeext' { (case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_try") 2>&5 ac_status=$? $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then { $as_echo "$as_me:$LINENO: result: yes" >&5 $as_echo "yes" >&6; } cat >>confdefs.h <<\_ACEOF #define HAVE_EXPORT_DYNAMIC 1 _ACEOF else $as_echo "$as_me: program exited with status $ac_status" >&5 $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ( exit $ac_status ) { $as_echo "$as_me:$LINENO: result: no" >&5 $as_echo "no" >&6; } { $as_echo "$as_me:$LINENO: WARNING: --export-dynamic is not accepted; configuring interpreter-only" >&5 $as_echo "$as_me: WARNING: --export-dynamic is not accepted; configuring interpreter-only" >&2;} a68g_ac_compiler=no LDFLAGS=$a68g_ac_save_LDFLAGS fi rm -rf conftest.dSYM rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext conftest.$ac_objext conftest.$ac_ext fi fi if test "x$a68g_ac_compiler" = "xyes"; then EXPORT_DYNAMIC_TRUE= EXPORT_DYNAMIC_FALSE='#' else EXPORT_DYNAMIC_TRUE='#' EXPORT_DYNAMIC_FALSE= fi # # Optionally, tune for a specific processor. # if test "x$enable_arch" != "xno"; then { $as_echo "$as_me:$LINENO: checking whether $CC accepts -march=$enable_arch" >&5 $as_echo_n "checking whether $CC accepts -march=$enable_arch... " >&6; } a68g_ac_save_CFLAGS=$CFLAGS a68g_ac_march="-march=$enable_arch" CFLAGS="$a68g_ac_save_CFLAGS $a68g_ac_march" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ int main () { ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then { $as_echo "$as_me:$LINENO: result: yes" >&5 $as_echo "yes" >&6; } cat >>confdefs.h <<_ACEOF #define HAVE_TUNING "$a68g_ac_march" _ACEOF else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 { $as_echo "$as_me:$LINENO: result: no" >&5 $as_echo "no" >&6; } { $as_echo "$as_me:$LINENO: WARNING: your CPU name is not accepted; resetting to default" >&5 $as_echo "$as_me: WARNING: your CPU name is not accepted; resetting to default" >&2;} CFLAGS="$a68g_ac_save_CFLAGS" fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi # # Some platforms want another or no PIC option. # if test "x$enable_compiler" = "xyes"; then if test "x$enable_pic" != "xno"; then { $as_echo "$as_me:$LINENO: checking whether $CC accepts $enable_pic" >&5 $as_echo_n "checking whether $CC accepts $enable_pic... " >&6; } a68g_ac_save_CFLAGS=$CFLAGS CFLAGS="$a68g_ac_save_CFLAGS $enable_pic" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ int main () { ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then { $as_echo "$as_me:$LINENO: result: yes" >&5 $as_echo "yes" >&6; } cat >>confdefs.h <<_ACEOF #define HAVE_PIC "$enable_pic" _ACEOF else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 { $as_echo "$as_me:$LINENO: result: no" >&5 $as_echo "no" >&6; } { $as_echo "$as_me:$LINENO: WARNING: your PIC option is not accepted; configuring interpreter-only" >&5 $as_echo "$as_me: WARNING: your PIC option is not accepted; configuring interpreter-only" >&2;} fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext CFLAGS="$a68g_ac_save_CFLAGS" fi fi if test "x$CC" != xcc; then { $as_echo "$as_me:$LINENO: checking whether $CC and cc understand -c and -o together" >&5 $as_echo_n "checking whether $CC and cc understand -c and -o together... " >&6; } else { $as_echo "$as_me:$LINENO: checking whether cc understands -c and -o together" >&5 $as_echo_n "checking whether cc understands -c and -o together... " >&6; } fi set dummy $CC; ac_cc=`$as_echo "$2" | sed 's/[^a-zA-Z0-9_]/_/g;s/^[0-9]/_/'` if { as_var=ac_cv_prog_cc_${ac_cc}_c_o; eval "test \"\${$as_var+set}\" = set"; }; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ int main () { ; return 0; } _ACEOF # Make sure it works both with $CC and with simple cc. # We do the test twice because some compilers refuse to overwrite an # existing .o file with -o, though they will create one. ac_try='$CC -c conftest.$ac_ext -o conftest2.$ac_objext >&5' rm -f conftest2.* if { (case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_try") 2>&5 ac_status=$? $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && test -f conftest2.$ac_objext && { (case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_try") 2>&5 ac_status=$? $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; then eval ac_cv_prog_cc_${ac_cc}_c_o=yes if test "x$CC" != xcc; then # Test first that cc exists at all. if { ac_try='cc -c conftest.$ac_ext >&5' { (case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_try") 2>&5 ac_status=$? $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then ac_try='cc -c conftest.$ac_ext -o conftest2.$ac_objext >&5' rm -f conftest2.* if { (case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_try") 2>&5 ac_status=$? $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && test -f conftest2.$ac_objext && { (case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_try") 2>&5 ac_status=$? $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; then # cc works too. : else # cc exists but doesn't like -o. eval ac_cv_prog_cc_${ac_cc}_c_o=no fi fi fi else eval ac_cv_prog_cc_${ac_cc}_c_o=no fi rm -f core conftest* fi if eval test \$ac_cv_prog_cc_${ac_cc}_c_o = yes; then { $as_echo "$as_me:$LINENO: result: yes" >&5 $as_echo "yes" >&6; } else { $as_echo "$as_me:$LINENO: result: no" >&5 $as_echo "no" >&6; } cat >>confdefs.h <<\_ACEOF #define NO_MINUS_C_MINUS_O 1 _ACEOF fi # FIXME: we rely on the cache variable name because # there is no other way. set dummy $CC ac_cc=`echo $2 | sed 's/[^a-zA-Z0-9_]/_/g;s/^[0-9]/_/'` if eval "test \"`echo '$ac_cv_prog_cc_'${ac_cc}_c_o`\" != yes"; then # Losing compiler, so override with the script. # FIXME: It is wrong to rewrite CC. # But if we don't then we get into trouble of one sort or another. # A longer-term fix would be to have automake use am__CC in this case, # and then we could set am__CC="\$(top_srcdir)/compile \$(CC)" CC="$am_aux_dir/compile $CC" fi ac_ext=c ac_cpp='$CPP $CPPFLAGS' ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' ac_compiler_gnu=$ac_cv_c_compiler_gnu { $as_echo "$as_me:$LINENO: checking how to run the C preprocessor" >&5 $as_echo_n "checking how to run the C preprocessor... " >&6; } # On Suns, sometimes $CPP names a directory. if test -n "$CPP" && test -d "$CPP"; then CPP= fi if test -z "$CPP"; then if test "${ac_cv_prog_CPP+set}" = set; then $as_echo_n "(cached) " >&6 else # Double quotes because CPP needs to be expanded for CPP in "$CC -E" "$CC -E -traditional-cpp" "/lib/cpp" do ac_preproc_ok=false for ac_c_preproc_warn_flag in '' yes do # Use a header file that comes with gcc, so configuring glibc # with a fresh cross-compiler works. # Prefer to if __STDC__ is defined, since # exists even on freestanding compilers. # On the NeXT, cc -E runs the code through the compiler's parser, # not just through cpp. "Syntax error" is here to catch this case. cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #ifdef __STDC__ # include #else # include #endif Syntax error _ACEOF if { (ac_try="$ac_cpp conftest.$ac_ext" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_cpp conftest.$ac_ext") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } >/dev/null && { test -z "$ac_c_preproc_warn_flag$ac_c_werror_flag" || test ! -s conftest.err }; then : else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 # Broken: fails on valid input. continue fi rm -f conftest.err conftest.$ac_ext # OK, works on sane cases. Now check whether nonexistent headers # can be detected and how. cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include _ACEOF if { (ac_try="$ac_cpp conftest.$ac_ext" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_cpp conftest.$ac_ext") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } >/dev/null && { test -z "$ac_c_preproc_warn_flag$ac_c_werror_flag" || test ! -s conftest.err }; then # Broken: success on invalid input. continue else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 # Passes both tests. ac_preproc_ok=: break fi rm -f conftest.err conftest.$ac_ext done # Because of `break', _AC_PREPROC_IFELSE's cleaning code was skipped. rm -f conftest.err conftest.$ac_ext if $ac_preproc_ok; then break fi done ac_cv_prog_CPP=$CPP fi CPP=$ac_cv_prog_CPP else ac_cv_prog_CPP=$CPP fi { $as_echo "$as_me:$LINENO: result: $CPP" >&5 $as_echo "$CPP" >&6; } ac_preproc_ok=false for ac_c_preproc_warn_flag in '' yes do # Use a header file that comes with gcc, so configuring glibc # with a fresh cross-compiler works. # Prefer to if __STDC__ is defined, since # exists even on freestanding compilers. # On the NeXT, cc -E runs the code through the compiler's parser, # not just through cpp. "Syntax error" is here to catch this case. cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #ifdef __STDC__ # include #else # include #endif Syntax error _ACEOF if { (ac_try="$ac_cpp conftest.$ac_ext" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_cpp conftest.$ac_ext") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } >/dev/null && { test -z "$ac_c_preproc_warn_flag$ac_c_werror_flag" || test ! -s conftest.err }; then : else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 # Broken: fails on valid input. continue fi rm -f conftest.err conftest.$ac_ext # OK, works on sane cases. Now check whether nonexistent headers # can be detected and how. cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include _ACEOF if { (ac_try="$ac_cpp conftest.$ac_ext" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_cpp conftest.$ac_ext") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } >/dev/null && { test -z "$ac_c_preproc_warn_flag$ac_c_werror_flag" || test ! -s conftest.err }; then # Broken: success on invalid input. continue else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 # Passes both tests. ac_preproc_ok=: break fi rm -f conftest.err conftest.$ac_ext done # Because of `break', _AC_PREPROC_IFELSE's cleaning code was skipped. rm -f conftest.err conftest.$ac_ext if $ac_preproc_ok; then : else { { $as_echo "$as_me:$LINENO: error: in \`$ac_pwd':" >&5 $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} { { $as_echo "$as_me:$LINENO: error: C preprocessor \"$CPP\" fails sanity check See \`config.log' for more details." >&5 $as_echo "$as_me: error: C preprocessor \"$CPP\" fails sanity check See \`config.log' for more details." >&2;} { (exit 1); exit 1; }; }; } fi ac_ext=c ac_cpp='$CPP $CPPFLAGS' ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' ac_compiler_gnu=$ac_cv_c_compiler_gnu { $as_echo "$as_me:$LINENO: types..." >&5 $as_echo "$as_me: types..." >&6;} { $as_echo "$as_me:$LINENO: checking for grep that handles long lines and -e" >&5 $as_echo_n "checking for grep that handles long lines and -e... " >&6; } if test "${ac_cv_path_GREP+set}" = set; then $as_echo_n "(cached) " >&6 else if test -z "$GREP"; then ac_path_GREP_found=false # Loop through the user's path and test for each of PROGNAME-LIST as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH$PATH_SEPARATOR/usr/xpg4/bin do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_prog in grep ggrep; do for ac_exec_ext in '' $ac_executable_extensions; do ac_path_GREP="$as_dir/$ac_prog$ac_exec_ext" { test -f "$ac_path_GREP" && $as_test_x "$ac_path_GREP"; } || continue # Check for GNU ac_path_GREP and select it if it is found. # Check for GNU $ac_path_GREP case `"$ac_path_GREP" --version 2>&1` in *GNU*) ac_cv_path_GREP="$ac_path_GREP" ac_path_GREP_found=:;; *) ac_count=0 $as_echo_n 0123456789 >"conftest.in" while : do cat "conftest.in" "conftest.in" >"conftest.tmp" mv "conftest.tmp" "conftest.in" cp "conftest.in" "conftest.nl" $as_echo 'GREP' >> "conftest.nl" "$ac_path_GREP" -e 'GREP$' -e '-(cannot match)-' < "conftest.nl" >"conftest.out" 2>/dev/null || break diff "conftest.out" "conftest.nl" >/dev/null 2>&1 || break ac_count=`expr $ac_count + 1` if test $ac_count -gt ${ac_path_GREP_max-0}; then # Best one so far, save it but keep looking for a better one ac_cv_path_GREP="$ac_path_GREP" ac_path_GREP_max=$ac_count fi # 10*(2^10) chars as input seems more than enough test $ac_count -gt 10 && break done rm -f conftest.in conftest.tmp conftest.nl conftest.out;; esac $ac_path_GREP_found && break 3 done done done IFS=$as_save_IFS if test -z "$ac_cv_path_GREP"; then { { $as_echo "$as_me:$LINENO: error: no acceptable grep could be found in $PATH$PATH_SEPARATOR/usr/xpg4/bin" >&5 $as_echo "$as_me: error: no acceptable grep could be found in $PATH$PATH_SEPARATOR/usr/xpg4/bin" >&2;} { (exit 1); exit 1; }; } fi else ac_cv_path_GREP=$GREP fi fi { $as_echo "$as_me:$LINENO: result: $ac_cv_path_GREP" >&5 $as_echo "$ac_cv_path_GREP" >&6; } GREP="$ac_cv_path_GREP" { $as_echo "$as_me:$LINENO: checking for egrep" >&5 $as_echo_n "checking for egrep... " >&6; } if test "${ac_cv_path_EGREP+set}" = set; then $as_echo_n "(cached) " >&6 else if echo a | $GREP -E '(a|b)' >/dev/null 2>&1 then ac_cv_path_EGREP="$GREP -E" else if test -z "$EGREP"; then ac_path_EGREP_found=false # Loop through the user's path and test for each of PROGNAME-LIST as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH$PATH_SEPARATOR/usr/xpg4/bin do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_prog in egrep; do for ac_exec_ext in '' $ac_executable_extensions; do ac_path_EGREP="$as_dir/$ac_prog$ac_exec_ext" { test -f "$ac_path_EGREP" && $as_test_x "$ac_path_EGREP"; } || continue # Check for GNU ac_path_EGREP and select it if it is found. # Check for GNU $ac_path_EGREP case `"$ac_path_EGREP" --version 2>&1` in *GNU*) ac_cv_path_EGREP="$ac_path_EGREP" ac_path_EGREP_found=:;; *) ac_count=0 $as_echo_n 0123456789 >"conftest.in" while : do cat "conftest.in" "conftest.in" >"conftest.tmp" mv "conftest.tmp" "conftest.in" cp "conftest.in" "conftest.nl" $as_echo 'EGREP' >> "conftest.nl" "$ac_path_EGREP" 'EGREP$' < "conftest.nl" >"conftest.out" 2>/dev/null || break diff "conftest.out" "conftest.nl" >/dev/null 2>&1 || break ac_count=`expr $ac_count + 1` if test $ac_count -gt ${ac_path_EGREP_max-0}; then # Best one so far, save it but keep looking for a better one ac_cv_path_EGREP="$ac_path_EGREP" ac_path_EGREP_max=$ac_count fi # 10*(2^10) chars as input seems more than enough test $ac_count -gt 10 && break done rm -f conftest.in conftest.tmp conftest.nl conftest.out;; esac $ac_path_EGREP_found && break 3 done done done IFS=$as_save_IFS if test -z "$ac_cv_path_EGREP"; then { { $as_echo "$as_me:$LINENO: error: no acceptable egrep could be found in $PATH$PATH_SEPARATOR/usr/xpg4/bin" >&5 $as_echo "$as_me: error: no acceptable egrep could be found in $PATH$PATH_SEPARATOR/usr/xpg4/bin" >&2;} { (exit 1); exit 1; }; } fi else ac_cv_path_EGREP=$EGREP fi fi fi { $as_echo "$as_me:$LINENO: result: $ac_cv_path_EGREP" >&5 $as_echo "$ac_cv_path_EGREP" >&6; } EGREP="$ac_cv_path_EGREP" { $as_echo "$as_me:$LINENO: checking for ANSI C header files" >&5 $as_echo_n "checking for ANSI C header files... " >&6; } if test "${ac_cv_header_stdc+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include int main () { ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_header_stdc=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_header_stdc=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext if test $ac_cv_header_stdc = yes; then # SunOS 4.x string.h does not declare mem*, contrary to ANSI. cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include _ACEOF if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | $EGREP "memchr" >/dev/null 2>&1; then : else ac_cv_header_stdc=no fi rm -f conftest* fi if test $ac_cv_header_stdc = yes; then # ISC 2.0.2 stdlib.h does not declare free, contrary to ANSI. cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include _ACEOF if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | $EGREP "free" >/dev/null 2>&1; then : else ac_cv_header_stdc=no fi rm -f conftest* fi if test $ac_cv_header_stdc = yes; then # /bin/cc in Irix-4.0.5 gets non-ANSI ctype macros unless using -ansi. if test "$cross_compiling" = yes; then : else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #if ((' ' & 0x0FF) == 0x020) # define ISLOWER(c) ('a' <= (c) && (c) <= 'z') # define TOUPPER(c) (ISLOWER(c) ? 'A' + ((c) - 'a') : (c)) #else # define ISLOWER(c) \ (('a' <= (c) && (c) <= 'i') \ || ('j' <= (c) && (c) <= 'r') \ || ('s' <= (c) && (c) <= 'z')) # define TOUPPER(c) (ISLOWER(c) ? ((c) | 0x40) : (c)) #endif #define XOR(e, f) (((e) && !(f)) || (!(e) && (f))) int main () { int i; for (i = 0; i < 256; i++) if (XOR (islower (i), ISLOWER (i)) || toupper (i) != TOUPPER (i)) return 2; return 0; } _ACEOF rm -f conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>&5 ac_status=$? $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='./conftest$ac_exeext' { (case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_try") 2>&5 ac_status=$? $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then : else $as_echo "$as_me: program exited with status $ac_status" >&5 $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ( exit $ac_status ) ac_cv_header_stdc=no fi rm -rf conftest.dSYM rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext conftest.$ac_objext conftest.$ac_ext fi fi fi { $as_echo "$as_me:$LINENO: result: $ac_cv_header_stdc" >&5 $as_echo "$ac_cv_header_stdc" >&6; } if test $ac_cv_header_stdc = yes; then cat >>confdefs.h <<\_ACEOF #define STDC_HEADERS 1 _ACEOF fi # On IRIX 5.3, sys/types and inttypes.h are conflicting. for ac_header in sys/types.h sys/stat.h stdlib.h string.h memory.h strings.h \ inttypes.h stdint.h unistd.h do as_ac_Header=`$as_echo "ac_cv_header_$ac_header" | $as_tr_sh` { $as_echo "$as_me:$LINENO: checking for $ac_header" >&5 $as_echo_n "checking for $ac_header... " >&6; } if { as_var=$as_ac_Header; eval "test \"\${$as_var+set}\" = set"; }; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ $ac_includes_default #include <$ac_header> _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then eval "$as_ac_Header=yes" else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 eval "$as_ac_Header=no" fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi ac_res=`eval 'as_val=${'$as_ac_Header'} $as_echo "$as_val"'` { $as_echo "$as_me:$LINENO: result: $ac_res" >&5 $as_echo "$ac_res" >&6; } as_val=`eval 'as_val=${'$as_ac_Header'} $as_echo "$as_val"'` if test "x$as_val" = x""yes; then cat >>confdefs.h <<_ACEOF #define `$as_echo "HAVE_$ac_header" | $as_tr_cpp` 1 _ACEOF fi done { $as_echo "$as_me:$LINENO: checking whether char is unsigned" >&5 $as_echo_n "checking whether char is unsigned... " >&6; } if test "${ac_cv_c_char_unsigned+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ $ac_includes_default int main () { static int test_array [1 - 2 * !(((char) -1) < 0)]; test_array [0] = 0 ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_c_char_unsigned=no else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_c_char_unsigned=yes fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_c_char_unsigned" >&5 $as_echo "$ac_cv_c_char_unsigned" >&6; } if test $ac_cv_c_char_unsigned = yes && test "$GCC" != yes; then cat >>confdefs.h <<\_ACEOF #define __CHAR_UNSIGNED__ 1 _ACEOF fi { $as_echo "$as_me:$LINENO: checking for mode_t" >&5 $as_echo_n "checking for mode_t... " >&6; } if test "${ac_cv_type_mode_t+set}" = set; then $as_echo_n "(cached) " >&6 else ac_cv_type_mode_t=no cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ $ac_includes_default int main () { if (sizeof (mode_t)) return 0; ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ $ac_includes_default int main () { if (sizeof ((mode_t))) return 0; ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then : else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_type_mode_t=yes fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_type_mode_t" >&5 $as_echo "$ac_cv_type_mode_t" >&6; } if test "x$ac_cv_type_mode_t" = x""yes; then : else cat >>confdefs.h <<_ACEOF #define mode_t int _ACEOF fi { $as_echo "$as_me:$LINENO: checking for size_t" >&5 $as_echo_n "checking for size_t... " >&6; } if test "${ac_cv_type_size_t+set}" = set; then $as_echo_n "(cached) " >&6 else ac_cv_type_size_t=no cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ $ac_includes_default int main () { if (sizeof (size_t)) return 0; ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ $ac_includes_default int main () { if (sizeof ((size_t))) return 0; ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then : else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_type_size_t=yes fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_type_size_t" >&5 $as_echo "$ac_cv_type_size_t" >&6; } if test "x$ac_cv_type_size_t" = x""yes; then : else cat >>confdefs.h <<_ACEOF #define size_t unsigned int _ACEOF fi { $as_echo "$as_me:$LINENO: checking for ssize_t" >&5 $as_echo_n "checking for ssize_t... " >&6; } if test "${ac_cv_type_ssize_t+set}" = set; then $as_echo_n "(cached) " >&6 else ac_cv_type_ssize_t=no cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ $ac_includes_default int main () { if (sizeof (ssize_t)) return 0; ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ $ac_includes_default int main () { if (sizeof ((ssize_t))) return 0; ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then : else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_type_ssize_t=yes fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_type_ssize_t" >&5 $as_echo "$ac_cv_type_ssize_t" >&6; } if test "x$ac_cv_type_ssize_t" = x""yes; then : else cat >>confdefs.h <<_ACEOF #define ssize_t int _ACEOF fi { $as_echo "$as_me:$LINENO: checking for uint16_t" >&5 $as_echo_n "checking for uint16_t... " >&6; } if test "${ac_cv_c_uint16_t+set}" = set; then $as_echo_n "(cached) " >&6 else ac_cv_c_uint16_t=no for ac_type in 'uint16_t' 'unsigned int' 'unsigned long int' \ 'unsigned long long int' 'unsigned short int' 'unsigned char'; do cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ $ac_includes_default int main () { static int test_array [1 - 2 * !(($ac_type) -1 >> (16 - 1) == 1)]; test_array [0] = 0 ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then case $ac_type in uint16_t) ac_cv_c_uint16_t=yes ;; *) ac_cv_c_uint16_t=$ac_type ;; esac else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext test "$ac_cv_c_uint16_t" != no && break done fi { $as_echo "$as_me:$LINENO: result: $ac_cv_c_uint16_t" >&5 $as_echo "$ac_cv_c_uint16_t" >&6; } case $ac_cv_c_uint16_t in #( no|yes) ;; #( *) cat >>confdefs.h <<_ACEOF #define uint16_t $ac_cv_c_uint16_t _ACEOF ;; esac { $as_echo "$as_me:$LINENO: checking __off_t or off_t" >&5 $as_echo_n "checking __off_t or off_t... " >&6; } cat >conftest.$ac_ext <<_ACEOF #include #include __off_t dummy; _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then { $as_echo "$as_me:$LINENO: result: __off_t" >&5 $as_echo "__off_t" >&6; } else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 { $as_echo "$as_me:$LINENO: result: off_t" >&5 $as_echo "off_t" >&6; } cat >>confdefs.h <<\_ACEOF #define __off_t off_t _ACEOF fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext { $as_echo "$as_me:$LINENO: checking __pid_t or pid_t" >&5 $as_echo_n "checking __pid_t or pid_t... " >&6; } cat >conftest.$ac_ext <<_ACEOF #include #include __pid_t dummy; _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then { $as_echo "$as_me:$LINENO: result: __pid_t" >&5 $as_echo "__pid_t" >&6; } else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 { $as_echo "$as_me:$LINENO: result: pid_t" >&5 $as_echo "pid_t" >&6; } cat >>confdefs.h <<\_ACEOF #define __pid_t pid_t _ACEOF fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext { $as_echo "$as_me:$LINENO: checking __mode_t or mode_t" >&5 $as_echo_n "checking __mode_t or mode_t... " >&6; } cat >conftest.$ac_ext <<_ACEOF #include #include __mode_t dummy; _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then { $as_echo "$as_me:$LINENO: result: __mode_t" >&5 $as_echo "__mode_t" >&6; } else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 { $as_echo "$as_me:$LINENO: result: mode_t" >&5 $as_echo "mode_t" >&6; } cat >>confdefs.h <<\_ACEOF #define __mode_t mode_t _ACEOF fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext # # Extra include directories. # { $as_echo "$as_me:$LINENO: extra include directories..." >&5 $as_echo "$as_me: extra include directories..." >&6;} if test -d /usr/local/pgsql/include; then cat >>confdefs.h <<\_ACEOF #define HAVE_USR_LOCAL_PGSQL_INCLUDE 1 _ACEOF CFLAGS="$CFLAGS -I/usr/local/pgsql/include" CPPFLAGS="$CPPFLAGS -I/usr/local/pgsql/include" CXXFLAGS="$CXXFLAGS -I/usr/local/pgsql/include" LDFLAGS="$LDFLAGS -L/usr/local/pgsql/lib" fi if test -d /usr/pkg/pgsql/include; then cat >>confdefs.h <<\_ACEOF #define HAVE_USR_PKG_PGSQL_INCLUDE 1 _ACEOF CFLAGS="$CFLAGS -I/usr/pkg/pgsql/include" CPPFLAGS="$CPPFLAGS -I/usr/pkg/pgsql/include" CXXFLAGS="$CXXFLAGS -I/usr/pkg/pgsql/include" LDFLAGS="$LDFLAGS -L/usr/pkg/pgsql/lib" fi if test -d /opt/local/pgsql/include; then cat >>confdefs.h <<\_ACEOF #define HAVE_OPT_LOCAL_PGSQL_INCLUDE 1 _ACEOF CFLAGS="$CFLAGS -I/opt/local/pgsql/include" CPPFLAGS="$CPPFLAGS -I/opt/local/pgsql/include" CXXFLAGS="$CXXFLAGS -I/opt/local/pgsql/include" LDFLAGS="$LDFLAGS -L/opt/local/pgsql/lib" fi # # Checks for header files. # { $as_echo "$as_me:$LINENO: standard header files..." >&5 $as_echo "$as_me: standard header files..." >&6;} # # test is GSL proof. # for ac_header in math.h do as_ac_Header=`$as_echo "ac_cv_header_$ac_header" | $as_tr_sh` if { as_var=$as_ac_Header; eval "test \"\${$as_var+set}\" = set"; }; then { $as_echo "$as_me:$LINENO: checking for $ac_header" >&5 $as_echo_n "checking for $ac_header... " >&6; } if { as_var=$as_ac_Header; eval "test \"\${$as_var+set}\" = set"; }; then $as_echo_n "(cached) " >&6 fi ac_res=`eval 'as_val=${'$as_ac_Header'} $as_echo "$as_val"'` { $as_echo "$as_me:$LINENO: result: $ac_res" >&5 $as_echo "$ac_res" >&6; } else # Is the header compilable? { $as_echo "$as_me:$LINENO: checking $ac_header usability" >&5 $as_echo_n "checking $ac_header usability... " >&6; } cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ $ac_includes_default #include <$ac_header> _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_header_compiler=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_header_compiler=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext { $as_echo "$as_me:$LINENO: result: $ac_header_compiler" >&5 $as_echo "$ac_header_compiler" >&6; } # Is the header present? { $as_echo "$as_me:$LINENO: checking $ac_header presence" >&5 $as_echo_n "checking $ac_header presence... " >&6; } cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include <$ac_header> _ACEOF if { (ac_try="$ac_cpp conftest.$ac_ext" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_cpp conftest.$ac_ext") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } >/dev/null && { test -z "$ac_c_preproc_warn_flag$ac_c_werror_flag" || test ! -s conftest.err }; then ac_header_preproc=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_header_preproc=no fi rm -f conftest.err conftest.$ac_ext { $as_echo "$as_me:$LINENO: result: $ac_header_preproc" >&5 $as_echo "$ac_header_preproc" >&6; } # So? What about this header? case $ac_header_compiler:$ac_header_preproc:$ac_c_preproc_warn_flag in yes:no: ) { $as_echo "$as_me:$LINENO: WARNING: $ac_header: accepted by the compiler, rejected by the preprocessor!" >&5 $as_echo "$as_me: WARNING: $ac_header: accepted by the compiler, rejected by the preprocessor!" >&2;} { $as_echo "$as_me:$LINENO: WARNING: $ac_header: proceeding with the compiler's result" >&5 $as_echo "$as_me: WARNING: $ac_header: proceeding with the compiler's result" >&2;} ac_header_preproc=yes ;; no:yes:* ) { $as_echo "$as_me:$LINENO: WARNING: $ac_header: present but cannot be compiled" >&5 $as_echo "$as_me: WARNING: $ac_header: present but cannot be compiled" >&2;} { $as_echo "$as_me:$LINENO: WARNING: $ac_header: check for missing prerequisite headers?" >&5 $as_echo "$as_me: WARNING: $ac_header: check for missing prerequisite headers?" >&2;} { $as_echo "$as_me:$LINENO: WARNING: $ac_header: see the Autoconf documentation" >&5 $as_echo "$as_me: WARNING: $ac_header: see the Autoconf documentation" >&2;} { $as_echo "$as_me:$LINENO: WARNING: $ac_header: section \"Present But Cannot Be Compiled\"" >&5 $as_echo "$as_me: WARNING: $ac_header: section \"Present But Cannot Be Compiled\"" >&2;} { $as_echo "$as_me:$LINENO: WARNING: $ac_header: proceeding with the preprocessor's result" >&5 $as_echo "$as_me: WARNING: $ac_header: proceeding with the preprocessor's result" >&2;} { $as_echo "$as_me:$LINENO: WARNING: $ac_header: in the future, the compiler will take precedence" >&5 $as_echo "$as_me: WARNING: $ac_header: in the future, the compiler will take precedence" >&2;} ( cat <<\_ASBOX ## ------------------------------------------------------- ## ## Report this to Marcel van der Veer ## ## ------------------------------------------------------- ## _ASBOX ) | sed "s/^/$as_me: WARNING: /" >&2 ;; esac { $as_echo "$as_me:$LINENO: checking for $ac_header" >&5 $as_echo_n "checking for $ac_header... " >&6; } if { as_var=$as_ac_Header; eval "test \"\${$as_var+set}\" = set"; }; then $as_echo_n "(cached) " >&6 else eval "$as_ac_Header=\$ac_header_preproc" fi ac_res=`eval 'as_val=${'$as_ac_Header'} $as_echo "$as_val"'` { $as_echo "$as_me:$LINENO: result: $ac_res" >&5 $as_echo "$ac_res" >&6; } fi as_val=`eval 'as_val=${'$as_ac_Header'} $as_echo "$as_val"'` if test "x$as_val" = x""yes; then cat >>confdefs.h <<_ACEOF #define `$as_echo "HAVE_$ac_header" | $as_tr_cpp` 1 _ACEOF fi done { $as_echo "$as_me:$LINENO: checking for cos in -lm" >&5 $as_echo_n "checking for cos in -lm... " >&6; } if test "${ac_cv_lib_m_cos+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lm $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char cos (); int main () { return cos (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_m_cos=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_m_cos=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_m_cos" >&5 $as_echo "$ac_cv_lib_m_cos" >&6; } if test "x$ac_cv_lib_m_cos" = x""yes; then cat >>confdefs.h <<_ACEOF #define HAVE_LIBM 1 _ACEOF LIBS="-lm $LIBS" fi { $as_echo "$as_me:$LINENO: checking for ANSI C header files" >&5 $as_echo_n "checking for ANSI C header files... " >&6; } if test "${ac_cv_header_stdc+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include int main () { ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_header_stdc=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_header_stdc=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext if test $ac_cv_header_stdc = yes; then # SunOS 4.x string.h does not declare mem*, contrary to ANSI. cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include _ACEOF if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | $EGREP "memchr" >/dev/null 2>&1; then : else ac_cv_header_stdc=no fi rm -f conftest* fi if test $ac_cv_header_stdc = yes; then # ISC 2.0.2 stdlib.h does not declare free, contrary to ANSI. cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include _ACEOF if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | $EGREP "free" >/dev/null 2>&1; then : else ac_cv_header_stdc=no fi rm -f conftest* fi if test $ac_cv_header_stdc = yes; then # /bin/cc in Irix-4.0.5 gets non-ANSI ctype macros unless using -ansi. if test "$cross_compiling" = yes; then : else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #if ((' ' & 0x0FF) == 0x020) # define ISLOWER(c) ('a' <= (c) && (c) <= 'z') # define TOUPPER(c) (ISLOWER(c) ? 'A' + ((c) - 'a') : (c)) #else # define ISLOWER(c) \ (('a' <= (c) && (c) <= 'i') \ || ('j' <= (c) && (c) <= 'r') \ || ('s' <= (c) && (c) <= 'z')) # define TOUPPER(c) (ISLOWER(c) ? ((c) | 0x40) : (c)) #endif #define XOR(e, f) (((e) && !(f)) || (!(e) && (f))) int main () { int i; for (i = 0; i < 256; i++) if (XOR (islower (i), ISLOWER (i)) || toupper (i) != TOUPPER (i)) return 2; return 0; } _ACEOF rm -f conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>&5 ac_status=$? $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='./conftest$ac_exeext' { (case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_try") 2>&5 ac_status=$? $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then : else $as_echo "$as_me: program exited with status $ac_status" >&5 $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ( exit $ac_status ) ac_cv_header_stdc=no fi rm -rf conftest.dSYM rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext conftest.$ac_objext conftest.$ac_ext fi fi fi { $as_echo "$as_me:$LINENO: result: $ac_cv_header_stdc" >&5 $as_echo "$ac_cv_header_stdc" >&6; } if test $ac_cv_header_stdc = yes; then cat >>confdefs.h <<\_ACEOF #define STDC_HEADERS 1 _ACEOF fi { $as_echo "$as_me:$LINENO: checking whether to enable assertions" >&5 $as_echo_n "checking whether to enable assertions... " >&6; } # Check whether --enable-assert was given. if test "${enable_assert+set}" = set; then enableval=$enable_assert; { $as_echo "$as_me:$LINENO: result: no" >&5 $as_echo "no" >&6; } cat >>confdefs.h <<\_ACEOF #define NDEBUG 1 _ACEOF else { $as_echo "$as_me:$LINENO: result: yes" >&5 $as_echo "yes" >&6; } fi ac_header_dirent=no for ac_hdr in dirent.h sys/ndir.h sys/dir.h ndir.h; do as_ac_Header=`$as_echo "ac_cv_header_dirent_$ac_hdr" | $as_tr_sh` { $as_echo "$as_me:$LINENO: checking for $ac_hdr that defines DIR" >&5 $as_echo_n "checking for $ac_hdr that defines DIR... " >&6; } if { as_var=$as_ac_Header; eval "test \"\${$as_var+set}\" = set"; }; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include <$ac_hdr> int main () { if ((DIR *) 0) return 0; ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then eval "$as_ac_Header=yes" else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 eval "$as_ac_Header=no" fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi ac_res=`eval 'as_val=${'$as_ac_Header'} $as_echo "$as_val"'` { $as_echo "$as_me:$LINENO: result: $ac_res" >&5 $as_echo "$ac_res" >&6; } as_val=`eval 'as_val=${'$as_ac_Header'} $as_echo "$as_val"'` if test "x$as_val" = x""yes; then cat >>confdefs.h <<_ACEOF #define `$as_echo "HAVE_$ac_hdr" | $as_tr_cpp` 1 _ACEOF ac_header_dirent=$ac_hdr; break fi done # Two versions of opendir et al. are in -ldir and -lx on SCO Xenix. if test $ac_header_dirent = dirent.h; then { $as_echo "$as_me:$LINENO: checking for library containing opendir" >&5 $as_echo_n "checking for library containing opendir... " >&6; } if test "${ac_cv_search_opendir+set}" = set; then $as_echo_n "(cached) " >&6 else ac_func_search_save_LIBS=$LIBS cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char opendir (); int main () { return opendir (); ; return 0; } _ACEOF for ac_lib in '' dir; do if test -z "$ac_lib"; then ac_res="none required" else ac_res=-l$ac_lib LIBS="-l$ac_lib $ac_func_search_save_LIBS" fi rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_search_opendir=$ac_res else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext if test "${ac_cv_search_opendir+set}" = set; then break fi done if test "${ac_cv_search_opendir+set}" = set; then : else ac_cv_search_opendir=no fi rm conftest.$ac_ext LIBS=$ac_func_search_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_search_opendir" >&5 $as_echo "$ac_cv_search_opendir" >&6; } ac_res=$ac_cv_search_opendir if test "$ac_res" != no; then test "$ac_res" = "none required" || LIBS="$ac_res $LIBS" fi else { $as_echo "$as_me:$LINENO: checking for library containing opendir" >&5 $as_echo_n "checking for library containing opendir... " >&6; } if test "${ac_cv_search_opendir+set}" = set; then $as_echo_n "(cached) " >&6 else ac_func_search_save_LIBS=$LIBS cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char opendir (); int main () { return opendir (); ; return 0; } _ACEOF for ac_lib in '' x; do if test -z "$ac_lib"; then ac_res="none required" else ac_res=-l$ac_lib LIBS="-l$ac_lib $ac_func_search_save_LIBS" fi rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_search_opendir=$ac_res else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext if test "${ac_cv_search_opendir+set}" = set; then break fi done if test "${ac_cv_search_opendir+set}" = set; then : else ac_cv_search_opendir=no fi rm conftest.$ac_ext LIBS=$ac_func_search_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_search_opendir" >&5 $as_echo "$ac_cv_search_opendir" >&6; } ac_res=$ac_cv_search_opendir if test "$ac_res" != no; then test "$ac_res" = "none required" || LIBS="$ac_res $LIBS" fi fi { $as_echo "$as_me:$LINENO: checking for sys/wait.h that is POSIX.1 compatible" >&5 $as_echo_n "checking for sys/wait.h that is POSIX.1 compatible... " >&6; } if test "${ac_cv_header_sys_wait_h+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #ifndef WEXITSTATUS # define WEXITSTATUS(stat_val) ((unsigned int) (stat_val) >> 8) #endif #ifndef WIFEXITED # define WIFEXITED(stat_val) (((stat_val) & 255) == 0) #endif int main () { int s; wait (&s); s = WIFEXITED (s) ? WEXITSTATUS (s) : 1; ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_header_sys_wait_h=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_header_sys_wait_h=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_header_sys_wait_h" >&5 $as_echo "$ac_cv_header_sys_wait_h" >&6; } if test $ac_cv_header_sys_wait_h = yes; then cat >>confdefs.h <<\_ACEOF #define HAVE_SYS_WAIT_H 1 _ACEOF fi { $as_echo "$as_me:$LINENO: checking whether termios.h defines TIOCGWINSZ" >&5 $as_echo_n "checking whether termios.h defines TIOCGWINSZ... " >&6; } if test "${ac_cv_sys_tiocgwinsz_in_termios_h+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #ifdef TIOCGWINSZ yes #endif _ACEOF if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | $EGREP "yes" >/dev/null 2>&1; then ac_cv_sys_tiocgwinsz_in_termios_h=yes else ac_cv_sys_tiocgwinsz_in_termios_h=no fi rm -f conftest* fi { $as_echo "$as_me:$LINENO: result: $ac_cv_sys_tiocgwinsz_in_termios_h" >&5 $as_echo "$ac_cv_sys_tiocgwinsz_in_termios_h" >&6; } if test $ac_cv_sys_tiocgwinsz_in_termios_h != yes; then { $as_echo "$as_me:$LINENO: checking whether sys/ioctl.h defines TIOCGWINSZ" >&5 $as_echo_n "checking whether sys/ioctl.h defines TIOCGWINSZ... " >&6; } if test "${ac_cv_sys_tiocgwinsz_in_sys_ioctl_h+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #ifdef TIOCGWINSZ yes #endif _ACEOF if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | $EGREP "yes" >/dev/null 2>&1; then ac_cv_sys_tiocgwinsz_in_sys_ioctl_h=yes else ac_cv_sys_tiocgwinsz_in_sys_ioctl_h=no fi rm -f conftest* fi { $as_echo "$as_me:$LINENO: result: $ac_cv_sys_tiocgwinsz_in_sys_ioctl_h" >&5 $as_echo "$ac_cv_sys_tiocgwinsz_in_sys_ioctl_h" >&6; } if test $ac_cv_sys_tiocgwinsz_in_sys_ioctl_h = yes; then cat >>confdefs.h <<\_ACEOF #define GWINSZ_IN_SYS_IOCTL 1 _ACEOF fi fi for ac_header in assert.h ctype.h errno.h fcntl.h float.h limits.h netdb.h netinet/in.h regex.h setjmp.h signal.h stdarg.h stddef.h stdio.h sys/ioctl.h sys/resource.h sys/socket.h sys/time.h termios.h time.h do as_ac_Header=`$as_echo "ac_cv_header_$ac_header" | $as_tr_sh` if { as_var=$as_ac_Header; eval "test \"\${$as_var+set}\" = set"; }; then { $as_echo "$as_me:$LINENO: checking for $ac_header" >&5 $as_echo_n "checking for $ac_header... " >&6; } if { as_var=$as_ac_Header; eval "test \"\${$as_var+set}\" = set"; }; then $as_echo_n "(cached) " >&6 fi ac_res=`eval 'as_val=${'$as_ac_Header'} $as_echo "$as_val"'` { $as_echo "$as_me:$LINENO: result: $ac_res" >&5 $as_echo "$ac_res" >&6; } else # Is the header compilable? { $as_echo "$as_me:$LINENO: checking $ac_header usability" >&5 $as_echo_n "checking $ac_header usability... " >&6; } cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ $ac_includes_default #include <$ac_header> _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_header_compiler=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_header_compiler=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext { $as_echo "$as_me:$LINENO: result: $ac_header_compiler" >&5 $as_echo "$ac_header_compiler" >&6; } # Is the header present? { $as_echo "$as_me:$LINENO: checking $ac_header presence" >&5 $as_echo_n "checking $ac_header presence... " >&6; } cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include <$ac_header> _ACEOF if { (ac_try="$ac_cpp conftest.$ac_ext" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_cpp conftest.$ac_ext") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } >/dev/null && { test -z "$ac_c_preproc_warn_flag$ac_c_werror_flag" || test ! -s conftest.err }; then ac_header_preproc=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_header_preproc=no fi rm -f conftest.err conftest.$ac_ext { $as_echo "$as_me:$LINENO: result: $ac_header_preproc" >&5 $as_echo "$ac_header_preproc" >&6; } # So? What about this header? case $ac_header_compiler:$ac_header_preproc:$ac_c_preproc_warn_flag in yes:no: ) { $as_echo "$as_me:$LINENO: WARNING: $ac_header: accepted by the compiler, rejected by the preprocessor!" >&5 $as_echo "$as_me: WARNING: $ac_header: accepted by the compiler, rejected by the preprocessor!" >&2;} { $as_echo "$as_me:$LINENO: WARNING: $ac_header: proceeding with the compiler's result" >&5 $as_echo "$as_me: WARNING: $ac_header: proceeding with the compiler's result" >&2;} ac_header_preproc=yes ;; no:yes:* ) { $as_echo "$as_me:$LINENO: WARNING: $ac_header: present but cannot be compiled" >&5 $as_echo "$as_me: WARNING: $ac_header: present but cannot be compiled" >&2;} { $as_echo "$as_me:$LINENO: WARNING: $ac_header: check for missing prerequisite headers?" >&5 $as_echo "$as_me: WARNING: $ac_header: check for missing prerequisite headers?" >&2;} { $as_echo "$as_me:$LINENO: WARNING: $ac_header: see the Autoconf documentation" >&5 $as_echo "$as_me: WARNING: $ac_header: see the Autoconf documentation" >&2;} { $as_echo "$as_me:$LINENO: WARNING: $ac_header: section \"Present But Cannot Be Compiled\"" >&5 $as_echo "$as_me: WARNING: $ac_header: section \"Present But Cannot Be Compiled\"" >&2;} { $as_echo "$as_me:$LINENO: WARNING: $ac_header: proceeding with the preprocessor's result" >&5 $as_echo "$as_me: WARNING: $ac_header: proceeding with the preprocessor's result" >&2;} { $as_echo "$as_me:$LINENO: WARNING: $ac_header: in the future, the compiler will take precedence" >&5 $as_echo "$as_me: WARNING: $ac_header: in the future, the compiler will take precedence" >&2;} ( cat <<\_ASBOX ## ------------------------------------------------------- ## ## Report this to Marcel van der Veer ## ## ------------------------------------------------------- ## _ASBOX ) | sed "s/^/$as_me: WARNING: /" >&2 ;; esac { $as_echo "$as_me:$LINENO: checking for $ac_header" >&5 $as_echo_n "checking for $ac_header... " >&6; } if { as_var=$as_ac_Header; eval "test \"\${$as_var+set}\" = set"; }; then $as_echo_n "(cached) " >&6 else eval "$as_ac_Header=\$ac_header_preproc" fi ac_res=`eval 'as_val=${'$as_ac_Header'} $as_echo "$as_val"'` { $as_echo "$as_me:$LINENO: result: $ac_res" >&5 $as_echo "$ac_res" >&6; } fi as_val=`eval 'as_val=${'$as_ac_Header'} $as_echo "$as_val"'` if test "x$as_val" = x""yes; then cat >>confdefs.h <<_ACEOF #define `$as_echo "HAVE_$ac_header" | $as_tr_cpp` 1 _ACEOF fi done # # Functions we expect # { $as_echo "$as_me:$LINENO: standard functions..." >&5 $as_echo "$as_me: standard functions..." >&6;} for ac_func in exit do as_ac_var=`$as_echo "ac_cv_func_$ac_func" | $as_tr_sh` { $as_echo "$as_me:$LINENO: checking for $ac_func" >&5 $as_echo_n "checking for $ac_func... " >&6; } if { as_var=$as_ac_var; eval "test \"\${$as_var+set}\" = set"; }; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Define $ac_func to an innocuous variant, in case declares $ac_func. For example, HP-UX 11i declares gettimeofday. */ #define $ac_func innocuous_$ac_func /* System header to define __stub macros and hopefully few prototypes, which can conflict with char $ac_func (); below. Prefer to if __STDC__ is defined, since exists even on freestanding compilers. */ #ifdef __STDC__ # include #else # include #endif #undef $ac_func /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char $ac_func (); /* The GNU C library defines this for functions which it implements to always fail with ENOSYS. Some functions are actually named something starting with __ and the normal name is an alias. */ #if defined __stub_$ac_func || defined __stub___$ac_func choke me #endif int main () { return $ac_func (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then eval "$as_ac_var=yes" else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 eval "$as_ac_var=no" fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext fi ac_res=`eval 'as_val=${'$as_ac_var'} $as_echo "$as_val"'` { $as_echo "$as_me:$LINENO: result: $ac_res" >&5 $as_echo "$ac_res" >&6; } as_val=`eval 'as_val=${'$as_ac_var'} $as_echo "$as_val"'` if test "x$as_val" = x""yes; then cat >>confdefs.h <<_ACEOF #define `$as_echo "HAVE_$ac_func" | $as_tr_cpp` 1 _ACEOF fi done for ac_func in fprintf do as_ac_var=`$as_echo "ac_cv_func_$ac_func" | $as_tr_sh` { $as_echo "$as_me:$LINENO: checking for $ac_func" >&5 $as_echo_n "checking for $ac_func... " >&6; } if { as_var=$as_ac_var; eval "test \"\${$as_var+set}\" = set"; }; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Define $ac_func to an innocuous variant, in case declares $ac_func. For example, HP-UX 11i declares gettimeofday. */ #define $ac_func innocuous_$ac_func /* System header to define __stub macros and hopefully few prototypes, which can conflict with char $ac_func (); below. Prefer to if __STDC__ is defined, since exists even on freestanding compilers. */ #ifdef __STDC__ # include #else # include #endif #undef $ac_func /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char $ac_func (); /* The GNU C library defines this for functions which it implements to always fail with ENOSYS. Some functions are actually named something starting with __ and the normal name is an alias. */ #if defined __stub_$ac_func || defined __stub___$ac_func choke me #endif int main () { return $ac_func (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then eval "$as_ac_var=yes" else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 eval "$as_ac_var=no" fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext fi ac_res=`eval 'as_val=${'$as_ac_var'} $as_echo "$as_val"'` { $as_echo "$as_me:$LINENO: result: $ac_res" >&5 $as_echo "$ac_res" >&6; } as_val=`eval 'as_val=${'$as_ac_var'} $as_echo "$as_val"'` if test "x$as_val" = x""yes; then cat >>confdefs.h <<_ACEOF #define `$as_echo "HAVE_$ac_func" | $as_tr_cpp` 1 _ACEOF fi done for ac_func in free do as_ac_var=`$as_echo "ac_cv_func_$ac_func" | $as_tr_sh` { $as_echo "$as_me:$LINENO: checking for $ac_func" >&5 $as_echo_n "checking for $ac_func... " >&6; } if { as_var=$as_ac_var; eval "test \"\${$as_var+set}\" = set"; }; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Define $ac_func to an innocuous variant, in case declares $ac_func. For example, HP-UX 11i declares gettimeofday. */ #define $ac_func innocuous_$ac_func /* System header to define __stub macros and hopefully few prototypes, which can conflict with char $ac_func (); below. Prefer to if __STDC__ is defined, since exists even on freestanding compilers. */ #ifdef __STDC__ # include #else # include #endif #undef $ac_func /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char $ac_func (); /* The GNU C library defines this for functions which it implements to always fail with ENOSYS. Some functions are actually named something starting with __ and the normal name is an alias. */ #if defined __stub_$ac_func || defined __stub___$ac_func choke me #endif int main () { return $ac_func (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then eval "$as_ac_var=yes" else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 eval "$as_ac_var=no" fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext fi ac_res=`eval 'as_val=${'$as_ac_var'} $as_echo "$as_val"'` { $as_echo "$as_me:$LINENO: result: $ac_res" >&5 $as_echo "$ac_res" >&6; } as_val=`eval 'as_val=${'$as_ac_var'} $as_echo "$as_val"'` if test "x$as_val" = x""yes; then cat >>confdefs.h <<_ACEOF #define `$as_echo "HAVE_$ac_func" | $as_tr_cpp` 1 _ACEOF fi done for ac_func in longjmp do as_ac_var=`$as_echo "ac_cv_func_$ac_func" | $as_tr_sh` { $as_echo "$as_me:$LINENO: checking for $ac_func" >&5 $as_echo_n "checking for $ac_func... " >&6; } if { as_var=$as_ac_var; eval "test \"\${$as_var+set}\" = set"; }; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Define $ac_func to an innocuous variant, in case declares $ac_func. For example, HP-UX 11i declares gettimeofday. */ #define $ac_func innocuous_$ac_func /* System header to define __stub macros and hopefully few prototypes, which can conflict with char $ac_func (); below. Prefer to if __STDC__ is defined, since exists even on freestanding compilers. */ #ifdef __STDC__ # include #else # include #endif #undef $ac_func /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char $ac_func (); /* The GNU C library defines this for functions which it implements to always fail with ENOSYS. Some functions are actually named something starting with __ and the normal name is an alias. */ #if defined __stub_$ac_func || defined __stub___$ac_func choke me #endif int main () { return $ac_func (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then eval "$as_ac_var=yes" else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 eval "$as_ac_var=no" fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext fi ac_res=`eval 'as_val=${'$as_ac_var'} $as_echo "$as_val"'` { $as_echo "$as_me:$LINENO: result: $ac_res" >&5 $as_echo "$ac_res" >&6; } as_val=`eval 'as_val=${'$as_ac_var'} $as_echo "$as_val"'` if test "x$as_val" = x""yes; then cat >>confdefs.h <<_ACEOF #define `$as_echo "HAVE_$ac_func" | $as_tr_cpp` 1 _ACEOF fi done for ac_func in malloc do as_ac_var=`$as_echo "ac_cv_func_$ac_func" | $as_tr_sh` { $as_echo "$as_me:$LINENO: checking for $ac_func" >&5 $as_echo_n "checking for $ac_func... " >&6; } if { as_var=$as_ac_var; eval "test \"\${$as_var+set}\" = set"; }; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Define $ac_func to an innocuous variant, in case declares $ac_func. For example, HP-UX 11i declares gettimeofday. */ #define $ac_func innocuous_$ac_func /* System header to define __stub macros and hopefully few prototypes, which can conflict with char $ac_func (); below. Prefer to if __STDC__ is defined, since exists even on freestanding compilers. */ #ifdef __STDC__ # include #else # include #endif #undef $ac_func /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char $ac_func (); /* The GNU C library defines this for functions which it implements to always fail with ENOSYS. Some functions are actually named something starting with __ and the normal name is an alias. */ #if defined __stub_$ac_func || defined __stub___$ac_func choke me #endif int main () { return $ac_func (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then eval "$as_ac_var=yes" else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 eval "$as_ac_var=no" fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext fi ac_res=`eval 'as_val=${'$as_ac_var'} $as_echo "$as_val"'` { $as_echo "$as_me:$LINENO: result: $ac_res" >&5 $as_echo "$ac_res" >&6; } as_val=`eval 'as_val=${'$as_ac_var'} $as_echo "$as_val"'` if test "x$as_val" = x""yes; then cat >>confdefs.h <<_ACEOF #define `$as_echo "HAVE_$ac_func" | $as_tr_cpp` 1 _ACEOF fi done for ac_func in memcpy do as_ac_var=`$as_echo "ac_cv_func_$ac_func" | $as_tr_sh` { $as_echo "$as_me:$LINENO: checking for $ac_func" >&5 $as_echo_n "checking for $ac_func... " >&6; } if { as_var=$as_ac_var; eval "test \"\${$as_var+set}\" = set"; }; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Define $ac_func to an innocuous variant, in case declares $ac_func. For example, HP-UX 11i declares gettimeofday. */ #define $ac_func innocuous_$ac_func /* System header to define __stub macros and hopefully few prototypes, which can conflict with char $ac_func (); below. Prefer to if __STDC__ is defined, since exists even on freestanding compilers. */ #ifdef __STDC__ # include #else # include #endif #undef $ac_func /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char $ac_func (); /* The GNU C library defines this for functions which it implements to always fail with ENOSYS. Some functions are actually named something starting with __ and the normal name is an alias. */ #if defined __stub_$ac_func || defined __stub___$ac_func choke me #endif int main () { return $ac_func (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then eval "$as_ac_var=yes" else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 eval "$as_ac_var=no" fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext fi ac_res=`eval 'as_val=${'$as_ac_var'} $as_echo "$as_val"'` { $as_echo "$as_me:$LINENO: result: $ac_res" >&5 $as_echo "$ac_res" >&6; } as_val=`eval 'as_val=${'$as_ac_var'} $as_echo "$as_val"'` if test "x$as_val" = x""yes; then cat >>confdefs.h <<_ACEOF #define `$as_echo "HAVE_$ac_func" | $as_tr_cpp` 1 _ACEOF fi done for ac_func in memmove do as_ac_var=`$as_echo "ac_cv_func_$ac_func" | $as_tr_sh` { $as_echo "$as_me:$LINENO: checking for $ac_func" >&5 $as_echo_n "checking for $ac_func... " >&6; } if { as_var=$as_ac_var; eval "test \"\${$as_var+set}\" = set"; }; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Define $ac_func to an innocuous variant, in case declares $ac_func. For example, HP-UX 11i declares gettimeofday. */ #define $ac_func innocuous_$ac_func /* System header to define __stub macros and hopefully few prototypes, which can conflict with char $ac_func (); below. Prefer to if __STDC__ is defined, since exists even on freestanding compilers. */ #ifdef __STDC__ # include #else # include #endif #undef $ac_func /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char $ac_func (); /* The GNU C library defines this for functions which it implements to always fail with ENOSYS. Some functions are actually named something starting with __ and the normal name is an alias. */ #if defined __stub_$ac_func || defined __stub___$ac_func choke me #endif int main () { return $ac_func (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then eval "$as_ac_var=yes" else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 eval "$as_ac_var=no" fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext fi ac_res=`eval 'as_val=${'$as_ac_var'} $as_echo "$as_val"'` { $as_echo "$as_me:$LINENO: result: $ac_res" >&5 $as_echo "$ac_res" >&6; } as_val=`eval 'as_val=${'$as_ac_var'} $as_echo "$as_val"'` if test "x$as_val" = x""yes; then cat >>confdefs.h <<_ACEOF #define `$as_echo "HAVE_$ac_func" | $as_tr_cpp` 1 _ACEOF fi done for ac_func in memset do as_ac_var=`$as_echo "ac_cv_func_$ac_func" | $as_tr_sh` { $as_echo "$as_me:$LINENO: checking for $ac_func" >&5 $as_echo_n "checking for $ac_func... " >&6; } if { as_var=$as_ac_var; eval "test \"\${$as_var+set}\" = set"; }; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Define $ac_func to an innocuous variant, in case declares $ac_func. For example, HP-UX 11i declares gettimeofday. */ #define $ac_func innocuous_$ac_func /* System header to define __stub macros and hopefully few prototypes, which can conflict with char $ac_func (); below. Prefer to if __STDC__ is defined, since exists even on freestanding compilers. */ #ifdef __STDC__ # include #else # include #endif #undef $ac_func /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char $ac_func (); /* The GNU C library defines this for functions which it implements to always fail with ENOSYS. Some functions are actually named something starting with __ and the normal name is an alias. */ #if defined __stub_$ac_func || defined __stub___$ac_func choke me #endif int main () { return $ac_func (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then eval "$as_ac_var=yes" else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 eval "$as_ac_var=no" fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext fi ac_res=`eval 'as_val=${'$as_ac_var'} $as_echo "$as_val"'` { $as_echo "$as_me:$LINENO: result: $ac_res" >&5 $as_echo "$ac_res" >&6; } as_val=`eval 'as_val=${'$as_ac_var'} $as_echo "$as_val"'` if test "x$as_val" = x""yes; then cat >>confdefs.h <<_ACEOF #define `$as_echo "HAVE_$ac_func" | $as_tr_cpp` 1 _ACEOF fi done for ac_func in printf do as_ac_var=`$as_echo "ac_cv_func_$ac_func" | $as_tr_sh` { $as_echo "$as_me:$LINENO: checking for $ac_func" >&5 $as_echo_n "checking for $ac_func... " >&6; } if { as_var=$as_ac_var; eval "test \"\${$as_var+set}\" = set"; }; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Define $ac_func to an innocuous variant, in case declares $ac_func. For example, HP-UX 11i declares gettimeofday. */ #define $ac_func innocuous_$ac_func /* System header to define __stub macros and hopefully few prototypes, which can conflict with char $ac_func (); below. Prefer to if __STDC__ is defined, since exists even on freestanding compilers. */ #ifdef __STDC__ # include #else # include #endif #undef $ac_func /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char $ac_func (); /* The GNU C library defines this for functions which it implements to always fail with ENOSYS. Some functions are actually named something starting with __ and the normal name is an alias. */ #if defined __stub_$ac_func || defined __stub___$ac_func choke me #endif int main () { return $ac_func (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then eval "$as_ac_var=yes" else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 eval "$as_ac_var=no" fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext fi ac_res=`eval 'as_val=${'$as_ac_var'} $as_echo "$as_val"'` { $as_echo "$as_me:$LINENO: result: $ac_res" >&5 $as_echo "$ac_res" >&6; } as_val=`eval 'as_val=${'$as_ac_var'} $as_echo "$as_val"'` if test "x$as_val" = x""yes; then cat >>confdefs.h <<_ACEOF #define `$as_echo "HAVE_$ac_func" | $as_tr_cpp` 1 _ACEOF fi done for ac_func in setjmp do as_ac_var=`$as_echo "ac_cv_func_$ac_func" | $as_tr_sh` { $as_echo "$as_me:$LINENO: checking for $ac_func" >&5 $as_echo_n "checking for $ac_func... " >&6; } if { as_var=$as_ac_var; eval "test \"\${$as_var+set}\" = set"; }; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Define $ac_func to an innocuous variant, in case declares $ac_func. For example, HP-UX 11i declares gettimeofday. */ #define $ac_func innocuous_$ac_func /* System header to define __stub macros and hopefully few prototypes, which can conflict with char $ac_func (); below. Prefer to if __STDC__ is defined, since exists even on freestanding compilers. */ #ifdef __STDC__ # include #else # include #endif #undef $ac_func /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char $ac_func (); /* The GNU C library defines this for functions which it implements to always fail with ENOSYS. Some functions are actually named something starting with __ and the normal name is an alias. */ #if defined __stub_$ac_func || defined __stub___$ac_func choke me #endif int main () { return $ac_func (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then eval "$as_ac_var=yes" else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 eval "$as_ac_var=no" fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext fi ac_res=`eval 'as_val=${'$as_ac_var'} $as_echo "$as_val"'` { $as_echo "$as_me:$LINENO: result: $ac_res" >&5 $as_echo "$ac_res" >&6; } as_val=`eval 'as_val=${'$as_ac_var'} $as_echo "$as_val"'` if test "x$as_val" = x""yes; then cat >>confdefs.h <<_ACEOF #define `$as_echo "HAVE_$ac_func" | $as_tr_cpp` 1 _ACEOF fi done for ac_func in signal do as_ac_var=`$as_echo "ac_cv_func_$ac_func" | $as_tr_sh` { $as_echo "$as_me:$LINENO: checking for $ac_func" >&5 $as_echo_n "checking for $ac_func... " >&6; } if { as_var=$as_ac_var; eval "test \"\${$as_var+set}\" = set"; }; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Define $ac_func to an innocuous variant, in case declares $ac_func. For example, HP-UX 11i declares gettimeofday. */ #define $ac_func innocuous_$ac_func /* System header to define __stub macros and hopefully few prototypes, which can conflict with char $ac_func (); below. Prefer to if __STDC__ is defined, since exists even on freestanding compilers. */ #ifdef __STDC__ # include #else # include #endif #undef $ac_func /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char $ac_func (); /* The GNU C library defines this for functions which it implements to always fail with ENOSYS. Some functions are actually named something starting with __ and the normal name is an alias. */ #if defined __stub_$ac_func || defined __stub___$ac_func choke me #endif int main () { return $ac_func (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then eval "$as_ac_var=yes" else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 eval "$as_ac_var=no" fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext fi ac_res=`eval 'as_val=${'$as_ac_var'} $as_echo "$as_val"'` { $as_echo "$as_me:$LINENO: result: $ac_res" >&5 $as_echo "$ac_res" >&6; } as_val=`eval 'as_val=${'$as_ac_var'} $as_echo "$as_val"'` if test "x$as_val" = x""yes; then cat >>confdefs.h <<_ACEOF #define `$as_echo "HAVE_$ac_func" | $as_tr_cpp` 1 _ACEOF fi done for ac_func in snprintf do as_ac_var=`$as_echo "ac_cv_func_$ac_func" | $as_tr_sh` { $as_echo "$as_me:$LINENO: checking for $ac_func" >&5 $as_echo_n "checking for $ac_func... " >&6; } if { as_var=$as_ac_var; eval "test \"\${$as_var+set}\" = set"; }; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Define $ac_func to an innocuous variant, in case declares $ac_func. For example, HP-UX 11i declares gettimeofday. */ #define $ac_func innocuous_$ac_func /* System header to define __stub macros and hopefully few prototypes, which can conflict with char $ac_func (); below. Prefer to if __STDC__ is defined, since exists even on freestanding compilers. */ #ifdef __STDC__ # include #else # include #endif #undef $ac_func /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char $ac_func (); /* The GNU C library defines this for functions which it implements to always fail with ENOSYS. Some functions are actually named something starting with __ and the normal name is an alias. */ #if defined __stub_$ac_func || defined __stub___$ac_func choke me #endif int main () { return $ac_func (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then eval "$as_ac_var=yes" else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 eval "$as_ac_var=no" fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext fi ac_res=`eval 'as_val=${'$as_ac_var'} $as_echo "$as_val"'` { $as_echo "$as_me:$LINENO: result: $ac_res" >&5 $as_echo "$ac_res" >&6; } as_val=`eval 'as_val=${'$as_ac_var'} $as_echo "$as_val"'` if test "x$as_val" = x""yes; then cat >>confdefs.h <<_ACEOF #define `$as_echo "HAVE_$ac_func" | $as_tr_cpp` 1 _ACEOF fi done for ac_func in strcmp do as_ac_var=`$as_echo "ac_cv_func_$ac_func" | $as_tr_sh` { $as_echo "$as_me:$LINENO: checking for $ac_func" >&5 $as_echo_n "checking for $ac_func... " >&6; } if { as_var=$as_ac_var; eval "test \"\${$as_var+set}\" = set"; }; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Define $ac_func to an innocuous variant, in case declares $ac_func. For example, HP-UX 11i declares gettimeofday. */ #define $ac_func innocuous_$ac_func /* System header to define __stub macros and hopefully few prototypes, which can conflict with char $ac_func (); below. Prefer to if __STDC__ is defined, since exists even on freestanding compilers. */ #ifdef __STDC__ # include #else # include #endif #undef $ac_func /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char $ac_func (); /* The GNU C library defines this for functions which it implements to always fail with ENOSYS. Some functions are actually named something starting with __ and the normal name is an alias. */ #if defined __stub_$ac_func || defined __stub___$ac_func choke me #endif int main () { return $ac_func (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then eval "$as_ac_var=yes" else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 eval "$as_ac_var=no" fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext fi ac_res=`eval 'as_val=${'$as_ac_var'} $as_echo "$as_val"'` { $as_echo "$as_me:$LINENO: result: $ac_res" >&5 $as_echo "$ac_res" >&6; } as_val=`eval 'as_val=${'$as_ac_var'} $as_echo "$as_val"'` if test "x$as_val" = x""yes; then cat >>confdefs.h <<_ACEOF #define `$as_echo "HAVE_$ac_func" | $as_tr_cpp` 1 _ACEOF fi done for ac_func in strncmp do as_ac_var=`$as_echo "ac_cv_func_$ac_func" | $as_tr_sh` { $as_echo "$as_me:$LINENO: checking for $ac_func" >&5 $as_echo_n "checking for $ac_func... " >&6; } if { as_var=$as_ac_var; eval "test \"\${$as_var+set}\" = set"; }; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Define $ac_func to an innocuous variant, in case declares $ac_func. For example, HP-UX 11i declares gettimeofday. */ #define $ac_func innocuous_$ac_func /* System header to define __stub macros and hopefully few prototypes, which can conflict with char $ac_func (); below. Prefer to if __STDC__ is defined, since exists even on freestanding compilers. */ #ifdef __STDC__ # include #else # include #endif #undef $ac_func /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char $ac_func (); /* The GNU C library defines this for functions which it implements to always fail with ENOSYS. Some functions are actually named something starting with __ and the normal name is an alias. */ #if defined __stub_$ac_func || defined __stub___$ac_func choke me #endif int main () { return $ac_func (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then eval "$as_ac_var=yes" else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 eval "$as_ac_var=no" fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext fi ac_res=`eval 'as_val=${'$as_ac_var'} $as_echo "$as_val"'` { $as_echo "$as_me:$LINENO: result: $ac_res" >&5 $as_echo "$ac_res" >&6; } as_val=`eval 'as_val=${'$as_ac_var'} $as_echo "$as_val"'` if test "x$as_val" = x""yes; then cat >>confdefs.h <<_ACEOF #define `$as_echo "HAVE_$ac_func" | $as_tr_cpp` 1 _ACEOF fi done for ac_func in strncpy do as_ac_var=`$as_echo "ac_cv_func_$ac_func" | $as_tr_sh` { $as_echo "$as_me:$LINENO: checking for $ac_func" >&5 $as_echo_n "checking for $ac_func... " >&6; } if { as_var=$as_ac_var; eval "test \"\${$as_var+set}\" = set"; }; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Define $ac_func to an innocuous variant, in case declares $ac_func. For example, HP-UX 11i declares gettimeofday. */ #define $ac_func innocuous_$ac_func /* System header to define __stub macros and hopefully few prototypes, which can conflict with char $ac_func (); below. Prefer to if __STDC__ is defined, since exists even on freestanding compilers. */ #ifdef __STDC__ # include #else # include #endif #undef $ac_func /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char $ac_func (); /* The GNU C library defines this for functions which it implements to always fail with ENOSYS. Some functions are actually named something starting with __ and the normal name is an alias. */ #if defined __stub_$ac_func || defined __stub___$ac_func choke me #endif int main () { return $ac_func (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then eval "$as_ac_var=yes" else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 eval "$as_ac_var=no" fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext fi ac_res=`eval 'as_val=${'$as_ac_var'} $as_echo "$as_val"'` { $as_echo "$as_me:$LINENO: result: $ac_res" >&5 $as_echo "$ac_res" >&6; } as_val=`eval 'as_val=${'$as_ac_var'} $as_echo "$as_val"'` if test "x$as_val" = x""yes; then cat >>confdefs.h <<_ACEOF #define `$as_echo "HAVE_$ac_func" | $as_tr_cpp` 1 _ACEOF fi done { $as_echo "$as_me:$LINENO: optional headers and libraries..." >&5 $as_echo "$as_me: optional headers and libraries..." >&6;} if test "x$enable_curses" = "xyes"; then for ac_header in curses.h do as_ac_Header=`$as_echo "ac_cv_header_$ac_header" | $as_tr_sh` if { as_var=$as_ac_Header; eval "test \"\${$as_var+set}\" = set"; }; then { $as_echo "$as_me:$LINENO: checking for $ac_header" >&5 $as_echo_n "checking for $ac_header... " >&6; } if { as_var=$as_ac_Header; eval "test \"\${$as_var+set}\" = set"; }; then $as_echo_n "(cached) " >&6 fi ac_res=`eval 'as_val=${'$as_ac_Header'} $as_echo "$as_val"'` { $as_echo "$as_me:$LINENO: result: $ac_res" >&5 $as_echo "$ac_res" >&6; } else # Is the header compilable? { $as_echo "$as_me:$LINENO: checking $ac_header usability" >&5 $as_echo_n "checking $ac_header usability... " >&6; } cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ $ac_includes_default #include <$ac_header> _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_header_compiler=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_header_compiler=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext { $as_echo "$as_me:$LINENO: result: $ac_header_compiler" >&5 $as_echo "$ac_header_compiler" >&6; } # Is the header present? { $as_echo "$as_me:$LINENO: checking $ac_header presence" >&5 $as_echo_n "checking $ac_header presence... " >&6; } cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include <$ac_header> _ACEOF if { (ac_try="$ac_cpp conftest.$ac_ext" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_cpp conftest.$ac_ext") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } >/dev/null && { test -z "$ac_c_preproc_warn_flag$ac_c_werror_flag" || test ! -s conftest.err }; then ac_header_preproc=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_header_preproc=no fi rm -f conftest.err conftest.$ac_ext { $as_echo "$as_me:$LINENO: result: $ac_header_preproc" >&5 $as_echo "$ac_header_preproc" >&6; } # So? What about this header? case $ac_header_compiler:$ac_header_preproc:$ac_c_preproc_warn_flag in yes:no: ) { $as_echo "$as_me:$LINENO: WARNING: $ac_header: accepted by the compiler, rejected by the preprocessor!" >&5 $as_echo "$as_me: WARNING: $ac_header: accepted by the compiler, rejected by the preprocessor!" >&2;} { $as_echo "$as_me:$LINENO: WARNING: $ac_header: proceeding with the compiler's result" >&5 $as_echo "$as_me: WARNING: $ac_header: proceeding with the compiler's result" >&2;} ac_header_preproc=yes ;; no:yes:* ) { $as_echo "$as_me:$LINENO: WARNING: $ac_header: present but cannot be compiled" >&5 $as_echo "$as_me: WARNING: $ac_header: present but cannot be compiled" >&2;} { $as_echo "$as_me:$LINENO: WARNING: $ac_header: check for missing prerequisite headers?" >&5 $as_echo "$as_me: WARNING: $ac_header: check for missing prerequisite headers?" >&2;} { $as_echo "$as_me:$LINENO: WARNING: $ac_header: see the Autoconf documentation" >&5 $as_echo "$as_me: WARNING: $ac_header: see the Autoconf documentation" >&2;} { $as_echo "$as_me:$LINENO: WARNING: $ac_header: section \"Present But Cannot Be Compiled\"" >&5 $as_echo "$as_me: WARNING: $ac_header: section \"Present But Cannot Be Compiled\"" >&2;} { $as_echo "$as_me:$LINENO: WARNING: $ac_header: proceeding with the preprocessor's result" >&5 $as_echo "$as_me: WARNING: $ac_header: proceeding with the preprocessor's result" >&2;} { $as_echo "$as_me:$LINENO: WARNING: $ac_header: in the future, the compiler will take precedence" >&5 $as_echo "$as_me: WARNING: $ac_header: in the future, the compiler will take precedence" >&2;} ( cat <<\_ASBOX ## ------------------------------------------------------- ## ## Report this to Marcel van der Veer ## ## ------------------------------------------------------- ## _ASBOX ) | sed "s/^/$as_me: WARNING: /" >&2 ;; esac { $as_echo "$as_me:$LINENO: checking for $ac_header" >&5 $as_echo_n "checking for $ac_header... " >&6; } if { as_var=$as_ac_Header; eval "test \"\${$as_var+set}\" = set"; }; then $as_echo_n "(cached) " >&6 else eval "$as_ac_Header=\$ac_header_preproc" fi ac_res=`eval 'as_val=${'$as_ac_Header'} $as_echo "$as_val"'` { $as_echo "$as_me:$LINENO: result: $ac_res" >&5 $as_echo "$ac_res" >&6; } fi as_val=`eval 'as_val=${'$as_ac_Header'} $as_echo "$as_val"'` if test "x$as_val" = x""yes; then cat >>confdefs.h <<_ACEOF #define `$as_echo "HAVE_$ac_header" | $as_tr_cpp` 1 _ACEOF else enable_curses=no fi done if test "x$enable_curses" = "xno"; then for ac_header in ncurses/curses.h do as_ac_Header=`$as_echo "ac_cv_header_$ac_header" | $as_tr_sh` if { as_var=$as_ac_Header; eval "test \"\${$as_var+set}\" = set"; }; then { $as_echo "$as_me:$LINENO: checking for $ac_header" >&5 $as_echo_n "checking for $ac_header... " >&6; } if { as_var=$as_ac_Header; eval "test \"\${$as_var+set}\" = set"; }; then $as_echo_n "(cached) " >&6 fi ac_res=`eval 'as_val=${'$as_ac_Header'} $as_echo "$as_val"'` { $as_echo "$as_me:$LINENO: result: $ac_res" >&5 $as_echo "$ac_res" >&6; } else # Is the header compilable? { $as_echo "$as_me:$LINENO: checking $ac_header usability" >&5 $as_echo_n "checking $ac_header usability... " >&6; } cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ $ac_includes_default #include <$ac_header> _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_header_compiler=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_header_compiler=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext { $as_echo "$as_me:$LINENO: result: $ac_header_compiler" >&5 $as_echo "$ac_header_compiler" >&6; } # Is the header present? { $as_echo "$as_me:$LINENO: checking $ac_header presence" >&5 $as_echo_n "checking $ac_header presence... " >&6; } cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include <$ac_header> _ACEOF if { (ac_try="$ac_cpp conftest.$ac_ext" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_cpp conftest.$ac_ext") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } >/dev/null && { test -z "$ac_c_preproc_warn_flag$ac_c_werror_flag" || test ! -s conftest.err }; then ac_header_preproc=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_header_preproc=no fi rm -f conftest.err conftest.$ac_ext { $as_echo "$as_me:$LINENO: result: $ac_header_preproc" >&5 $as_echo "$ac_header_preproc" >&6; } # So? What about this header? case $ac_header_compiler:$ac_header_preproc:$ac_c_preproc_warn_flag in yes:no: ) { $as_echo "$as_me:$LINENO: WARNING: $ac_header: accepted by the compiler, rejected by the preprocessor!" >&5 $as_echo "$as_me: WARNING: $ac_header: accepted by the compiler, rejected by the preprocessor!" >&2;} { $as_echo "$as_me:$LINENO: WARNING: $ac_header: proceeding with the compiler's result" >&5 $as_echo "$as_me: WARNING: $ac_header: proceeding with the compiler's result" >&2;} ac_header_preproc=yes ;; no:yes:* ) { $as_echo "$as_me:$LINENO: WARNING: $ac_header: present but cannot be compiled" >&5 $as_echo "$as_me: WARNING: $ac_header: present but cannot be compiled" >&2;} { $as_echo "$as_me:$LINENO: WARNING: $ac_header: check for missing prerequisite headers?" >&5 $as_echo "$as_me: WARNING: $ac_header: check for missing prerequisite headers?" >&2;} { $as_echo "$as_me:$LINENO: WARNING: $ac_header: see the Autoconf documentation" >&5 $as_echo "$as_me: WARNING: $ac_header: see the Autoconf documentation" >&2;} { $as_echo "$as_me:$LINENO: WARNING: $ac_header: section \"Present But Cannot Be Compiled\"" >&5 $as_echo "$as_me: WARNING: $ac_header: section \"Present But Cannot Be Compiled\"" >&2;} { $as_echo "$as_me:$LINENO: WARNING: $ac_header: proceeding with the preprocessor's result" >&5 $as_echo "$as_me: WARNING: $ac_header: proceeding with the preprocessor's result" >&2;} { $as_echo "$as_me:$LINENO: WARNING: $ac_header: in the future, the compiler will take precedence" >&5 $as_echo "$as_me: WARNING: $ac_header: in the future, the compiler will take precedence" >&2;} ( cat <<\_ASBOX ## ------------------------------------------------------- ## ## Report this to Marcel van der Veer ## ## ------------------------------------------------------- ## _ASBOX ) | sed "s/^/$as_me: WARNING: /" >&2 ;; esac { $as_echo "$as_me:$LINENO: checking for $ac_header" >&5 $as_echo_n "checking for $ac_header... " >&6; } if { as_var=$as_ac_Header; eval "test \"\${$as_var+set}\" = set"; }; then $as_echo_n "(cached) " >&6 else eval "$as_ac_Header=\$ac_header_preproc" fi ac_res=`eval 'as_val=${'$as_ac_Header'} $as_echo "$as_val"'` { $as_echo "$as_me:$LINENO: result: $ac_res" >&5 $as_echo "$ac_res" >&6; } fi as_val=`eval 'as_val=${'$as_ac_Header'} $as_echo "$as_val"'` if test "x$as_val" = x""yes; then cat >>confdefs.h <<_ACEOF #define `$as_echo "HAVE_$ac_header" | $as_tr_cpp` 1 _ACEOF enable_curses=yes fi done fi if test "x$enable_curses" = "xyes"; then { $as_echo "$as_me:$LINENO: checking for initscr in -lncurses" >&5 $as_echo_n "checking for initscr in -lncurses... " >&6; } if test "${ac_cv_lib_ncurses_initscr+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lncurses $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char initscr (); int main () { return initscr (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_ncurses_initscr=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_ncurses_initscr=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_ncurses_initscr" >&5 $as_echo "$ac_cv_lib_ncurses_initscr" >&6; } if test "x$ac_cv_lib_ncurses_initscr" = x""yes; then cat >>confdefs.h <<_ACEOF #define HAVE_LIBNCURSES 1 _ACEOF LIBS="-lncurses $LIBS" else enable_curses=no fi if test "x$enable_curses" = "xyes"; then if test "x$enable_readline" = "xyes"; then for ac_header in readline/readline.h do as_ac_Header=`$as_echo "ac_cv_header_$ac_header" | $as_tr_sh` if { as_var=$as_ac_Header; eval "test \"\${$as_var+set}\" = set"; }; then { $as_echo "$as_me:$LINENO: checking for $ac_header" >&5 $as_echo_n "checking for $ac_header... " >&6; } if { as_var=$as_ac_Header; eval "test \"\${$as_var+set}\" = set"; }; then $as_echo_n "(cached) " >&6 fi ac_res=`eval 'as_val=${'$as_ac_Header'} $as_echo "$as_val"'` { $as_echo "$as_me:$LINENO: result: $ac_res" >&5 $as_echo "$ac_res" >&6; } else # Is the header compilable? { $as_echo "$as_me:$LINENO: checking $ac_header usability" >&5 $as_echo_n "checking $ac_header usability... " >&6; } cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ $ac_includes_default #include <$ac_header> _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_header_compiler=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_header_compiler=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext { $as_echo "$as_me:$LINENO: result: $ac_header_compiler" >&5 $as_echo "$ac_header_compiler" >&6; } # Is the header present? { $as_echo "$as_me:$LINENO: checking $ac_header presence" >&5 $as_echo_n "checking $ac_header presence... " >&6; } cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include <$ac_header> _ACEOF if { (ac_try="$ac_cpp conftest.$ac_ext" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_cpp conftest.$ac_ext") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } >/dev/null && { test -z "$ac_c_preproc_warn_flag$ac_c_werror_flag" || test ! -s conftest.err }; then ac_header_preproc=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_header_preproc=no fi rm -f conftest.err conftest.$ac_ext { $as_echo "$as_me:$LINENO: result: $ac_header_preproc" >&5 $as_echo "$ac_header_preproc" >&6; } # So? What about this header? case $ac_header_compiler:$ac_header_preproc:$ac_c_preproc_warn_flag in yes:no: ) { $as_echo "$as_me:$LINENO: WARNING: $ac_header: accepted by the compiler, rejected by the preprocessor!" >&5 $as_echo "$as_me: WARNING: $ac_header: accepted by the compiler, rejected by the preprocessor!" >&2;} { $as_echo "$as_me:$LINENO: WARNING: $ac_header: proceeding with the compiler's result" >&5 $as_echo "$as_me: WARNING: $ac_header: proceeding with the compiler's result" >&2;} ac_header_preproc=yes ;; no:yes:* ) { $as_echo "$as_me:$LINENO: WARNING: $ac_header: present but cannot be compiled" >&5 $as_echo "$as_me: WARNING: $ac_header: present but cannot be compiled" >&2;} { $as_echo "$as_me:$LINENO: WARNING: $ac_header: check for missing prerequisite headers?" >&5 $as_echo "$as_me: WARNING: $ac_header: check for missing prerequisite headers?" >&2;} { $as_echo "$as_me:$LINENO: WARNING: $ac_header: see the Autoconf documentation" >&5 $as_echo "$as_me: WARNING: $ac_header: see the Autoconf documentation" >&2;} { $as_echo "$as_me:$LINENO: WARNING: $ac_header: section \"Present But Cannot Be Compiled\"" >&5 $as_echo "$as_me: WARNING: $ac_header: section \"Present But Cannot Be Compiled\"" >&2;} { $as_echo "$as_me:$LINENO: WARNING: $ac_header: proceeding with the preprocessor's result" >&5 $as_echo "$as_me: WARNING: $ac_header: proceeding with the preprocessor's result" >&2;} { $as_echo "$as_me:$LINENO: WARNING: $ac_header: in the future, the compiler will take precedence" >&5 $as_echo "$as_me: WARNING: $ac_header: in the future, the compiler will take precedence" >&2;} ( cat <<\_ASBOX ## ------------------------------------------------------- ## ## Report this to Marcel van der Veer ## ## ------------------------------------------------------- ## _ASBOX ) | sed "s/^/$as_me: WARNING: /" >&2 ;; esac { $as_echo "$as_me:$LINENO: checking for $ac_header" >&5 $as_echo_n "checking for $ac_header... " >&6; } if { as_var=$as_ac_Header; eval "test \"\${$as_var+set}\" = set"; }; then $as_echo_n "(cached) " >&6 else eval "$as_ac_Header=\$ac_header_preproc" fi ac_res=`eval 'as_val=${'$as_ac_Header'} $as_echo "$as_val"'` { $as_echo "$as_me:$LINENO: result: $ac_res" >&5 $as_echo "$ac_res" >&6; } fi as_val=`eval 'as_val=${'$as_ac_Header'} $as_echo "$as_val"'` if test "x$as_val" = x""yes; then cat >>confdefs.h <<_ACEOF #define `$as_echo "HAVE_$ac_header" | $as_tr_cpp` 1 _ACEOF else enable_readline=no fi done for ac_header in readline/history.h do as_ac_Header=`$as_echo "ac_cv_header_$ac_header" | $as_tr_sh` if { as_var=$as_ac_Header; eval "test \"\${$as_var+set}\" = set"; }; then { $as_echo "$as_me:$LINENO: checking for $ac_header" >&5 $as_echo_n "checking for $ac_header... " >&6; } if { as_var=$as_ac_Header; eval "test \"\${$as_var+set}\" = set"; }; then $as_echo_n "(cached) " >&6 fi ac_res=`eval 'as_val=${'$as_ac_Header'} $as_echo "$as_val"'` { $as_echo "$as_me:$LINENO: result: $ac_res" >&5 $as_echo "$ac_res" >&6; } else # Is the header compilable? { $as_echo "$as_me:$LINENO: checking $ac_header usability" >&5 $as_echo_n "checking $ac_header usability... " >&6; } cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ $ac_includes_default #include <$ac_header> _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_header_compiler=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_header_compiler=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext { $as_echo "$as_me:$LINENO: result: $ac_header_compiler" >&5 $as_echo "$ac_header_compiler" >&6; } # Is the header present? { $as_echo "$as_me:$LINENO: checking $ac_header presence" >&5 $as_echo_n "checking $ac_header presence... " >&6; } cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include <$ac_header> _ACEOF if { (ac_try="$ac_cpp conftest.$ac_ext" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_cpp conftest.$ac_ext") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } >/dev/null && { test -z "$ac_c_preproc_warn_flag$ac_c_werror_flag" || test ! -s conftest.err }; then ac_header_preproc=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_header_preproc=no fi rm -f conftest.err conftest.$ac_ext { $as_echo "$as_me:$LINENO: result: $ac_header_preproc" >&5 $as_echo "$ac_header_preproc" >&6; } # So? What about this header? case $ac_header_compiler:$ac_header_preproc:$ac_c_preproc_warn_flag in yes:no: ) { $as_echo "$as_me:$LINENO: WARNING: $ac_header: accepted by the compiler, rejected by the preprocessor!" >&5 $as_echo "$as_me: WARNING: $ac_header: accepted by the compiler, rejected by the preprocessor!" >&2;} { $as_echo "$as_me:$LINENO: WARNING: $ac_header: proceeding with the compiler's result" >&5 $as_echo "$as_me: WARNING: $ac_header: proceeding with the compiler's result" >&2;} ac_header_preproc=yes ;; no:yes:* ) { $as_echo "$as_me:$LINENO: WARNING: $ac_header: present but cannot be compiled" >&5 $as_echo "$as_me: WARNING: $ac_header: present but cannot be compiled" >&2;} { $as_echo "$as_me:$LINENO: WARNING: $ac_header: check for missing prerequisite headers?" >&5 $as_echo "$as_me: WARNING: $ac_header: check for missing prerequisite headers?" >&2;} { $as_echo "$as_me:$LINENO: WARNING: $ac_header: see the Autoconf documentation" >&5 $as_echo "$as_me: WARNING: $ac_header: see the Autoconf documentation" >&2;} { $as_echo "$as_me:$LINENO: WARNING: $ac_header: section \"Present But Cannot Be Compiled\"" >&5 $as_echo "$as_me: WARNING: $ac_header: section \"Present But Cannot Be Compiled\"" >&2;} { $as_echo "$as_me:$LINENO: WARNING: $ac_header: proceeding with the preprocessor's result" >&5 $as_echo "$as_me: WARNING: $ac_header: proceeding with the preprocessor's result" >&2;} { $as_echo "$as_me:$LINENO: WARNING: $ac_header: in the future, the compiler will take precedence" >&5 $as_echo "$as_me: WARNING: $ac_header: in the future, the compiler will take precedence" >&2;} ( cat <<\_ASBOX ## ------------------------------------------------------- ## ## Report this to Marcel van der Veer ## ## ------------------------------------------------------- ## _ASBOX ) | sed "s/^/$as_me: WARNING: /" >&2 ;; esac { $as_echo "$as_me:$LINENO: checking for $ac_header" >&5 $as_echo_n "checking for $ac_header... " >&6; } if { as_var=$as_ac_Header; eval "test \"\${$as_var+set}\" = set"; }; then $as_echo_n "(cached) " >&6 else eval "$as_ac_Header=\$ac_header_preproc" fi ac_res=`eval 'as_val=${'$as_ac_Header'} $as_echo "$as_val"'` { $as_echo "$as_me:$LINENO: result: $ac_res" >&5 $as_echo "$ac_res" >&6; } fi as_val=`eval 'as_val=${'$as_ac_Header'} $as_echo "$as_val"'` if test "x$as_val" = x""yes; then cat >>confdefs.h <<_ACEOF #define `$as_echo "HAVE_$ac_header" | $as_tr_cpp` 1 _ACEOF else enable_readline=no fi done if test "x$enable_readline" = "xyes"; then { $as_echo "$as_me:$LINENO: checking for readline in -lreadline" >&5 $as_echo_n "checking for readline in -lreadline... " >&6; } if test "${ac_cv_lib_readline_readline+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lreadline -lcurses $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char readline (); int main () { return readline (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_readline_readline=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_readline_readline=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_readline_readline" >&5 $as_echo "$ac_cv_lib_readline_readline" >&6; } if test "x$ac_cv_lib_readline_readline" = x""yes; then cat >>confdefs.h <<_ACEOF #define HAVE_LIBREADLINE 1 _ACEOF LIBS="-lreadline $LIBS" else enable_readline=no fi if test "x$enable_readline" = "xyes"; then cat >>confdefs.h <<\_ACEOF #define HAVE_READLINE 1 _ACEOF fi fi fi fi if test "x$enable_curses" = "xno"; then { $as_echo "$as_me:$LINENO: checking for initscr in -lcurses" >&5 $as_echo_n "checking for initscr in -lcurses... " >&6; } if test "${ac_cv_lib_curses_initscr+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lcurses $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char initscr (); int main () { return initscr (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_curses_initscr=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_curses_initscr=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_curses_initscr" >&5 $as_echo "$ac_cv_lib_curses_initscr" >&6; } if test "x$ac_cv_lib_curses_initscr" = x""yes; then enable_curses=yes fi fi if test "x$enable_curses" = "xyes"; then cat >>confdefs.h <<\_ACEOF #define HAVE_CURSES 1 _ACEOF fi fi fi if test "x$enable_plotutils" = "xyes"; then { $as_echo "$as_me:$LINENO: GNU plotutils..." >&5 $as_echo "$as_me: GNU plotutils..." >&6;} for ac_header in plot.h do as_ac_Header=`$as_echo "ac_cv_header_$ac_header" | $as_tr_sh` if { as_var=$as_ac_Header; eval "test \"\${$as_var+set}\" = set"; }; then { $as_echo "$as_me:$LINENO: checking for $ac_header" >&5 $as_echo_n "checking for $ac_header... " >&6; } if { as_var=$as_ac_Header; eval "test \"\${$as_var+set}\" = set"; }; then $as_echo_n "(cached) " >&6 fi ac_res=`eval 'as_val=${'$as_ac_Header'} $as_echo "$as_val"'` { $as_echo "$as_me:$LINENO: result: $ac_res" >&5 $as_echo "$ac_res" >&6; } else # Is the header compilable? { $as_echo "$as_me:$LINENO: checking $ac_header usability" >&5 $as_echo_n "checking $ac_header usability... " >&6; } cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ $ac_includes_default #include <$ac_header> _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_header_compiler=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_header_compiler=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext { $as_echo "$as_me:$LINENO: result: $ac_header_compiler" >&5 $as_echo "$ac_header_compiler" >&6; } # Is the header present? { $as_echo "$as_me:$LINENO: checking $ac_header presence" >&5 $as_echo_n "checking $ac_header presence... " >&6; } cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include <$ac_header> _ACEOF if { (ac_try="$ac_cpp conftest.$ac_ext" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_cpp conftest.$ac_ext") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } >/dev/null && { test -z "$ac_c_preproc_warn_flag$ac_c_werror_flag" || test ! -s conftest.err }; then ac_header_preproc=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_header_preproc=no fi rm -f conftest.err conftest.$ac_ext { $as_echo "$as_me:$LINENO: result: $ac_header_preproc" >&5 $as_echo "$ac_header_preproc" >&6; } # So? What about this header? case $ac_header_compiler:$ac_header_preproc:$ac_c_preproc_warn_flag in yes:no: ) { $as_echo "$as_me:$LINENO: WARNING: $ac_header: accepted by the compiler, rejected by the preprocessor!" >&5 $as_echo "$as_me: WARNING: $ac_header: accepted by the compiler, rejected by the preprocessor!" >&2;} { $as_echo "$as_me:$LINENO: WARNING: $ac_header: proceeding with the compiler's result" >&5 $as_echo "$as_me: WARNING: $ac_header: proceeding with the compiler's result" >&2;} ac_header_preproc=yes ;; no:yes:* ) { $as_echo "$as_me:$LINENO: WARNING: $ac_header: present but cannot be compiled" >&5 $as_echo "$as_me: WARNING: $ac_header: present but cannot be compiled" >&2;} { $as_echo "$as_me:$LINENO: WARNING: $ac_header: check for missing prerequisite headers?" >&5 $as_echo "$as_me: WARNING: $ac_header: check for missing prerequisite headers?" >&2;} { $as_echo "$as_me:$LINENO: WARNING: $ac_header: see the Autoconf documentation" >&5 $as_echo "$as_me: WARNING: $ac_header: see the Autoconf documentation" >&2;} { $as_echo "$as_me:$LINENO: WARNING: $ac_header: section \"Present But Cannot Be Compiled\"" >&5 $as_echo "$as_me: WARNING: $ac_header: section \"Present But Cannot Be Compiled\"" >&2;} { $as_echo "$as_me:$LINENO: WARNING: $ac_header: proceeding with the preprocessor's result" >&5 $as_echo "$as_me: WARNING: $ac_header: proceeding with the preprocessor's result" >&2;} { $as_echo "$as_me:$LINENO: WARNING: $ac_header: in the future, the compiler will take precedence" >&5 $as_echo "$as_me: WARNING: $ac_header: in the future, the compiler will take precedence" >&2;} ( cat <<\_ASBOX ## ------------------------------------------------------- ## ## Report this to Marcel van der Veer ## ## ------------------------------------------------------- ## _ASBOX ) | sed "s/^/$as_me: WARNING: /" >&2 ;; esac { $as_echo "$as_me:$LINENO: checking for $ac_header" >&5 $as_echo_n "checking for $ac_header... " >&6; } if { as_var=$as_ac_Header; eval "test \"\${$as_var+set}\" = set"; }; then $as_echo_n "(cached) " >&6 else eval "$as_ac_Header=\$ac_header_preproc" fi ac_res=`eval 'as_val=${'$as_ac_Header'} $as_echo "$as_val"'` { $as_echo "$as_me:$LINENO: result: $ac_res" >&5 $as_echo "$ac_res" >&6; } fi as_val=`eval 'as_val=${'$as_ac_Header'} $as_echo "$as_val"'` if test "x$as_val" = x""yes; then cat >>confdefs.h <<_ACEOF #define `$as_echo "HAVE_$ac_header" | $as_tr_cpp` 1 _ACEOF else enable_plotutils=no fi done { $as_echo "$as_me:$LINENO: checking whether pl_alabel_r is declared" >&5 $as_echo_n "checking whether pl_alabel_r is declared... " >&6; } if test "${ac_cv_have_decl_pl_alabel_r+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include int main () { #ifndef pl_alabel_r (void) pl_alabel_r; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_pl_alabel_r=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_pl_alabel_r=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_pl_alabel_r" >&5 $as_echo "$ac_cv_have_decl_pl_alabel_r" >&6; } if test "x$ac_cv_have_decl_pl_alabel_r" = x""yes; then : else enable_plotutils=no fi { $as_echo "$as_me:$LINENO: checking for pl_alabel_r in -lplot" >&5 $as_echo_n "checking for pl_alabel_r in -lplot... " >&6; } if test "${ac_cv_lib_plot_pl_alabel_r+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lplot $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char pl_alabel_r (); int main () { return pl_alabel_r (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_plot_pl_alabel_r=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_plot_pl_alabel_r=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_plot_pl_alabel_r" >&5 $as_echo "$ac_cv_lib_plot_pl_alabel_r" >&6; } if test "x$ac_cv_lib_plot_pl_alabel_r" = x""yes; then a68g_unexpected=yes else enable_plotutils=no fi if test "x$enable_plotutils" = "xyes"; then { $as_echo "$as_me:$LINENO: checking whether pl_bgcolor_r is declared" >&5 $as_echo_n "checking whether pl_bgcolor_r is declared... " >&6; } if test "${ac_cv_have_decl_pl_bgcolor_r+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include int main () { #ifndef pl_bgcolor_r (void) pl_bgcolor_r; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_pl_bgcolor_r=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_pl_bgcolor_r=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_pl_bgcolor_r" >&5 $as_echo "$ac_cv_have_decl_pl_bgcolor_r" >&6; } if test "x$ac_cv_have_decl_pl_bgcolor_r" = x""yes; then : else enable_plotutils=no fi { $as_echo "$as_me:$LINENO: checking for pl_bgcolor_r in -lplot" >&5 $as_echo_n "checking for pl_bgcolor_r in -lplot... " >&6; } if test "${ac_cv_lib_plot_pl_bgcolor_r+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lplot $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char pl_bgcolor_r (); int main () { return pl_bgcolor_r (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_plot_pl_bgcolor_r=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_plot_pl_bgcolor_r=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_plot_pl_bgcolor_r" >&5 $as_echo "$ac_cv_lib_plot_pl_bgcolor_r" >&6; } if test "x$ac_cv_lib_plot_pl_bgcolor_r" = x""yes; then a68g_unexpected=yes else enable_plotutils=no fi { $as_echo "$as_me:$LINENO: checking whether pl_bgcolorname_r is declared" >&5 $as_echo_n "checking whether pl_bgcolorname_r is declared... " >&6; } if test "${ac_cv_have_decl_pl_bgcolorname_r+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include int main () { #ifndef pl_bgcolorname_r (void) pl_bgcolorname_r; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_pl_bgcolorname_r=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_pl_bgcolorname_r=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_pl_bgcolorname_r" >&5 $as_echo "$ac_cv_have_decl_pl_bgcolorname_r" >&6; } if test "x$ac_cv_have_decl_pl_bgcolorname_r" = x""yes; then : else enable_plotutils=no fi { $as_echo "$as_me:$LINENO: checking for pl_bgcolorname_r in -lplot" >&5 $as_echo_n "checking for pl_bgcolorname_r in -lplot... " >&6; } if test "${ac_cv_lib_plot_pl_bgcolorname_r+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lplot $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char pl_bgcolorname_r (); int main () { return pl_bgcolorname_r (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_plot_pl_bgcolorname_r=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_plot_pl_bgcolorname_r=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_plot_pl_bgcolorname_r" >&5 $as_echo "$ac_cv_lib_plot_pl_bgcolorname_r" >&6; } if test "x$ac_cv_lib_plot_pl_bgcolorname_r" = x""yes; then a68g_unexpected=yes else enable_plotutils=no fi { $as_echo "$as_me:$LINENO: checking whether pl_color_r is declared" >&5 $as_echo_n "checking whether pl_color_r is declared... " >&6; } if test "${ac_cv_have_decl_pl_color_r+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include int main () { #ifndef pl_color_r (void) pl_color_r; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_pl_color_r=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_pl_color_r=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_pl_color_r" >&5 $as_echo "$ac_cv_have_decl_pl_color_r" >&6; } if test "x$ac_cv_have_decl_pl_color_r" = x""yes; then : else enable_plotutils=no fi { $as_echo "$as_me:$LINENO: checking for pl_color_r in -lplot" >&5 $as_echo_n "checking for pl_color_r in -lplot... " >&6; } if test "${ac_cv_lib_plot_pl_color_r+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lplot $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char pl_color_r (); int main () { return pl_color_r (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_plot_pl_color_r=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_plot_pl_color_r=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_plot_pl_color_r" >&5 $as_echo "$ac_cv_lib_plot_pl_color_r" >&6; } if test "x$ac_cv_lib_plot_pl_color_r" = x""yes; then a68g_unexpected=yes else enable_plotutils=no fi { $as_echo "$as_me:$LINENO: checking whether pl_colorname_r is declared" >&5 $as_echo_n "checking whether pl_colorname_r is declared... " >&6; } if test "${ac_cv_have_decl_pl_colorname_r+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include int main () { #ifndef pl_colorname_r (void) pl_colorname_r; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_pl_colorname_r=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_pl_colorname_r=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_pl_colorname_r" >&5 $as_echo "$ac_cv_have_decl_pl_colorname_r" >&6; } if test "x$ac_cv_have_decl_pl_colorname_r" = x""yes; then : else enable_plotutils=no fi { $as_echo "$as_me:$LINENO: checking for pl_colorname_r in -lplot" >&5 $as_echo_n "checking for pl_colorname_r in -lplot... " >&6; } if test "${ac_cv_lib_plot_pl_colorname_r+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lplot $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char pl_colorname_r (); int main () { return pl_colorname_r (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_plot_pl_colorname_r=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_plot_pl_colorname_r=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_plot_pl_colorname_r" >&5 $as_echo "$ac_cv_lib_plot_pl_colorname_r" >&6; } if test "x$ac_cv_lib_plot_pl_colorname_r" = x""yes; then a68g_unexpected=yes else enable_plotutils=no fi { $as_echo "$as_me:$LINENO: checking whether pl_erase_r is declared" >&5 $as_echo_n "checking whether pl_erase_r is declared... " >&6; } if test "${ac_cv_have_decl_pl_erase_r+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include int main () { #ifndef pl_erase_r (void) pl_erase_r; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_pl_erase_r=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_pl_erase_r=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_pl_erase_r" >&5 $as_echo "$ac_cv_have_decl_pl_erase_r" >&6; } if test "x$ac_cv_have_decl_pl_erase_r" = x""yes; then : else enable_plotutils=no fi { $as_echo "$as_me:$LINENO: checking for pl_erase_r in -lplot" >&5 $as_echo_n "checking for pl_erase_r in -lplot... " >&6; } if test "${ac_cv_lib_plot_pl_erase_r+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lplot $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char pl_erase_r (); int main () { return pl_erase_r (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_plot_pl_erase_r=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_plot_pl_erase_r=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_plot_pl_erase_r" >&5 $as_echo "$ac_cv_lib_plot_pl_erase_r" >&6; } if test "x$ac_cv_lib_plot_pl_erase_r" = x""yes; then a68g_unexpected=yes else enable_plotutils=no fi { $as_echo "$as_me:$LINENO: checking whether pl_fbox_r is declared" >&5 $as_echo_n "checking whether pl_fbox_r is declared... " >&6; } if test "${ac_cv_have_decl_pl_fbox_r+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include int main () { #ifndef pl_fbox_r (void) pl_fbox_r; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_pl_fbox_r=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_pl_fbox_r=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_pl_fbox_r" >&5 $as_echo "$ac_cv_have_decl_pl_fbox_r" >&6; } if test "x$ac_cv_have_decl_pl_fbox_r" = x""yes; then : else enable_plotutils=no fi { $as_echo "$as_me:$LINENO: checking for pl_fbox_r in -lplot" >&5 $as_echo_n "checking for pl_fbox_r in -lplot... " >&6; } if test "${ac_cv_lib_plot_pl_fbox_r+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lplot $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char pl_fbox_r (); int main () { return pl_fbox_r (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_plot_pl_fbox_r=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_plot_pl_fbox_r=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_plot_pl_fbox_r" >&5 $as_echo "$ac_cv_lib_plot_pl_fbox_r" >&6; } if test "x$ac_cv_lib_plot_pl_fbox_r" = x""yes; then a68g_unexpected=yes else enable_plotutils=no fi { $as_echo "$as_me:$LINENO: checking whether pl_fcircle_r is declared" >&5 $as_echo_n "checking whether pl_fcircle_r is declared... " >&6; } if test "${ac_cv_have_decl_pl_fcircle_r+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include int main () { #ifndef pl_fcircle_r (void) pl_fcircle_r; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_pl_fcircle_r=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_pl_fcircle_r=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_pl_fcircle_r" >&5 $as_echo "$ac_cv_have_decl_pl_fcircle_r" >&6; } if test "x$ac_cv_have_decl_pl_fcircle_r" = x""yes; then : else enable_plotutils=no fi { $as_echo "$as_me:$LINENO: checking for pl_fcircle_r in -lplot" >&5 $as_echo_n "checking for pl_fcircle_r in -lplot... " >&6; } if test "${ac_cv_lib_plot_pl_fcircle_r+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lplot $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char pl_fcircle_r (); int main () { return pl_fcircle_r (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_plot_pl_fcircle_r=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_plot_pl_fcircle_r=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_plot_pl_fcircle_r" >&5 $as_echo "$ac_cv_lib_plot_pl_fcircle_r" >&6; } if test "x$ac_cv_lib_plot_pl_fcircle_r" = x""yes; then a68g_unexpected=yes else enable_plotutils=no fi { $as_echo "$as_me:$LINENO: checking whether pl_fillcolor_r is declared" >&5 $as_echo_n "checking whether pl_fillcolor_r is declared... " >&6; } if test "${ac_cv_have_decl_pl_fillcolor_r+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include int main () { #ifndef pl_fillcolor_r (void) pl_fillcolor_r; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_pl_fillcolor_r=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_pl_fillcolor_r=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_pl_fillcolor_r" >&5 $as_echo "$ac_cv_have_decl_pl_fillcolor_r" >&6; } if test "x$ac_cv_have_decl_pl_fillcolor_r" = x""yes; then : else enable_plotutils=no fi { $as_echo "$as_me:$LINENO: checking for pl_fillcolor_r in -lplot" >&5 $as_echo_n "checking for pl_fillcolor_r in -lplot... " >&6; } if test "${ac_cv_lib_plot_pl_fillcolor_r+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lplot $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char pl_fillcolor_r (); int main () { return pl_fillcolor_r (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_plot_pl_fillcolor_r=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_plot_pl_fillcolor_r=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_plot_pl_fillcolor_r" >&5 $as_echo "$ac_cv_lib_plot_pl_fillcolor_r" >&6; } if test "x$ac_cv_lib_plot_pl_fillcolor_r" = x""yes; then a68g_unexpected=yes else enable_plotutils=no fi { $as_echo "$as_me:$LINENO: checking whether pl_fillcolorname_r is declared" >&5 $as_echo_n "checking whether pl_fillcolorname_r is declared... " >&6; } if test "${ac_cv_have_decl_pl_fillcolorname_r+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include int main () { #ifndef pl_fillcolorname_r (void) pl_fillcolorname_r; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_pl_fillcolorname_r=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_pl_fillcolorname_r=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_pl_fillcolorname_r" >&5 $as_echo "$ac_cv_have_decl_pl_fillcolorname_r" >&6; } if test "x$ac_cv_have_decl_pl_fillcolorname_r" = x""yes; then : else enable_plotutils=no fi { $as_echo "$as_me:$LINENO: checking for pl_fillcolorname_r in -lplot" >&5 $as_echo_n "checking for pl_fillcolorname_r in -lplot... " >&6; } if test "${ac_cv_lib_plot_pl_fillcolorname_r+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lplot $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char pl_fillcolorname_r (); int main () { return pl_fillcolorname_r (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_plot_pl_fillcolorname_r=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_plot_pl_fillcolorname_r=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_plot_pl_fillcolorname_r" >&5 $as_echo "$ac_cv_lib_plot_pl_fillcolorname_r" >&6; } if test "x$ac_cv_lib_plot_pl_fillcolorname_r" = x""yes; then a68g_unexpected=yes else enable_plotutils=no fi { $as_echo "$as_me:$LINENO: checking whether pl_filltype_r is declared" >&5 $as_echo_n "checking whether pl_filltype_r is declared... " >&6; } if test "${ac_cv_have_decl_pl_filltype_r+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include int main () { #ifndef pl_filltype_r (void) pl_filltype_r; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_pl_filltype_r=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_pl_filltype_r=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_pl_filltype_r" >&5 $as_echo "$ac_cv_have_decl_pl_filltype_r" >&6; } if test "x$ac_cv_have_decl_pl_filltype_r" = x""yes; then : else enable_plotutils=no fi { $as_echo "$as_me:$LINENO: checking for pl_filltype_r in -lplot" >&5 $as_echo_n "checking for pl_filltype_r in -lplot... " >&6; } if test "${ac_cv_lib_plot_pl_filltype_r+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lplot $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char pl_filltype_r (); int main () { return pl_filltype_r (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_plot_pl_filltype_r=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_plot_pl_filltype_r=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_plot_pl_filltype_r" >&5 $as_echo "$ac_cv_lib_plot_pl_filltype_r" >&6; } if test "x$ac_cv_lib_plot_pl_filltype_r" = x""yes; then a68g_unexpected=yes else enable_plotutils=no fi { $as_echo "$as_me:$LINENO: checking whether pl_fline_r is declared" >&5 $as_echo_n "checking whether pl_fline_r is declared... " >&6; } if test "${ac_cv_have_decl_pl_fline_r+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include int main () { #ifndef pl_fline_r (void) pl_fline_r; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_pl_fline_r=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_pl_fline_r=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_pl_fline_r" >&5 $as_echo "$ac_cv_have_decl_pl_fline_r" >&6; } if test "x$ac_cv_have_decl_pl_fline_r" = x""yes; then : else enable_plotutils=no fi { $as_echo "$as_me:$LINENO: checking for pl_fline_r in -lplot" >&5 $as_echo_n "checking for pl_fline_r in -lplot... " >&6; } if test "${ac_cv_lib_plot_pl_fline_r+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lplot $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char pl_fline_r (); int main () { return pl_fline_r (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_plot_pl_fline_r=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_plot_pl_fline_r=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_plot_pl_fline_r" >&5 $as_echo "$ac_cv_lib_plot_pl_fline_r" >&6; } if test "x$ac_cv_lib_plot_pl_fline_r" = x""yes; then a68g_unexpected=yes else enable_plotutils=no fi { $as_echo "$as_me:$LINENO: checking whether pl_fmove_r is declared" >&5 $as_echo_n "checking whether pl_fmove_r is declared... " >&6; } if test "${ac_cv_have_decl_pl_fmove_r+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include int main () { #ifndef pl_fmove_r (void) pl_fmove_r; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_pl_fmove_r=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_pl_fmove_r=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_pl_fmove_r" >&5 $as_echo "$ac_cv_have_decl_pl_fmove_r" >&6; } if test "x$ac_cv_have_decl_pl_fmove_r" = x""yes; then : else enable_plotutils=no fi { $as_echo "$as_me:$LINENO: checking for pl_fmove_r in -lplot" >&5 $as_echo_n "checking for pl_fmove_r in -lplot... " >&6; } if test "${ac_cv_lib_plot_pl_fmove_r+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lplot $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char pl_fmove_r (); int main () { return pl_fmove_r (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_plot_pl_fmove_r=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_plot_pl_fmove_r=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_plot_pl_fmove_r" >&5 $as_echo "$ac_cv_lib_plot_pl_fmove_r" >&6; } if test "x$ac_cv_lib_plot_pl_fmove_r" = x""yes; then a68g_unexpected=yes else enable_plotutils=no fi { $as_echo "$as_me:$LINENO: checking whether pl_fontname_r is declared" >&5 $as_echo_n "checking whether pl_fontname_r is declared... " >&6; } if test "${ac_cv_have_decl_pl_fontname_r+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include int main () { #ifndef pl_fontname_r (void) pl_fontname_r; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_pl_fontname_r=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_pl_fontname_r=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_pl_fontname_r" >&5 $as_echo "$ac_cv_have_decl_pl_fontname_r" >&6; } if test "x$ac_cv_have_decl_pl_fontname_r" = x""yes; then : else enable_plotutils=no fi { $as_echo "$as_me:$LINENO: checking for pl_fontname_r in -lplot" >&5 $as_echo_n "checking for pl_fontname_r in -lplot... " >&6; } if test "${ac_cv_lib_plot_pl_fontname_r+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lplot $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char pl_fontname_r (); int main () { return pl_fontname_r (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_plot_pl_fontname_r=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_plot_pl_fontname_r=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_plot_pl_fontname_r" >&5 $as_echo "$ac_cv_lib_plot_pl_fontname_r" >&6; } if test "x$ac_cv_lib_plot_pl_fontname_r" = x""yes; then a68g_unexpected=yes else enable_plotutils=no fi { $as_echo "$as_me:$LINENO: checking whether pl_fontsize_r is declared" >&5 $as_echo_n "checking whether pl_fontsize_r is declared... " >&6; } if test "${ac_cv_have_decl_pl_fontsize_r+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include int main () { #ifndef pl_fontsize_r (void) pl_fontsize_r; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_pl_fontsize_r=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_pl_fontsize_r=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_pl_fontsize_r" >&5 $as_echo "$ac_cv_have_decl_pl_fontsize_r" >&6; } if test "x$ac_cv_have_decl_pl_fontsize_r" = x""yes; then : else enable_plotutils=no fi { $as_echo "$as_me:$LINENO: checking for pl_fontsize_r in -lplot" >&5 $as_echo_n "checking for pl_fontsize_r in -lplot... " >&6; } if test "${ac_cv_lib_plot_pl_fontsize_r+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lplot $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char pl_fontsize_r (); int main () { return pl_fontsize_r (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_plot_pl_fontsize_r=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_plot_pl_fontsize_r=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_plot_pl_fontsize_r" >&5 $as_echo "$ac_cv_lib_plot_pl_fontsize_r" >&6; } if test "x$ac_cv_lib_plot_pl_fontsize_r" = x""yes; then a68g_unexpected=yes else enable_plotutils=no fi { $as_echo "$as_me:$LINENO: checking whether pl_fpoint_r is declared" >&5 $as_echo_n "checking whether pl_fpoint_r is declared... " >&6; } if test "${ac_cv_have_decl_pl_fpoint_r+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include int main () { #ifndef pl_fpoint_r (void) pl_fpoint_r; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_pl_fpoint_r=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_pl_fpoint_r=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_pl_fpoint_r" >&5 $as_echo "$ac_cv_have_decl_pl_fpoint_r" >&6; } if test "x$ac_cv_have_decl_pl_fpoint_r" = x""yes; then : else enable_plotutils=no fi { $as_echo "$as_me:$LINENO: checking for pl_fpoint_r in -lplot" >&5 $as_echo_n "checking for pl_fpoint_r in -lplot... " >&6; } if test "${ac_cv_lib_plot_pl_fpoint_r+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lplot $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char pl_fpoint_r (); int main () { return pl_fpoint_r (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_plot_pl_fpoint_r=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_plot_pl_fpoint_r=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_plot_pl_fpoint_r" >&5 $as_echo "$ac_cv_lib_plot_pl_fpoint_r" >&6; } if test "x$ac_cv_lib_plot_pl_fpoint_r" = x""yes; then a68g_unexpected=yes else enable_plotutils=no fi { $as_echo "$as_me:$LINENO: checking whether pl_linemod_r is declared" >&5 $as_echo_n "checking whether pl_linemod_r is declared... " >&6; } if test "${ac_cv_have_decl_pl_linemod_r+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include int main () { #ifndef pl_linemod_r (void) pl_linemod_r; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_pl_linemod_r=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_pl_linemod_r=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_pl_linemod_r" >&5 $as_echo "$ac_cv_have_decl_pl_linemod_r" >&6; } if test "x$ac_cv_have_decl_pl_linemod_r" = x""yes; then : else enable_plotutils=no fi { $as_echo "$as_me:$LINENO: checking for pl_linemod_r in -lplot" >&5 $as_echo_n "checking for pl_linemod_r in -lplot... " >&6; } if test "${ac_cv_lib_plot_pl_linemod_r+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lplot $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char pl_linemod_r (); int main () { return pl_linemod_r (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_plot_pl_linemod_r=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_plot_pl_linemod_r=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_plot_pl_linemod_r" >&5 $as_echo "$ac_cv_lib_plot_pl_linemod_r" >&6; } if test "x$ac_cv_lib_plot_pl_linemod_r" = x""yes; then a68g_unexpected=yes else enable_plotutils=no fi { $as_echo "$as_me:$LINENO: checking whether pl_linewidth_r is declared" >&5 $as_echo_n "checking whether pl_linewidth_r is declared... " >&6; } if test "${ac_cv_have_decl_pl_linewidth_r+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include int main () { #ifndef pl_linewidth_r (void) pl_linewidth_r; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_pl_linewidth_r=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_pl_linewidth_r=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_pl_linewidth_r" >&5 $as_echo "$ac_cv_have_decl_pl_linewidth_r" >&6; } if test "x$ac_cv_have_decl_pl_linewidth_r" = x""yes; then : else enable_plotutils=no fi { $as_echo "$as_me:$LINENO: checking for pl_linewidth_r in -lplot" >&5 $as_echo_n "checking for pl_linewidth_r in -lplot... " >&6; } if test "${ac_cv_lib_plot_pl_linewidth_r+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lplot $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char pl_linewidth_r (); int main () { return pl_linewidth_r (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_plot_pl_linewidth_r=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_plot_pl_linewidth_r=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_plot_pl_linewidth_r" >&5 $as_echo "$ac_cv_lib_plot_pl_linewidth_r" >&6; } if test "x$ac_cv_lib_plot_pl_linewidth_r" = x""yes; then a68g_unexpected=yes else enable_plotutils=no fi { $as_echo "$as_me:$LINENO: checking whether pl_newplparams is declared" >&5 $as_echo_n "checking whether pl_newplparams is declared... " >&6; } if test "${ac_cv_have_decl_pl_newplparams+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include int main () { #ifndef pl_newplparams (void) pl_newplparams; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_pl_newplparams=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_pl_newplparams=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_pl_newplparams" >&5 $as_echo "$ac_cv_have_decl_pl_newplparams" >&6; } if test "x$ac_cv_have_decl_pl_newplparams" = x""yes; then : else enable_plotutils=no fi { $as_echo "$as_me:$LINENO: checking for pl_newplparams in -lplot" >&5 $as_echo_n "checking for pl_newplparams in -lplot... " >&6; } if test "${ac_cv_lib_plot_pl_newplparams+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lplot $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char pl_newplparams (); int main () { return pl_newplparams (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_plot_pl_newplparams=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_plot_pl_newplparams=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_plot_pl_newplparams" >&5 $as_echo "$ac_cv_lib_plot_pl_newplparams" >&6; } if test "x$ac_cv_lib_plot_pl_newplparams" = x""yes; then a68g_unexpected=yes else enable_plotutils=no fi { $as_echo "$as_me:$LINENO: checking whether pl_openpl_r is declared" >&5 $as_echo_n "checking whether pl_openpl_r is declared... " >&6; } if test "${ac_cv_have_decl_pl_openpl_r+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include int main () { #ifndef pl_openpl_r (void) pl_openpl_r; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_pl_openpl_r=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_pl_openpl_r=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_pl_openpl_r" >&5 $as_echo "$ac_cv_have_decl_pl_openpl_r" >&6; } if test "x$ac_cv_have_decl_pl_openpl_r" = x""yes; then : else enable_plotutils=no fi { $as_echo "$as_me:$LINENO: checking for pl_openpl_r in -lplot" >&5 $as_echo_n "checking for pl_openpl_r in -lplot... " >&6; } if test "${ac_cv_lib_plot_pl_openpl_r+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lplot $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char pl_openpl_r (); int main () { return pl_openpl_r (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_plot_pl_openpl_r=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_plot_pl_openpl_r=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_plot_pl_openpl_r" >&5 $as_echo "$ac_cv_lib_plot_pl_openpl_r" >&6; } if test "x$ac_cv_lib_plot_pl_openpl_r" = x""yes; then a68g_unexpected=yes else enable_plotutils=no fi { $as_echo "$as_me:$LINENO: checking whether pl_pencolor_r is declared" >&5 $as_echo_n "checking whether pl_pencolor_r is declared... " >&6; } if test "${ac_cv_have_decl_pl_pencolor_r+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include int main () { #ifndef pl_pencolor_r (void) pl_pencolor_r; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_pl_pencolor_r=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_pl_pencolor_r=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_pl_pencolor_r" >&5 $as_echo "$ac_cv_have_decl_pl_pencolor_r" >&6; } if test "x$ac_cv_have_decl_pl_pencolor_r" = x""yes; then : else enable_plotutils=no fi { $as_echo "$as_me:$LINENO: checking for pl_pencolor_r in -lplot" >&5 $as_echo_n "checking for pl_pencolor_r in -lplot... " >&6; } if test "${ac_cv_lib_plot_pl_pencolor_r+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lplot $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char pl_pencolor_r (); int main () { return pl_pencolor_r (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_plot_pl_pencolor_r=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_plot_pl_pencolor_r=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_plot_pl_pencolor_r" >&5 $as_echo "$ac_cv_lib_plot_pl_pencolor_r" >&6; } if test "x$ac_cv_lib_plot_pl_pencolor_r" = x""yes; then a68g_unexpected=yes else enable_plotutils=no fi { $as_echo "$as_me:$LINENO: checking whether pl_pencolorname_r is declared" >&5 $as_echo_n "checking whether pl_pencolorname_r is declared... " >&6; } if test "${ac_cv_have_decl_pl_pencolorname_r+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include int main () { #ifndef pl_pencolorname_r (void) pl_pencolorname_r; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_pl_pencolorname_r=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_pl_pencolorname_r=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_pl_pencolorname_r" >&5 $as_echo "$ac_cv_have_decl_pl_pencolorname_r" >&6; } if test "x$ac_cv_have_decl_pl_pencolorname_r" = x""yes; then : else enable_plotutils=no fi { $as_echo "$as_me:$LINENO: checking for pl_pencolorname_r in -lplot" >&5 $as_echo_n "checking for pl_pencolorname_r in -lplot... " >&6; } if test "${ac_cv_lib_plot_pl_pencolorname_r+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lplot $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char pl_pencolorname_r (); int main () { return pl_pencolorname_r (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_plot_pl_pencolorname_r=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_plot_pl_pencolorname_r=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_plot_pl_pencolorname_r" >&5 $as_echo "$ac_cv_lib_plot_pl_pencolorname_r" >&6; } if test "x$ac_cv_lib_plot_pl_pencolorname_r" = x""yes; then a68g_unexpected=yes else enable_plotutils=no fi { $as_echo "$as_me:$LINENO: checking whether pl_setplparam is declared" >&5 $as_echo_n "checking whether pl_setplparam is declared... " >&6; } if test "${ac_cv_have_decl_pl_setplparam+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include int main () { #ifndef pl_setplparam (void) pl_setplparam; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_pl_setplparam=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_pl_setplparam=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_pl_setplparam" >&5 $as_echo "$ac_cv_have_decl_pl_setplparam" >&6; } if test "x$ac_cv_have_decl_pl_setplparam" = x""yes; then : else enable_plotutils=no fi { $as_echo "$as_me:$LINENO: checking for pl_setplparam in -lplot" >&5 $as_echo_n "checking for pl_setplparam in -lplot... " >&6; } if test "${ac_cv_lib_plot_pl_setplparam+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lplot $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char pl_setplparam (); int main () { return pl_setplparam (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_plot_pl_setplparam=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_plot_pl_setplparam=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_plot_pl_setplparam" >&5 $as_echo "$ac_cv_lib_plot_pl_setplparam" >&6; } if test "x$ac_cv_lib_plot_pl_setplparam" = x""yes; then a68g_unexpected=yes else enable_plotutils=no fi { $as_echo "$as_me:$LINENO: checking whether pl_space_r is declared" >&5 $as_echo_n "checking whether pl_space_r is declared... " >&6; } if test "${ac_cv_have_decl_pl_space_r+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include int main () { #ifndef pl_space_r (void) pl_space_r; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_pl_space_r=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_pl_space_r=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_pl_space_r" >&5 $as_echo "$ac_cv_have_decl_pl_space_r" >&6; } if test "x$ac_cv_have_decl_pl_space_r" = x""yes; then : else enable_plotutils=no fi { $as_echo "$as_me:$LINENO: checking for pl_space_r in -lplot" >&5 $as_echo_n "checking for pl_space_r in -lplot... " >&6; } if test "${ac_cv_lib_plot_pl_space_r+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lplot $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char pl_space_r (); int main () { return pl_space_r (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_plot_pl_space_r=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_plot_pl_space_r=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_plot_pl_space_r" >&5 $as_echo "$ac_cv_lib_plot_pl_space_r" >&6; } if test "x$ac_cv_lib_plot_pl_space_r" = x""yes; then a68g_unexpected=yes else enable_plotutils=no fi { $as_echo "$as_me:$LINENO: checking whether pl_textangle_r is declared" >&5 $as_echo_n "checking whether pl_textangle_r is declared... " >&6; } if test "${ac_cv_have_decl_pl_textangle_r+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include int main () { #ifndef pl_textangle_r (void) pl_textangle_r; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_pl_textangle_r=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_pl_textangle_r=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_pl_textangle_r" >&5 $as_echo "$ac_cv_have_decl_pl_textangle_r" >&6; } if test "x$ac_cv_have_decl_pl_textangle_r" = x""yes; then : else enable_plotutils=no fi { $as_echo "$as_me:$LINENO: checking for pl_textangle_r in -lplot" >&5 $as_echo_n "checking for pl_textangle_r in -lplot... " >&6; } if test "${ac_cv_lib_plot_pl_textangle_r+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lplot $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char pl_textangle_r (); int main () { return pl_textangle_r (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_plot_pl_textangle_r=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_plot_pl_textangle_r=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_plot_pl_textangle_r" >&5 $as_echo "$ac_cv_lib_plot_pl_textangle_r" >&6; } if test "x$ac_cv_lib_plot_pl_textangle_r" = x""yes; then a68g_unexpected=yes else enable_plotutils=no fi fi if test "x$enable_plotutils" = "xyes"; then { $as_echo "$as_me:$LINENO: checking for pl_alabel_r in -lplot" >&5 $as_echo_n "checking for pl_alabel_r in -lplot... " >&6; } if test "${ac_cv_lib_plot_pl_alabel_r+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lplot $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char pl_alabel_r (); int main () { return pl_alabel_r (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_plot_pl_alabel_r=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_plot_pl_alabel_r=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_plot_pl_alabel_r" >&5 $as_echo "$ac_cv_lib_plot_pl_alabel_r" >&6; } if test "x$ac_cv_lib_plot_pl_alabel_r" = x""yes; then cat >>confdefs.h <<_ACEOF #define HAVE_LIBPLOT 1 _ACEOF LIBS="-lplot $LIBS" fi cat >>confdefs.h <<\_ACEOF #define HAVE_GNU_PLOTUTILS 1 _ACEOF fi fi if test "x$enable_gsl" = "xyes"; then { $as_echo "$as_me:$LINENO: GNU scientific library..." >&5 $as_echo "$as_me: GNU scientific library..." >&6;} for ac_header in gsl/gsl_blas.h gsl/gsl_complex.h gsl/gsl_complex_math.h gsl/gsl_errno.h gsl/gsl_fft_complex.h gsl/gsl_integration.h gsl/gsl_linalg.h gsl/gsl_math.h gsl/gsl_matrix.h gsl/gsl_permutation.h gsl/gsl_sf.h gsl/gsl_vector.h do as_ac_Header=`$as_echo "ac_cv_header_$ac_header" | $as_tr_sh` if { as_var=$as_ac_Header; eval "test \"\${$as_var+set}\" = set"; }; then { $as_echo "$as_me:$LINENO: checking for $ac_header" >&5 $as_echo_n "checking for $ac_header... " >&6; } if { as_var=$as_ac_Header; eval "test \"\${$as_var+set}\" = set"; }; then $as_echo_n "(cached) " >&6 fi ac_res=`eval 'as_val=${'$as_ac_Header'} $as_echo "$as_val"'` { $as_echo "$as_me:$LINENO: result: $ac_res" >&5 $as_echo "$ac_res" >&6; } else # Is the header compilable? { $as_echo "$as_me:$LINENO: checking $ac_header usability" >&5 $as_echo_n "checking $ac_header usability... " >&6; } cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ $ac_includes_default #include <$ac_header> _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_header_compiler=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_header_compiler=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext { $as_echo "$as_me:$LINENO: result: $ac_header_compiler" >&5 $as_echo "$ac_header_compiler" >&6; } # Is the header present? { $as_echo "$as_me:$LINENO: checking $ac_header presence" >&5 $as_echo_n "checking $ac_header presence... " >&6; } cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include <$ac_header> _ACEOF if { (ac_try="$ac_cpp conftest.$ac_ext" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_cpp conftest.$ac_ext") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } >/dev/null && { test -z "$ac_c_preproc_warn_flag$ac_c_werror_flag" || test ! -s conftest.err }; then ac_header_preproc=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_header_preproc=no fi rm -f conftest.err conftest.$ac_ext { $as_echo "$as_me:$LINENO: result: $ac_header_preproc" >&5 $as_echo "$ac_header_preproc" >&6; } # So? What about this header? case $ac_header_compiler:$ac_header_preproc:$ac_c_preproc_warn_flag in yes:no: ) { $as_echo "$as_me:$LINENO: WARNING: $ac_header: accepted by the compiler, rejected by the preprocessor!" >&5 $as_echo "$as_me: WARNING: $ac_header: accepted by the compiler, rejected by the preprocessor!" >&2;} { $as_echo "$as_me:$LINENO: WARNING: $ac_header: proceeding with the compiler's result" >&5 $as_echo "$as_me: WARNING: $ac_header: proceeding with the compiler's result" >&2;} ac_header_preproc=yes ;; no:yes:* ) { $as_echo "$as_me:$LINENO: WARNING: $ac_header: present but cannot be compiled" >&5 $as_echo "$as_me: WARNING: $ac_header: present but cannot be compiled" >&2;} { $as_echo "$as_me:$LINENO: WARNING: $ac_header: check for missing prerequisite headers?" >&5 $as_echo "$as_me: WARNING: $ac_header: check for missing prerequisite headers?" >&2;} { $as_echo "$as_me:$LINENO: WARNING: $ac_header: see the Autoconf documentation" >&5 $as_echo "$as_me: WARNING: $ac_header: see the Autoconf documentation" >&2;} { $as_echo "$as_me:$LINENO: WARNING: $ac_header: section \"Present But Cannot Be Compiled\"" >&5 $as_echo "$as_me: WARNING: $ac_header: section \"Present But Cannot Be Compiled\"" >&2;} { $as_echo "$as_me:$LINENO: WARNING: $ac_header: proceeding with the preprocessor's result" >&5 $as_echo "$as_me: WARNING: $ac_header: proceeding with the preprocessor's result" >&2;} { $as_echo "$as_me:$LINENO: WARNING: $ac_header: in the future, the compiler will take precedence" >&5 $as_echo "$as_me: WARNING: $ac_header: in the future, the compiler will take precedence" >&2;} ( cat <<\_ASBOX ## ------------------------------------------------------- ## ## Report this to Marcel van der Veer ## ## ------------------------------------------------------- ## _ASBOX ) | sed "s/^/$as_me: WARNING: /" >&2 ;; esac { $as_echo "$as_me:$LINENO: checking for $ac_header" >&5 $as_echo_n "checking for $ac_header... " >&6; } if { as_var=$as_ac_Header; eval "test \"\${$as_var+set}\" = set"; }; then $as_echo_n "(cached) " >&6 else eval "$as_ac_Header=\$ac_header_preproc" fi ac_res=`eval 'as_val=${'$as_ac_Header'} $as_echo "$as_val"'` { $as_echo "$as_me:$LINENO: result: $ac_res" >&5 $as_echo "$ac_res" >&6; } fi as_val=`eval 'as_val=${'$as_ac_Header'} $as_echo "$as_val"'` if test "x$as_val" = x""yes; then cat >>confdefs.h <<_ACEOF #define `$as_echo "HAVE_$ac_header" | $as_tr_cpp` 1 _ACEOF else enable_gsl=no fi done { $as_echo "$as_me:$LINENO: checking for cblas_dgemm in -lgslcblas" >&5 $as_echo_n "checking for cblas_dgemm in -lgslcblas... " >&6; } if test "${ac_cv_lib_gslcblas_cblas_dgemm+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgslcblas $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char cblas_dgemm (); int main () { return cblas_dgemm (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gslcblas_cblas_dgemm=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gslcblas_cblas_dgemm=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gslcblas_cblas_dgemm" >&5 $as_echo "$ac_cv_lib_gslcblas_cblas_dgemm" >&6; } if test "x$ac_cv_lib_gslcblas_cblas_dgemm" = x""yes; then cat >>confdefs.h <<_ACEOF #define HAVE_LIBGSLCBLAS 1 _ACEOF LIBS="-lgslcblas $LIBS" else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_blas_ddot is declared" >&5 $as_echo_n "checking whether gsl_blas_ddot is declared... " >&6; } if test "${ac_cv_have_decl_gsl_blas_ddot+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_blas_ddot (void) gsl_blas_ddot; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_blas_ddot=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_blas_ddot=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_blas_ddot" >&5 $as_echo "$ac_cv_have_decl_gsl_blas_ddot" >&6; } if test "x$ac_cv_have_decl_gsl_blas_ddot" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_blas_ddot in -lgsl" >&5 $as_echo_n "checking for gsl_blas_ddot in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_blas_ddot+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_blas_ddot (); int main () { return gsl_blas_ddot (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_blas_ddot=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_blas_ddot=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_blas_ddot" >&5 $as_echo "$ac_cv_lib_gsl_gsl_blas_ddot" >&6; } if test "x$ac_cv_lib_gsl_gsl_blas_ddot" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi if test "x$enable_gsl" = "xyes"; then { $as_echo "$as_me:$LINENO: checking whether gsl_blas_dgemm is declared" >&5 $as_echo_n "checking whether gsl_blas_dgemm is declared... " >&6; } if test "${ac_cv_have_decl_gsl_blas_dgemm+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_blas_dgemm (void) gsl_blas_dgemm; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_blas_dgemm=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_blas_dgemm=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_blas_dgemm" >&5 $as_echo "$ac_cv_have_decl_gsl_blas_dgemm" >&6; } if test "x$ac_cv_have_decl_gsl_blas_dgemm" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_blas_dgemm in -lgsl" >&5 $as_echo_n "checking for gsl_blas_dgemm in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_blas_dgemm+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_blas_dgemm (); int main () { return gsl_blas_dgemm (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_blas_dgemm=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_blas_dgemm=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_blas_dgemm" >&5 $as_echo "$ac_cv_lib_gsl_gsl_blas_dgemm" >&6; } if test "x$ac_cv_lib_gsl_gsl_blas_dgemm" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_blas_dgemv is declared" >&5 $as_echo_n "checking whether gsl_blas_dgemv is declared... " >&6; } if test "${ac_cv_have_decl_gsl_blas_dgemv+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_blas_dgemv (void) gsl_blas_dgemv; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_blas_dgemv=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_blas_dgemv=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_blas_dgemv" >&5 $as_echo "$ac_cv_have_decl_gsl_blas_dgemv" >&6; } if test "x$ac_cv_have_decl_gsl_blas_dgemv" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_blas_dgemv in -lgsl" >&5 $as_echo_n "checking for gsl_blas_dgemv in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_blas_dgemv+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_blas_dgemv (); int main () { return gsl_blas_dgemv (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_blas_dgemv=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_blas_dgemv=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_blas_dgemv" >&5 $as_echo "$ac_cv_lib_gsl_gsl_blas_dgemv" >&6; } if test "x$ac_cv_lib_gsl_gsl_blas_dgemv" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_blas_zaxpy is declared" >&5 $as_echo_n "checking whether gsl_blas_zaxpy is declared... " >&6; } if test "${ac_cv_have_decl_gsl_blas_zaxpy+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_blas_zaxpy (void) gsl_blas_zaxpy; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_blas_zaxpy=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_blas_zaxpy=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_blas_zaxpy" >&5 $as_echo "$ac_cv_have_decl_gsl_blas_zaxpy" >&6; } if test "x$ac_cv_have_decl_gsl_blas_zaxpy" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_blas_zaxpy in -lgsl" >&5 $as_echo_n "checking for gsl_blas_zaxpy in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_blas_zaxpy+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_blas_zaxpy (); int main () { return gsl_blas_zaxpy (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_blas_zaxpy=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_blas_zaxpy=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_blas_zaxpy" >&5 $as_echo "$ac_cv_lib_gsl_gsl_blas_zaxpy" >&6; } if test "x$ac_cv_lib_gsl_gsl_blas_zaxpy" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_blas_zdotc is declared" >&5 $as_echo_n "checking whether gsl_blas_zdotc is declared... " >&6; } if test "${ac_cv_have_decl_gsl_blas_zdotc+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_blas_zdotc (void) gsl_blas_zdotc; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_blas_zdotc=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_blas_zdotc=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_blas_zdotc" >&5 $as_echo "$ac_cv_have_decl_gsl_blas_zdotc" >&6; } if test "x$ac_cv_have_decl_gsl_blas_zdotc" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_blas_zdotc in -lgsl" >&5 $as_echo_n "checking for gsl_blas_zdotc in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_blas_zdotc+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_blas_zdotc (); int main () { return gsl_blas_zdotc (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_blas_zdotc=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_blas_zdotc=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_blas_zdotc" >&5 $as_echo "$ac_cv_lib_gsl_gsl_blas_zdotc" >&6; } if test "x$ac_cv_lib_gsl_gsl_blas_zdotc" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_blas_zdscal is declared" >&5 $as_echo_n "checking whether gsl_blas_zdscal is declared... " >&6; } if test "${ac_cv_have_decl_gsl_blas_zdscal+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_blas_zdscal (void) gsl_blas_zdscal; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_blas_zdscal=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_blas_zdscal=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_blas_zdscal" >&5 $as_echo "$ac_cv_have_decl_gsl_blas_zdscal" >&6; } if test "x$ac_cv_have_decl_gsl_blas_zdscal" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_blas_zdscal in -lgsl" >&5 $as_echo_n "checking for gsl_blas_zdscal in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_blas_zdscal+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_blas_zdscal (); int main () { return gsl_blas_zdscal (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_blas_zdscal=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_blas_zdscal=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_blas_zdscal" >&5 $as_echo "$ac_cv_lib_gsl_gsl_blas_zdscal" >&6; } if test "x$ac_cv_lib_gsl_gsl_blas_zdscal" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_blas_zgemm is declared" >&5 $as_echo_n "checking whether gsl_blas_zgemm is declared... " >&6; } if test "${ac_cv_have_decl_gsl_blas_zgemm+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_blas_zgemm (void) gsl_blas_zgemm; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_blas_zgemm=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_blas_zgemm=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_blas_zgemm" >&5 $as_echo "$ac_cv_have_decl_gsl_blas_zgemm" >&6; } if test "x$ac_cv_have_decl_gsl_blas_zgemm" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_blas_zgemm in -lgsl" >&5 $as_echo_n "checking for gsl_blas_zgemm in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_blas_zgemm+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_blas_zgemm (); int main () { return gsl_blas_zgemm (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_blas_zgemm=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_blas_zgemm=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_blas_zgemm" >&5 $as_echo "$ac_cv_lib_gsl_gsl_blas_zgemm" >&6; } if test "x$ac_cv_lib_gsl_gsl_blas_zgemm" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_blas_zgemv is declared" >&5 $as_echo_n "checking whether gsl_blas_zgemv is declared... " >&6; } if test "${ac_cv_have_decl_gsl_blas_zgemv+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_blas_zgemv (void) gsl_blas_zgemv; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_blas_zgemv=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_blas_zgemv=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_blas_zgemv" >&5 $as_echo "$ac_cv_have_decl_gsl_blas_zgemv" >&6; } if test "x$ac_cv_have_decl_gsl_blas_zgemv" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_blas_zgemv in -lgsl" >&5 $as_echo_n "checking for gsl_blas_zgemv in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_blas_zgemv+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_blas_zgemv (); int main () { return gsl_blas_zgemv (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_blas_zgemv=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_blas_zgemv=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_blas_zgemv" >&5 $as_echo "$ac_cv_lib_gsl_gsl_blas_zgemv" >&6; } if test "x$ac_cv_lib_gsl_gsl_blas_zgemv" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_blas_zscal is declared" >&5 $as_echo_n "checking whether gsl_blas_zscal is declared... " >&6; } if test "${ac_cv_have_decl_gsl_blas_zscal+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_blas_zscal (void) gsl_blas_zscal; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_blas_zscal=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_blas_zscal=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_blas_zscal" >&5 $as_echo "$ac_cv_have_decl_gsl_blas_zscal" >&6; } if test "x$ac_cv_have_decl_gsl_blas_zscal" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_blas_zscal in -lgsl" >&5 $as_echo_n "checking for gsl_blas_zscal in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_blas_zscal+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_blas_zscal (); int main () { return gsl_blas_zscal (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_blas_zscal=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_blas_zscal=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_blas_zscal" >&5 $as_echo "$ac_cv_lib_gsl_gsl_blas_zscal" >&6; } if test "x$ac_cv_lib_gsl_gsl_blas_zscal" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_complex_arccosh is declared" >&5 $as_echo_n "checking whether gsl_complex_arccosh is declared... " >&6; } if test "${ac_cv_have_decl_gsl_complex_arccosh+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_complex_arccosh (void) gsl_complex_arccosh; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_complex_arccosh=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_complex_arccosh=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_complex_arccosh" >&5 $as_echo "$ac_cv_have_decl_gsl_complex_arccosh" >&6; } if test "x$ac_cv_have_decl_gsl_complex_arccosh" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_complex_arccosh in -lgsl" >&5 $as_echo_n "checking for gsl_complex_arccosh in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_complex_arccosh+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_complex_arccosh (); int main () { return gsl_complex_arccosh (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_complex_arccosh=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_complex_arccosh=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_complex_arccosh" >&5 $as_echo "$ac_cv_lib_gsl_gsl_complex_arccosh" >&6; } if test "x$ac_cv_lib_gsl_gsl_complex_arccosh" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_complex_arcsinh is declared" >&5 $as_echo_n "checking whether gsl_complex_arcsinh is declared... " >&6; } if test "${ac_cv_have_decl_gsl_complex_arcsinh+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_complex_arcsinh (void) gsl_complex_arcsinh; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_complex_arcsinh=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_complex_arcsinh=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_complex_arcsinh" >&5 $as_echo "$ac_cv_have_decl_gsl_complex_arcsinh" >&6; } if test "x$ac_cv_have_decl_gsl_complex_arcsinh" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_complex_arcsinh in -lgsl" >&5 $as_echo_n "checking for gsl_complex_arcsinh in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_complex_arcsinh+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_complex_arcsinh (); int main () { return gsl_complex_arcsinh (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_complex_arcsinh=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_complex_arcsinh=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_complex_arcsinh" >&5 $as_echo "$ac_cv_lib_gsl_gsl_complex_arcsinh" >&6; } if test "x$ac_cv_lib_gsl_gsl_complex_arcsinh" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_complex_arctanh is declared" >&5 $as_echo_n "checking whether gsl_complex_arctanh is declared... " >&6; } if test "${ac_cv_have_decl_gsl_complex_arctanh+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_complex_arctanh (void) gsl_complex_arctanh; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_complex_arctanh=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_complex_arctanh=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_complex_arctanh" >&5 $as_echo "$ac_cv_have_decl_gsl_complex_arctanh" >&6; } if test "x$ac_cv_have_decl_gsl_complex_arctanh" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_complex_arctanh in -lgsl" >&5 $as_echo_n "checking for gsl_complex_arctanh in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_complex_arctanh+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_complex_arctanh (); int main () { return gsl_complex_arctanh (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_complex_arctanh=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_complex_arctanh=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_complex_arctanh" >&5 $as_echo "$ac_cv_lib_gsl_gsl_complex_arctanh" >&6; } if test "x$ac_cv_lib_gsl_gsl_complex_arctanh" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_complex_cosh is declared" >&5 $as_echo_n "checking whether gsl_complex_cosh is declared... " >&6; } if test "${ac_cv_have_decl_gsl_complex_cosh+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_complex_cosh (void) gsl_complex_cosh; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_complex_cosh=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_complex_cosh=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_complex_cosh" >&5 $as_echo "$ac_cv_have_decl_gsl_complex_cosh" >&6; } if test "x$ac_cv_have_decl_gsl_complex_cosh" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_complex_cosh in -lgsl" >&5 $as_echo_n "checking for gsl_complex_cosh in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_complex_cosh+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_complex_cosh (); int main () { return gsl_complex_cosh (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_complex_cosh=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_complex_cosh=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_complex_cosh" >&5 $as_echo "$ac_cv_lib_gsl_gsl_complex_cosh" >&6; } if test "x$ac_cv_lib_gsl_gsl_complex_cosh" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_complex_inverse is declared" >&5 $as_echo_n "checking whether gsl_complex_inverse is declared... " >&6; } if test "${ac_cv_have_decl_gsl_complex_inverse+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_complex_inverse (void) gsl_complex_inverse; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_complex_inverse=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_complex_inverse=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_complex_inverse" >&5 $as_echo "$ac_cv_have_decl_gsl_complex_inverse" >&6; } if test "x$ac_cv_have_decl_gsl_complex_inverse" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_complex_inverse in -lgsl" >&5 $as_echo_n "checking for gsl_complex_inverse in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_complex_inverse+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_complex_inverse (); int main () { return gsl_complex_inverse (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_complex_inverse=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_complex_inverse=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_complex_inverse" >&5 $as_echo "$ac_cv_lib_gsl_gsl_complex_inverse" >&6; } if test "x$ac_cv_lib_gsl_gsl_complex_inverse" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_complex_mul is declared" >&5 $as_echo_n "checking whether gsl_complex_mul is declared... " >&6; } if test "${ac_cv_have_decl_gsl_complex_mul+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_complex_mul (void) gsl_complex_mul; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_complex_mul=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_complex_mul=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_complex_mul" >&5 $as_echo "$ac_cv_have_decl_gsl_complex_mul" >&6; } if test "x$ac_cv_have_decl_gsl_complex_mul" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_complex_mul in -lgsl" >&5 $as_echo_n "checking for gsl_complex_mul in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_complex_mul+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_complex_mul (); int main () { return gsl_complex_mul (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_complex_mul=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_complex_mul=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_complex_mul" >&5 $as_echo "$ac_cv_lib_gsl_gsl_complex_mul" >&6; } if test "x$ac_cv_lib_gsl_gsl_complex_mul" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_complex_sinh is declared" >&5 $as_echo_n "checking whether gsl_complex_sinh is declared... " >&6; } if test "${ac_cv_have_decl_gsl_complex_sinh+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_complex_sinh (void) gsl_complex_sinh; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_complex_sinh=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_complex_sinh=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_complex_sinh" >&5 $as_echo "$ac_cv_have_decl_gsl_complex_sinh" >&6; } if test "x$ac_cv_have_decl_gsl_complex_sinh" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_complex_sinh in -lgsl" >&5 $as_echo_n "checking for gsl_complex_sinh in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_complex_sinh+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_complex_sinh (); int main () { return gsl_complex_sinh (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_complex_sinh=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_complex_sinh=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_complex_sinh" >&5 $as_echo "$ac_cv_lib_gsl_gsl_complex_sinh" >&6; } if test "x$ac_cv_lib_gsl_gsl_complex_sinh" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_complex_tanh is declared" >&5 $as_echo_n "checking whether gsl_complex_tanh is declared... " >&6; } if test "${ac_cv_have_decl_gsl_complex_tanh+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_complex_tanh (void) gsl_complex_tanh; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_complex_tanh=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_complex_tanh=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_complex_tanh" >&5 $as_echo "$ac_cv_have_decl_gsl_complex_tanh" >&6; } if test "x$ac_cv_have_decl_gsl_complex_tanh" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_complex_tanh in -lgsl" >&5 $as_echo_n "checking for gsl_complex_tanh in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_complex_tanh+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_complex_tanh (); int main () { return gsl_complex_tanh (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_complex_tanh=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_complex_tanh=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_complex_tanh" >&5 $as_echo "$ac_cv_lib_gsl_gsl_complex_tanh" >&6; } if test "x$ac_cv_lib_gsl_gsl_complex_tanh" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_fft_complex_backward is declared" >&5 $as_echo_n "checking whether gsl_fft_complex_backward is declared... " >&6; } if test "${ac_cv_have_decl_gsl_fft_complex_backward+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_fft_complex_backward (void) gsl_fft_complex_backward; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_fft_complex_backward=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_fft_complex_backward=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_fft_complex_backward" >&5 $as_echo "$ac_cv_have_decl_gsl_fft_complex_backward" >&6; } if test "x$ac_cv_have_decl_gsl_fft_complex_backward" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_fft_complex_backward in -lgsl" >&5 $as_echo_n "checking for gsl_fft_complex_backward in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_fft_complex_backward+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_fft_complex_backward (); int main () { return gsl_fft_complex_backward (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_fft_complex_backward=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_fft_complex_backward=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_fft_complex_backward" >&5 $as_echo "$ac_cv_lib_gsl_gsl_fft_complex_backward" >&6; } if test "x$ac_cv_lib_gsl_gsl_fft_complex_backward" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_fft_complex_forward is declared" >&5 $as_echo_n "checking whether gsl_fft_complex_forward is declared... " >&6; } if test "${ac_cv_have_decl_gsl_fft_complex_forward+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_fft_complex_forward (void) gsl_fft_complex_forward; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_fft_complex_forward=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_fft_complex_forward=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_fft_complex_forward" >&5 $as_echo "$ac_cv_have_decl_gsl_fft_complex_forward" >&6; } if test "x$ac_cv_have_decl_gsl_fft_complex_forward" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_fft_complex_forward in -lgsl" >&5 $as_echo_n "checking for gsl_fft_complex_forward in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_fft_complex_forward+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_fft_complex_forward (); int main () { return gsl_fft_complex_forward (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_fft_complex_forward=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_fft_complex_forward=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_fft_complex_forward" >&5 $as_echo "$ac_cv_lib_gsl_gsl_fft_complex_forward" >&6; } if test "x$ac_cv_lib_gsl_gsl_fft_complex_forward" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_fft_complex_inverse is declared" >&5 $as_echo_n "checking whether gsl_fft_complex_inverse is declared... " >&6; } if test "${ac_cv_have_decl_gsl_fft_complex_inverse+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_fft_complex_inverse (void) gsl_fft_complex_inverse; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_fft_complex_inverse=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_fft_complex_inverse=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_fft_complex_inverse" >&5 $as_echo "$ac_cv_have_decl_gsl_fft_complex_inverse" >&6; } if test "x$ac_cv_have_decl_gsl_fft_complex_inverse" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_fft_complex_inverse in -lgsl" >&5 $as_echo_n "checking for gsl_fft_complex_inverse in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_fft_complex_inverse+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_fft_complex_inverse (); int main () { return gsl_fft_complex_inverse (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_fft_complex_inverse=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_fft_complex_inverse=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_fft_complex_inverse" >&5 $as_echo "$ac_cv_lib_gsl_gsl_fft_complex_inverse" >&6; } if test "x$ac_cv_lib_gsl_gsl_fft_complex_inverse" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_fft_complex_wavetable_alloc is declared" >&5 $as_echo_n "checking whether gsl_fft_complex_wavetable_alloc is declared... " >&6; } if test "${ac_cv_have_decl_gsl_fft_complex_wavetable_alloc+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_fft_complex_wavetable_alloc (void) gsl_fft_complex_wavetable_alloc; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_fft_complex_wavetable_alloc=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_fft_complex_wavetable_alloc=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_fft_complex_wavetable_alloc" >&5 $as_echo "$ac_cv_have_decl_gsl_fft_complex_wavetable_alloc" >&6; } if test "x$ac_cv_have_decl_gsl_fft_complex_wavetable_alloc" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_fft_complex_wavetable_alloc in -lgsl" >&5 $as_echo_n "checking for gsl_fft_complex_wavetable_alloc in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_fft_complex_wavetable_alloc+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_fft_complex_wavetable_alloc (); int main () { return gsl_fft_complex_wavetable_alloc (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_fft_complex_wavetable_alloc=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_fft_complex_wavetable_alloc=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_fft_complex_wavetable_alloc" >&5 $as_echo "$ac_cv_lib_gsl_gsl_fft_complex_wavetable_alloc" >&6; } if test "x$ac_cv_lib_gsl_gsl_fft_complex_wavetable_alloc" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_fft_complex_wavetable_free is declared" >&5 $as_echo_n "checking whether gsl_fft_complex_wavetable_free is declared... " >&6; } if test "${ac_cv_have_decl_gsl_fft_complex_wavetable_free+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_fft_complex_wavetable_free (void) gsl_fft_complex_wavetable_free; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_fft_complex_wavetable_free=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_fft_complex_wavetable_free=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_fft_complex_wavetable_free" >&5 $as_echo "$ac_cv_have_decl_gsl_fft_complex_wavetable_free" >&6; } if test "x$ac_cv_have_decl_gsl_fft_complex_wavetable_free" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_fft_complex_wavetable_free in -lgsl" >&5 $as_echo_n "checking for gsl_fft_complex_wavetable_free in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_fft_complex_wavetable_free+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_fft_complex_wavetable_free (); int main () { return gsl_fft_complex_wavetable_free (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_fft_complex_wavetable_free=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_fft_complex_wavetable_free=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_fft_complex_wavetable_free" >&5 $as_echo "$ac_cv_lib_gsl_gsl_fft_complex_wavetable_free" >&6; } if test "x$ac_cv_lib_gsl_gsl_fft_complex_wavetable_free" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_fft_complex_workspace_alloc is declared" >&5 $as_echo_n "checking whether gsl_fft_complex_workspace_alloc is declared... " >&6; } if test "${ac_cv_have_decl_gsl_fft_complex_workspace_alloc+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_fft_complex_workspace_alloc (void) gsl_fft_complex_workspace_alloc; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_fft_complex_workspace_alloc=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_fft_complex_workspace_alloc=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_fft_complex_workspace_alloc" >&5 $as_echo "$ac_cv_have_decl_gsl_fft_complex_workspace_alloc" >&6; } if test "x$ac_cv_have_decl_gsl_fft_complex_workspace_alloc" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_fft_complex_workspace_alloc in -lgsl" >&5 $as_echo_n "checking for gsl_fft_complex_workspace_alloc in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_fft_complex_workspace_alloc+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_fft_complex_workspace_alloc (); int main () { return gsl_fft_complex_workspace_alloc (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_fft_complex_workspace_alloc=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_fft_complex_workspace_alloc=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_fft_complex_workspace_alloc" >&5 $as_echo "$ac_cv_lib_gsl_gsl_fft_complex_workspace_alloc" >&6; } if test "x$ac_cv_lib_gsl_gsl_fft_complex_workspace_alloc" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_fft_complex_workspace_free is declared" >&5 $as_echo_n "checking whether gsl_fft_complex_workspace_free is declared... " >&6; } if test "${ac_cv_have_decl_gsl_fft_complex_workspace_free+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_fft_complex_workspace_free (void) gsl_fft_complex_workspace_free; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_fft_complex_workspace_free=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_fft_complex_workspace_free=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_fft_complex_workspace_free" >&5 $as_echo "$ac_cv_have_decl_gsl_fft_complex_workspace_free" >&6; } if test "x$ac_cv_have_decl_gsl_fft_complex_workspace_free" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_fft_complex_workspace_free in -lgsl" >&5 $as_echo_n "checking for gsl_fft_complex_workspace_free in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_fft_complex_workspace_free+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_fft_complex_workspace_free (); int main () { return gsl_fft_complex_workspace_free (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_fft_complex_workspace_free=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_fft_complex_workspace_free=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_fft_complex_workspace_free" >&5 $as_echo "$ac_cv_lib_gsl_gsl_fft_complex_workspace_free" >&6; } if test "x$ac_cv_lib_gsl_gsl_fft_complex_workspace_free" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_integration_qagiu is declared" >&5 $as_echo_n "checking whether gsl_integration_qagiu is declared... " >&6; } if test "${ac_cv_have_decl_gsl_integration_qagiu+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_integration_qagiu (void) gsl_integration_qagiu; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_integration_qagiu=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_integration_qagiu=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_integration_qagiu" >&5 $as_echo "$ac_cv_have_decl_gsl_integration_qagiu" >&6; } if test "x$ac_cv_have_decl_gsl_integration_qagiu" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_integration_qagiu in -lgsl" >&5 $as_echo_n "checking for gsl_integration_qagiu in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_integration_qagiu+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_integration_qagiu (); int main () { return gsl_integration_qagiu (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_integration_qagiu=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_integration_qagiu=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_integration_qagiu" >&5 $as_echo "$ac_cv_lib_gsl_gsl_integration_qagiu" >&6; } if test "x$ac_cv_lib_gsl_gsl_integration_qagiu" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_integration_workspace_alloc is declared" >&5 $as_echo_n "checking whether gsl_integration_workspace_alloc is declared... " >&6; } if test "${ac_cv_have_decl_gsl_integration_workspace_alloc+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_integration_workspace_alloc (void) gsl_integration_workspace_alloc; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_integration_workspace_alloc=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_integration_workspace_alloc=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_integration_workspace_alloc" >&5 $as_echo "$ac_cv_have_decl_gsl_integration_workspace_alloc" >&6; } if test "x$ac_cv_have_decl_gsl_integration_workspace_alloc" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_integration_workspace_alloc in -lgsl" >&5 $as_echo_n "checking for gsl_integration_workspace_alloc in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_integration_workspace_alloc+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_integration_workspace_alloc (); int main () { return gsl_integration_workspace_alloc (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_integration_workspace_alloc=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_integration_workspace_alloc=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_integration_workspace_alloc" >&5 $as_echo "$ac_cv_lib_gsl_gsl_integration_workspace_alloc" >&6; } if test "x$ac_cv_lib_gsl_gsl_integration_workspace_alloc" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_integration_workspace_free is declared" >&5 $as_echo_n "checking whether gsl_integration_workspace_free is declared... " >&6; } if test "${ac_cv_have_decl_gsl_integration_workspace_free+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_integration_workspace_free (void) gsl_integration_workspace_free; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_integration_workspace_free=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_integration_workspace_free=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_integration_workspace_free" >&5 $as_echo "$ac_cv_have_decl_gsl_integration_workspace_free" >&6; } if test "x$ac_cv_have_decl_gsl_integration_workspace_free" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_integration_workspace_free in -lgsl" >&5 $as_echo_n "checking for gsl_integration_workspace_free in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_integration_workspace_free+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_integration_workspace_free (); int main () { return gsl_integration_workspace_free (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_integration_workspace_free=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_integration_workspace_free=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_integration_workspace_free" >&5 $as_echo "$ac_cv_lib_gsl_gsl_integration_workspace_free" >&6; } if test "x$ac_cv_lib_gsl_gsl_integration_workspace_free" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_linalg_LU_decomp is declared" >&5 $as_echo_n "checking whether gsl_linalg_LU_decomp is declared... " >&6; } if test "${ac_cv_have_decl_gsl_linalg_LU_decomp+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_linalg_LU_decomp (void) gsl_linalg_LU_decomp; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_linalg_LU_decomp=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_linalg_LU_decomp=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_linalg_LU_decomp" >&5 $as_echo "$ac_cv_have_decl_gsl_linalg_LU_decomp" >&6; } if test "x$ac_cv_have_decl_gsl_linalg_LU_decomp" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_linalg_LU_decomp in -lgsl" >&5 $as_echo_n "checking for gsl_linalg_LU_decomp in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_linalg_LU_decomp+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_linalg_LU_decomp (); int main () { return gsl_linalg_LU_decomp (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_linalg_LU_decomp=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_linalg_LU_decomp=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_linalg_LU_decomp" >&5 $as_echo "$ac_cv_lib_gsl_gsl_linalg_LU_decomp" >&6; } if test "x$ac_cv_lib_gsl_gsl_linalg_LU_decomp" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_linalg_LU_det is declared" >&5 $as_echo_n "checking whether gsl_linalg_LU_det is declared... " >&6; } if test "${ac_cv_have_decl_gsl_linalg_LU_det+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_linalg_LU_det (void) gsl_linalg_LU_det; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_linalg_LU_det=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_linalg_LU_det=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_linalg_LU_det" >&5 $as_echo "$ac_cv_have_decl_gsl_linalg_LU_det" >&6; } if test "x$ac_cv_have_decl_gsl_linalg_LU_det" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_linalg_LU_det in -lgsl" >&5 $as_echo_n "checking for gsl_linalg_LU_det in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_linalg_LU_det+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_linalg_LU_det (); int main () { return gsl_linalg_LU_det (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_linalg_LU_det=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_linalg_LU_det=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_linalg_LU_det" >&5 $as_echo "$ac_cv_lib_gsl_gsl_linalg_LU_det" >&6; } if test "x$ac_cv_lib_gsl_gsl_linalg_LU_det" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_linalg_LU_invert is declared" >&5 $as_echo_n "checking whether gsl_linalg_LU_invert is declared... " >&6; } if test "${ac_cv_have_decl_gsl_linalg_LU_invert+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_linalg_LU_invert (void) gsl_linalg_LU_invert; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_linalg_LU_invert=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_linalg_LU_invert=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_linalg_LU_invert" >&5 $as_echo "$ac_cv_have_decl_gsl_linalg_LU_invert" >&6; } if test "x$ac_cv_have_decl_gsl_linalg_LU_invert" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_linalg_LU_invert in -lgsl" >&5 $as_echo_n "checking for gsl_linalg_LU_invert in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_linalg_LU_invert+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_linalg_LU_invert (); int main () { return gsl_linalg_LU_invert (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_linalg_LU_invert=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_linalg_LU_invert=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_linalg_LU_invert" >&5 $as_echo "$ac_cv_lib_gsl_gsl_linalg_LU_invert" >&6; } if test "x$ac_cv_lib_gsl_gsl_linalg_LU_invert" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_linalg_LU_refine is declared" >&5 $as_echo_n "checking whether gsl_linalg_LU_refine is declared... " >&6; } if test "${ac_cv_have_decl_gsl_linalg_LU_refine+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_linalg_LU_refine (void) gsl_linalg_LU_refine; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_linalg_LU_refine=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_linalg_LU_refine=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_linalg_LU_refine" >&5 $as_echo "$ac_cv_have_decl_gsl_linalg_LU_refine" >&6; } if test "x$ac_cv_have_decl_gsl_linalg_LU_refine" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_linalg_LU_refine in -lgsl" >&5 $as_echo_n "checking for gsl_linalg_LU_refine in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_linalg_LU_refine+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_linalg_LU_refine (); int main () { return gsl_linalg_LU_refine (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_linalg_LU_refine=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_linalg_LU_refine=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_linalg_LU_refine" >&5 $as_echo "$ac_cv_lib_gsl_gsl_linalg_LU_refine" >&6; } if test "x$ac_cv_lib_gsl_gsl_linalg_LU_refine" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_linalg_LU_solve is declared" >&5 $as_echo_n "checking whether gsl_linalg_LU_solve is declared... " >&6; } if test "${ac_cv_have_decl_gsl_linalg_LU_solve+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_linalg_LU_solve (void) gsl_linalg_LU_solve; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_linalg_LU_solve=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_linalg_LU_solve=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_linalg_LU_solve" >&5 $as_echo "$ac_cv_have_decl_gsl_linalg_LU_solve" >&6; } if test "x$ac_cv_have_decl_gsl_linalg_LU_solve" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_linalg_LU_solve in -lgsl" >&5 $as_echo_n "checking for gsl_linalg_LU_solve in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_linalg_LU_solve+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_linalg_LU_solve (); int main () { return gsl_linalg_LU_solve (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_linalg_LU_solve=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_linalg_LU_solve=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_linalg_LU_solve" >&5 $as_echo "$ac_cv_lib_gsl_gsl_linalg_LU_solve" >&6; } if test "x$ac_cv_lib_gsl_gsl_linalg_LU_solve" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_linalg_QR_decomp is declared" >&5 $as_echo_n "checking whether gsl_linalg_QR_decomp is declared... " >&6; } if test "${ac_cv_have_decl_gsl_linalg_QR_decomp+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_linalg_QR_decomp (void) gsl_linalg_QR_decomp; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_linalg_QR_decomp=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_linalg_QR_decomp=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_linalg_QR_decomp" >&5 $as_echo "$ac_cv_have_decl_gsl_linalg_QR_decomp" >&6; } if test "x$ac_cv_have_decl_gsl_linalg_QR_decomp" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_linalg_QR_decomp in -lgsl" >&5 $as_echo_n "checking for gsl_linalg_QR_decomp in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_linalg_QR_decomp+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_linalg_QR_decomp (); int main () { return gsl_linalg_QR_decomp (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_linalg_QR_decomp=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_linalg_QR_decomp=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_linalg_QR_decomp" >&5 $as_echo "$ac_cv_lib_gsl_gsl_linalg_QR_decomp" >&6; } if test "x$ac_cv_lib_gsl_gsl_linalg_QR_decomp" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_linalg_QR_lssolve is declared" >&5 $as_echo_n "checking whether gsl_linalg_QR_lssolve is declared... " >&6; } if test "${ac_cv_have_decl_gsl_linalg_QR_lssolve+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_linalg_QR_lssolve (void) gsl_linalg_QR_lssolve; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_linalg_QR_lssolve=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_linalg_QR_lssolve=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_linalg_QR_lssolve" >&5 $as_echo "$ac_cv_have_decl_gsl_linalg_QR_lssolve" >&6; } if test "x$ac_cv_have_decl_gsl_linalg_QR_lssolve" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_linalg_QR_lssolve in -lgsl" >&5 $as_echo_n "checking for gsl_linalg_QR_lssolve in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_linalg_QR_lssolve+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_linalg_QR_lssolve (); int main () { return gsl_linalg_QR_lssolve (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_linalg_QR_lssolve=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_linalg_QR_lssolve=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_linalg_QR_lssolve" >&5 $as_echo "$ac_cv_lib_gsl_gsl_linalg_QR_lssolve" >&6; } if test "x$ac_cv_lib_gsl_gsl_linalg_QR_lssolve" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_linalg_QR_solve is declared" >&5 $as_echo_n "checking whether gsl_linalg_QR_solve is declared... " >&6; } if test "${ac_cv_have_decl_gsl_linalg_QR_solve+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_linalg_QR_solve (void) gsl_linalg_QR_solve; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_linalg_QR_solve=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_linalg_QR_solve=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_linalg_QR_solve" >&5 $as_echo "$ac_cv_have_decl_gsl_linalg_QR_solve" >&6; } if test "x$ac_cv_have_decl_gsl_linalg_QR_solve" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_linalg_QR_solve in -lgsl" >&5 $as_echo_n "checking for gsl_linalg_QR_solve in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_linalg_QR_solve+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_linalg_QR_solve (); int main () { return gsl_linalg_QR_solve (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_linalg_QR_solve=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_linalg_QR_solve=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_linalg_QR_solve" >&5 $as_echo "$ac_cv_lib_gsl_gsl_linalg_QR_solve" >&6; } if test "x$ac_cv_lib_gsl_gsl_linalg_QR_solve" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_linalg_SV_decomp is declared" >&5 $as_echo_n "checking whether gsl_linalg_SV_decomp is declared... " >&6; } if test "${ac_cv_have_decl_gsl_linalg_SV_decomp+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_linalg_SV_decomp (void) gsl_linalg_SV_decomp; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_linalg_SV_decomp=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_linalg_SV_decomp=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_linalg_SV_decomp" >&5 $as_echo "$ac_cv_have_decl_gsl_linalg_SV_decomp" >&6; } if test "x$ac_cv_have_decl_gsl_linalg_SV_decomp" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_linalg_SV_decomp in -lgsl" >&5 $as_echo_n "checking for gsl_linalg_SV_decomp in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_linalg_SV_decomp+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_linalg_SV_decomp (); int main () { return gsl_linalg_SV_decomp (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_linalg_SV_decomp=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_linalg_SV_decomp=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_linalg_SV_decomp" >&5 $as_echo "$ac_cv_lib_gsl_gsl_linalg_SV_decomp" >&6; } if test "x$ac_cv_lib_gsl_gsl_linalg_SV_decomp" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_linalg_SV_solve is declared" >&5 $as_echo_n "checking whether gsl_linalg_SV_solve is declared... " >&6; } if test "${ac_cv_have_decl_gsl_linalg_SV_solve+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_linalg_SV_solve (void) gsl_linalg_SV_solve; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_linalg_SV_solve=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_linalg_SV_solve=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_linalg_SV_solve" >&5 $as_echo "$ac_cv_have_decl_gsl_linalg_SV_solve" >&6; } if test "x$ac_cv_have_decl_gsl_linalg_SV_solve" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_linalg_SV_solve in -lgsl" >&5 $as_echo_n "checking for gsl_linalg_SV_solve in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_linalg_SV_solve+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_linalg_SV_solve (); int main () { return gsl_linalg_SV_solve (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_linalg_SV_solve=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_linalg_SV_solve=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_linalg_SV_solve" >&5 $as_echo "$ac_cv_lib_gsl_gsl_linalg_SV_solve" >&6; } if test "x$ac_cv_lib_gsl_gsl_linalg_SV_solve" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_linalg_cholesky_decomp is declared" >&5 $as_echo_n "checking whether gsl_linalg_cholesky_decomp is declared... " >&6; } if test "${ac_cv_have_decl_gsl_linalg_cholesky_decomp+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_linalg_cholesky_decomp (void) gsl_linalg_cholesky_decomp; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_linalg_cholesky_decomp=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_linalg_cholesky_decomp=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_linalg_cholesky_decomp" >&5 $as_echo "$ac_cv_have_decl_gsl_linalg_cholesky_decomp" >&6; } if test "x$ac_cv_have_decl_gsl_linalg_cholesky_decomp" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_linalg_cholesky_decomp in -lgsl" >&5 $as_echo_n "checking for gsl_linalg_cholesky_decomp in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_linalg_cholesky_decomp+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_linalg_cholesky_decomp (); int main () { return gsl_linalg_cholesky_decomp (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_linalg_cholesky_decomp=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_linalg_cholesky_decomp=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_linalg_cholesky_decomp" >&5 $as_echo "$ac_cv_lib_gsl_gsl_linalg_cholesky_decomp" >&6; } if test "x$ac_cv_lib_gsl_gsl_linalg_cholesky_decomp" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_linalg_cholesky_solve is declared" >&5 $as_echo_n "checking whether gsl_linalg_cholesky_solve is declared... " >&6; } if test "${ac_cv_have_decl_gsl_linalg_cholesky_solve+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_linalg_cholesky_solve (void) gsl_linalg_cholesky_solve; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_linalg_cholesky_solve=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_linalg_cholesky_solve=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_linalg_cholesky_solve" >&5 $as_echo "$ac_cv_have_decl_gsl_linalg_cholesky_solve" >&6; } if test "x$ac_cv_have_decl_gsl_linalg_cholesky_solve" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_linalg_cholesky_solve in -lgsl" >&5 $as_echo_n "checking for gsl_linalg_cholesky_solve in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_linalg_cholesky_solve+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_linalg_cholesky_solve (); int main () { return gsl_linalg_cholesky_solve (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_linalg_cholesky_solve=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_linalg_cholesky_solve=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_linalg_cholesky_solve" >&5 $as_echo "$ac_cv_lib_gsl_gsl_linalg_cholesky_solve" >&6; } if test "x$ac_cv_lib_gsl_gsl_linalg_cholesky_solve" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_linalg_complex_LU_decomp is declared" >&5 $as_echo_n "checking whether gsl_linalg_complex_LU_decomp is declared... " >&6; } if test "${ac_cv_have_decl_gsl_linalg_complex_LU_decomp+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_linalg_complex_LU_decomp (void) gsl_linalg_complex_LU_decomp; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_linalg_complex_LU_decomp=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_linalg_complex_LU_decomp=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_linalg_complex_LU_decomp" >&5 $as_echo "$ac_cv_have_decl_gsl_linalg_complex_LU_decomp" >&6; } if test "x$ac_cv_have_decl_gsl_linalg_complex_LU_decomp" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_linalg_complex_LU_decomp in -lgsl" >&5 $as_echo_n "checking for gsl_linalg_complex_LU_decomp in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_linalg_complex_LU_decomp+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_linalg_complex_LU_decomp (); int main () { return gsl_linalg_complex_LU_decomp (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_linalg_complex_LU_decomp=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_linalg_complex_LU_decomp=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_linalg_complex_LU_decomp" >&5 $as_echo "$ac_cv_lib_gsl_gsl_linalg_complex_LU_decomp" >&6; } if test "x$ac_cv_lib_gsl_gsl_linalg_complex_LU_decomp" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_linalg_complex_LU_det is declared" >&5 $as_echo_n "checking whether gsl_linalg_complex_LU_det is declared... " >&6; } if test "${ac_cv_have_decl_gsl_linalg_complex_LU_det+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_linalg_complex_LU_det (void) gsl_linalg_complex_LU_det; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_linalg_complex_LU_det=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_linalg_complex_LU_det=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_linalg_complex_LU_det" >&5 $as_echo "$ac_cv_have_decl_gsl_linalg_complex_LU_det" >&6; } if test "x$ac_cv_have_decl_gsl_linalg_complex_LU_det" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_linalg_complex_LU_det in -lgsl" >&5 $as_echo_n "checking for gsl_linalg_complex_LU_det in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_linalg_complex_LU_det+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_linalg_complex_LU_det (); int main () { return gsl_linalg_complex_LU_det (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_linalg_complex_LU_det=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_linalg_complex_LU_det=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_linalg_complex_LU_det" >&5 $as_echo "$ac_cv_lib_gsl_gsl_linalg_complex_LU_det" >&6; } if test "x$ac_cv_lib_gsl_gsl_linalg_complex_LU_det" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_linalg_complex_LU_invert is declared" >&5 $as_echo_n "checking whether gsl_linalg_complex_LU_invert is declared... " >&6; } if test "${ac_cv_have_decl_gsl_linalg_complex_LU_invert+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_linalg_complex_LU_invert (void) gsl_linalg_complex_LU_invert; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_linalg_complex_LU_invert=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_linalg_complex_LU_invert=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_linalg_complex_LU_invert" >&5 $as_echo "$ac_cv_have_decl_gsl_linalg_complex_LU_invert" >&6; } if test "x$ac_cv_have_decl_gsl_linalg_complex_LU_invert" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_linalg_complex_LU_invert in -lgsl" >&5 $as_echo_n "checking for gsl_linalg_complex_LU_invert in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_linalg_complex_LU_invert+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_linalg_complex_LU_invert (); int main () { return gsl_linalg_complex_LU_invert (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_linalg_complex_LU_invert=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_linalg_complex_LU_invert=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_linalg_complex_LU_invert" >&5 $as_echo "$ac_cv_lib_gsl_gsl_linalg_complex_LU_invert" >&6; } if test "x$ac_cv_lib_gsl_gsl_linalg_complex_LU_invert" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_linalg_complex_LU_refine is declared" >&5 $as_echo_n "checking whether gsl_linalg_complex_LU_refine is declared... " >&6; } if test "${ac_cv_have_decl_gsl_linalg_complex_LU_refine+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_linalg_complex_LU_refine (void) gsl_linalg_complex_LU_refine; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_linalg_complex_LU_refine=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_linalg_complex_LU_refine=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_linalg_complex_LU_refine" >&5 $as_echo "$ac_cv_have_decl_gsl_linalg_complex_LU_refine" >&6; } if test "x$ac_cv_have_decl_gsl_linalg_complex_LU_refine" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_linalg_complex_LU_refine in -lgsl" >&5 $as_echo_n "checking for gsl_linalg_complex_LU_refine in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_linalg_complex_LU_refine+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_linalg_complex_LU_refine (); int main () { return gsl_linalg_complex_LU_refine (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_linalg_complex_LU_refine=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_linalg_complex_LU_refine=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_linalg_complex_LU_refine" >&5 $as_echo "$ac_cv_lib_gsl_gsl_linalg_complex_LU_refine" >&6; } if test "x$ac_cv_lib_gsl_gsl_linalg_complex_LU_refine" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_linalg_complex_LU_solve is declared" >&5 $as_echo_n "checking whether gsl_linalg_complex_LU_solve is declared... " >&6; } if test "${ac_cv_have_decl_gsl_linalg_complex_LU_solve+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_linalg_complex_LU_solve (void) gsl_linalg_complex_LU_solve; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_linalg_complex_LU_solve=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_linalg_complex_LU_solve=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_linalg_complex_LU_solve" >&5 $as_echo "$ac_cv_have_decl_gsl_linalg_complex_LU_solve" >&6; } if test "x$ac_cv_have_decl_gsl_linalg_complex_LU_solve" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_linalg_complex_LU_solve in -lgsl" >&5 $as_echo_n "checking for gsl_linalg_complex_LU_solve in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_linalg_complex_LU_solve+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_linalg_complex_LU_solve (); int main () { return gsl_linalg_complex_LU_solve (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_linalg_complex_LU_solve=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_linalg_complex_LU_solve=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_linalg_complex_LU_solve" >&5 $as_echo "$ac_cv_lib_gsl_gsl_linalg_complex_LU_solve" >&6; } if test "x$ac_cv_lib_gsl_gsl_linalg_complex_LU_solve" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_matrix_add is declared" >&5 $as_echo_n "checking whether gsl_matrix_add is declared... " >&6; } if test "${ac_cv_have_decl_gsl_matrix_add+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_matrix_add (void) gsl_matrix_add; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_matrix_add=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_matrix_add=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_matrix_add" >&5 $as_echo "$ac_cv_have_decl_gsl_matrix_add" >&6; } if test "x$ac_cv_have_decl_gsl_matrix_add" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_matrix_add in -lgsl" >&5 $as_echo_n "checking for gsl_matrix_add in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_matrix_add+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_matrix_add (); int main () { return gsl_matrix_add (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_matrix_add=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_matrix_add=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_matrix_add" >&5 $as_echo "$ac_cv_lib_gsl_gsl_matrix_add" >&6; } if test "x$ac_cv_lib_gsl_gsl_matrix_add" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_matrix_alloc is declared" >&5 $as_echo_n "checking whether gsl_matrix_alloc is declared... " >&6; } if test "${ac_cv_have_decl_gsl_matrix_alloc+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_matrix_alloc (void) gsl_matrix_alloc; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_matrix_alloc=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_matrix_alloc=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_matrix_alloc" >&5 $as_echo "$ac_cv_have_decl_gsl_matrix_alloc" >&6; } if test "x$ac_cv_have_decl_gsl_matrix_alloc" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_matrix_alloc in -lgsl" >&5 $as_echo_n "checking for gsl_matrix_alloc in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_matrix_alloc+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_matrix_alloc (); int main () { return gsl_matrix_alloc (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_matrix_alloc=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_matrix_alloc=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_matrix_alloc" >&5 $as_echo "$ac_cv_lib_gsl_gsl_matrix_alloc" >&6; } if test "x$ac_cv_lib_gsl_gsl_matrix_alloc" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_matrix_complex_add is declared" >&5 $as_echo_n "checking whether gsl_matrix_complex_add is declared... " >&6; } if test "${ac_cv_have_decl_gsl_matrix_complex_add+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_matrix_complex_add (void) gsl_matrix_complex_add; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_matrix_complex_add=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_matrix_complex_add=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_matrix_complex_add" >&5 $as_echo "$ac_cv_have_decl_gsl_matrix_complex_add" >&6; } if test "x$ac_cv_have_decl_gsl_matrix_complex_add" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_matrix_complex_add in -lgsl" >&5 $as_echo_n "checking for gsl_matrix_complex_add in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_matrix_complex_add+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_matrix_complex_add (); int main () { return gsl_matrix_complex_add (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_matrix_complex_add=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_matrix_complex_add=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_matrix_complex_add" >&5 $as_echo "$ac_cv_lib_gsl_gsl_matrix_complex_add" >&6; } if test "x$ac_cv_lib_gsl_gsl_matrix_complex_add" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_matrix_complex_alloc is declared" >&5 $as_echo_n "checking whether gsl_matrix_complex_alloc is declared... " >&6; } if test "${ac_cv_have_decl_gsl_matrix_complex_alloc+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_matrix_complex_alloc (void) gsl_matrix_complex_alloc; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_matrix_complex_alloc=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_matrix_complex_alloc=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_matrix_complex_alloc" >&5 $as_echo "$ac_cv_have_decl_gsl_matrix_complex_alloc" >&6; } if test "x$ac_cv_have_decl_gsl_matrix_complex_alloc" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_matrix_complex_alloc in -lgsl" >&5 $as_echo_n "checking for gsl_matrix_complex_alloc in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_matrix_complex_alloc+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_matrix_complex_alloc (); int main () { return gsl_matrix_complex_alloc (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_matrix_complex_alloc=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_matrix_complex_alloc=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_matrix_complex_alloc" >&5 $as_echo "$ac_cv_lib_gsl_gsl_matrix_complex_alloc" >&6; } if test "x$ac_cv_lib_gsl_gsl_matrix_complex_alloc" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_matrix_complex_free is declared" >&5 $as_echo_n "checking whether gsl_matrix_complex_free is declared... " >&6; } if test "${ac_cv_have_decl_gsl_matrix_complex_free+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_matrix_complex_free (void) gsl_matrix_complex_free; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_matrix_complex_free=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_matrix_complex_free=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_matrix_complex_free" >&5 $as_echo "$ac_cv_have_decl_gsl_matrix_complex_free" >&6; } if test "x$ac_cv_have_decl_gsl_matrix_complex_free" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_matrix_complex_free in -lgsl" >&5 $as_echo_n "checking for gsl_matrix_complex_free in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_matrix_complex_free+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_matrix_complex_free (); int main () { return gsl_matrix_complex_free (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_matrix_complex_free=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_matrix_complex_free=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_matrix_complex_free" >&5 $as_echo "$ac_cv_lib_gsl_gsl_matrix_complex_free" >&6; } if test "x$ac_cv_lib_gsl_gsl_matrix_complex_free" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_matrix_complex_get is declared" >&5 $as_echo_n "checking whether gsl_matrix_complex_get is declared... " >&6; } if test "${ac_cv_have_decl_gsl_matrix_complex_get+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_matrix_complex_get (void) gsl_matrix_complex_get; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_matrix_complex_get=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_matrix_complex_get=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_matrix_complex_get" >&5 $as_echo "$ac_cv_have_decl_gsl_matrix_complex_get" >&6; } if test "x$ac_cv_have_decl_gsl_matrix_complex_get" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_matrix_complex_get in -lgsl" >&5 $as_echo_n "checking for gsl_matrix_complex_get in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_matrix_complex_get+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_matrix_complex_get (); int main () { return gsl_matrix_complex_get (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_matrix_complex_get=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_matrix_complex_get=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_matrix_complex_get" >&5 $as_echo "$ac_cv_lib_gsl_gsl_matrix_complex_get" >&6; } if test "x$ac_cv_lib_gsl_gsl_matrix_complex_get" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_matrix_complex_isnull is declared" >&5 $as_echo_n "checking whether gsl_matrix_complex_isnull is declared... " >&6; } if test "${ac_cv_have_decl_gsl_matrix_complex_isnull+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_matrix_complex_isnull (void) gsl_matrix_complex_isnull; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_matrix_complex_isnull=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_matrix_complex_isnull=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_matrix_complex_isnull" >&5 $as_echo "$ac_cv_have_decl_gsl_matrix_complex_isnull" >&6; } if test "x$ac_cv_have_decl_gsl_matrix_complex_isnull" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_matrix_complex_isnull in -lgsl" >&5 $as_echo_n "checking for gsl_matrix_complex_isnull in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_matrix_complex_isnull+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_matrix_complex_isnull (); int main () { return gsl_matrix_complex_isnull (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_matrix_complex_isnull=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_matrix_complex_isnull=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_matrix_complex_isnull" >&5 $as_echo "$ac_cv_lib_gsl_gsl_matrix_complex_isnull" >&6; } if test "x$ac_cv_lib_gsl_gsl_matrix_complex_isnull" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_matrix_complex_scale is declared" >&5 $as_echo_n "checking whether gsl_matrix_complex_scale is declared... " >&6; } if test "${ac_cv_have_decl_gsl_matrix_complex_scale+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_matrix_complex_scale (void) gsl_matrix_complex_scale; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_matrix_complex_scale=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_matrix_complex_scale=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_matrix_complex_scale" >&5 $as_echo "$ac_cv_have_decl_gsl_matrix_complex_scale" >&6; } if test "x$ac_cv_have_decl_gsl_matrix_complex_scale" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_matrix_complex_scale in -lgsl" >&5 $as_echo_n "checking for gsl_matrix_complex_scale in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_matrix_complex_scale+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_matrix_complex_scale (); int main () { return gsl_matrix_complex_scale (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_matrix_complex_scale=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_matrix_complex_scale=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_matrix_complex_scale" >&5 $as_echo "$ac_cv_lib_gsl_gsl_matrix_complex_scale" >&6; } if test "x$ac_cv_lib_gsl_gsl_matrix_complex_scale" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_matrix_complex_set is declared" >&5 $as_echo_n "checking whether gsl_matrix_complex_set is declared... " >&6; } if test "${ac_cv_have_decl_gsl_matrix_complex_set+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_matrix_complex_set (void) gsl_matrix_complex_set; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_matrix_complex_set=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_matrix_complex_set=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_matrix_complex_set" >&5 $as_echo "$ac_cv_have_decl_gsl_matrix_complex_set" >&6; } if test "x$ac_cv_have_decl_gsl_matrix_complex_set" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_matrix_complex_set in -lgsl" >&5 $as_echo_n "checking for gsl_matrix_complex_set in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_matrix_complex_set+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_matrix_complex_set (); int main () { return gsl_matrix_complex_set (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_matrix_complex_set=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_matrix_complex_set=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_matrix_complex_set" >&5 $as_echo "$ac_cv_lib_gsl_gsl_matrix_complex_set" >&6; } if test "x$ac_cv_lib_gsl_gsl_matrix_complex_set" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_matrix_complex_set_zero is declared" >&5 $as_echo_n "checking whether gsl_matrix_complex_set_zero is declared... " >&6; } if test "${ac_cv_have_decl_gsl_matrix_complex_set_zero+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_matrix_complex_set_zero (void) gsl_matrix_complex_set_zero; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_matrix_complex_set_zero=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_matrix_complex_set_zero=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_matrix_complex_set_zero" >&5 $as_echo "$ac_cv_have_decl_gsl_matrix_complex_set_zero" >&6; } if test "x$ac_cv_have_decl_gsl_matrix_complex_set_zero" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_matrix_complex_set_zero in -lgsl" >&5 $as_echo_n "checking for gsl_matrix_complex_set_zero in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_matrix_complex_set_zero+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_matrix_complex_set_zero (); int main () { return gsl_matrix_complex_set_zero (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_matrix_complex_set_zero=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_matrix_complex_set_zero=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_matrix_complex_set_zero" >&5 $as_echo "$ac_cv_lib_gsl_gsl_matrix_complex_set_zero" >&6; } if test "x$ac_cv_lib_gsl_gsl_matrix_complex_set_zero" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_matrix_complex_sub is declared" >&5 $as_echo_n "checking whether gsl_matrix_complex_sub is declared... " >&6; } if test "${ac_cv_have_decl_gsl_matrix_complex_sub+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_matrix_complex_sub (void) gsl_matrix_complex_sub; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_matrix_complex_sub=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_matrix_complex_sub=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_matrix_complex_sub" >&5 $as_echo "$ac_cv_have_decl_gsl_matrix_complex_sub" >&6; } if test "x$ac_cv_have_decl_gsl_matrix_complex_sub" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_matrix_complex_sub in -lgsl" >&5 $as_echo_n "checking for gsl_matrix_complex_sub in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_matrix_complex_sub+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_matrix_complex_sub (); int main () { return gsl_matrix_complex_sub (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_matrix_complex_sub=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_matrix_complex_sub=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_matrix_complex_sub" >&5 $as_echo "$ac_cv_lib_gsl_gsl_matrix_complex_sub" >&6; } if test "x$ac_cv_lib_gsl_gsl_matrix_complex_sub" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_matrix_complex_transpose is declared" >&5 $as_echo_n "checking whether gsl_matrix_complex_transpose is declared... " >&6; } if test "${ac_cv_have_decl_gsl_matrix_complex_transpose+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_matrix_complex_transpose (void) gsl_matrix_complex_transpose; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_matrix_complex_transpose=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_matrix_complex_transpose=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_matrix_complex_transpose" >&5 $as_echo "$ac_cv_have_decl_gsl_matrix_complex_transpose" >&6; } if test "x$ac_cv_have_decl_gsl_matrix_complex_transpose" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_matrix_complex_transpose in -lgsl" >&5 $as_echo_n "checking for gsl_matrix_complex_transpose in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_matrix_complex_transpose+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_matrix_complex_transpose (); int main () { return gsl_matrix_complex_transpose (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_matrix_complex_transpose=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_matrix_complex_transpose=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_matrix_complex_transpose" >&5 $as_echo "$ac_cv_lib_gsl_gsl_matrix_complex_transpose" >&6; } if test "x$ac_cv_lib_gsl_gsl_matrix_complex_transpose" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_matrix_free is declared" >&5 $as_echo_n "checking whether gsl_matrix_free is declared... " >&6; } if test "${ac_cv_have_decl_gsl_matrix_free+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_matrix_free (void) gsl_matrix_free; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_matrix_free=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_matrix_free=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_matrix_free" >&5 $as_echo "$ac_cv_have_decl_gsl_matrix_free" >&6; } if test "x$ac_cv_have_decl_gsl_matrix_free" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_matrix_free in -lgsl" >&5 $as_echo_n "checking for gsl_matrix_free in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_matrix_free+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_matrix_free (); int main () { return gsl_matrix_free (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_matrix_free=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_matrix_free=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_matrix_free" >&5 $as_echo "$ac_cv_lib_gsl_gsl_matrix_free" >&6; } if test "x$ac_cv_lib_gsl_gsl_matrix_free" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_matrix_get is declared" >&5 $as_echo_n "checking whether gsl_matrix_get is declared... " >&6; } if test "${ac_cv_have_decl_gsl_matrix_get+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_matrix_get (void) gsl_matrix_get; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_matrix_get=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_matrix_get=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_matrix_get" >&5 $as_echo "$ac_cv_have_decl_gsl_matrix_get" >&6; } if test "x$ac_cv_have_decl_gsl_matrix_get" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_matrix_get in -lgsl" >&5 $as_echo_n "checking for gsl_matrix_get in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_matrix_get+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_matrix_get (); int main () { return gsl_matrix_get (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_matrix_get=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_matrix_get=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_matrix_get" >&5 $as_echo "$ac_cv_lib_gsl_gsl_matrix_get" >&6; } if test "x$ac_cv_lib_gsl_gsl_matrix_get" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_matrix_isnull is declared" >&5 $as_echo_n "checking whether gsl_matrix_isnull is declared... " >&6; } if test "${ac_cv_have_decl_gsl_matrix_isnull+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_matrix_isnull (void) gsl_matrix_isnull; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_matrix_isnull=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_matrix_isnull=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_matrix_isnull" >&5 $as_echo "$ac_cv_have_decl_gsl_matrix_isnull" >&6; } if test "x$ac_cv_have_decl_gsl_matrix_isnull" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_matrix_isnull in -lgsl" >&5 $as_echo_n "checking for gsl_matrix_isnull in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_matrix_isnull+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_matrix_isnull (); int main () { return gsl_matrix_isnull (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_matrix_isnull=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_matrix_isnull=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_matrix_isnull" >&5 $as_echo "$ac_cv_lib_gsl_gsl_matrix_isnull" >&6; } if test "x$ac_cv_lib_gsl_gsl_matrix_isnull" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_matrix_scale is declared" >&5 $as_echo_n "checking whether gsl_matrix_scale is declared... " >&6; } if test "${ac_cv_have_decl_gsl_matrix_scale+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_matrix_scale (void) gsl_matrix_scale; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_matrix_scale=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_matrix_scale=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_matrix_scale" >&5 $as_echo "$ac_cv_have_decl_gsl_matrix_scale" >&6; } if test "x$ac_cv_have_decl_gsl_matrix_scale" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_matrix_scale in -lgsl" >&5 $as_echo_n "checking for gsl_matrix_scale in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_matrix_scale+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_matrix_scale (); int main () { return gsl_matrix_scale (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_matrix_scale=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_matrix_scale=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_matrix_scale" >&5 $as_echo "$ac_cv_lib_gsl_gsl_matrix_scale" >&6; } if test "x$ac_cv_lib_gsl_gsl_matrix_scale" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_matrix_set is declared" >&5 $as_echo_n "checking whether gsl_matrix_set is declared... " >&6; } if test "${ac_cv_have_decl_gsl_matrix_set+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_matrix_set (void) gsl_matrix_set; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_matrix_set=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_matrix_set=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_matrix_set" >&5 $as_echo "$ac_cv_have_decl_gsl_matrix_set" >&6; } if test "x$ac_cv_have_decl_gsl_matrix_set" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_matrix_set in -lgsl" >&5 $as_echo_n "checking for gsl_matrix_set in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_matrix_set+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_matrix_set (); int main () { return gsl_matrix_set (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_matrix_set=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_matrix_set=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_matrix_set" >&5 $as_echo "$ac_cv_lib_gsl_gsl_matrix_set" >&6; } if test "x$ac_cv_lib_gsl_gsl_matrix_set" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_matrix_set_zero is declared" >&5 $as_echo_n "checking whether gsl_matrix_set_zero is declared... " >&6; } if test "${ac_cv_have_decl_gsl_matrix_set_zero+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_matrix_set_zero (void) gsl_matrix_set_zero; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_matrix_set_zero=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_matrix_set_zero=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_matrix_set_zero" >&5 $as_echo "$ac_cv_have_decl_gsl_matrix_set_zero" >&6; } if test "x$ac_cv_have_decl_gsl_matrix_set_zero" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_matrix_set_zero in -lgsl" >&5 $as_echo_n "checking for gsl_matrix_set_zero in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_matrix_set_zero+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_matrix_set_zero (); int main () { return gsl_matrix_set_zero (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_matrix_set_zero=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_matrix_set_zero=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_matrix_set_zero" >&5 $as_echo "$ac_cv_lib_gsl_gsl_matrix_set_zero" >&6; } if test "x$ac_cv_lib_gsl_gsl_matrix_set_zero" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_matrix_sub is declared" >&5 $as_echo_n "checking whether gsl_matrix_sub is declared... " >&6; } if test "${ac_cv_have_decl_gsl_matrix_sub+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_matrix_sub (void) gsl_matrix_sub; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_matrix_sub=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_matrix_sub=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_matrix_sub" >&5 $as_echo "$ac_cv_have_decl_gsl_matrix_sub" >&6; } if test "x$ac_cv_have_decl_gsl_matrix_sub" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_matrix_sub in -lgsl" >&5 $as_echo_n "checking for gsl_matrix_sub in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_matrix_sub+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_matrix_sub (); int main () { return gsl_matrix_sub (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_matrix_sub=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_matrix_sub=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_matrix_sub" >&5 $as_echo "$ac_cv_lib_gsl_gsl_matrix_sub" >&6; } if test "x$ac_cv_lib_gsl_gsl_matrix_sub" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_matrix_transpose is declared" >&5 $as_echo_n "checking whether gsl_matrix_transpose is declared... " >&6; } if test "${ac_cv_have_decl_gsl_matrix_transpose+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_matrix_transpose (void) gsl_matrix_transpose; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_matrix_transpose=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_matrix_transpose=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_matrix_transpose" >&5 $as_echo "$ac_cv_have_decl_gsl_matrix_transpose" >&6; } if test "x$ac_cv_have_decl_gsl_matrix_transpose" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_matrix_transpose in -lgsl" >&5 $as_echo_n "checking for gsl_matrix_transpose in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_matrix_transpose+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_matrix_transpose (); int main () { return gsl_matrix_transpose (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_matrix_transpose=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_matrix_transpose=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_matrix_transpose" >&5 $as_echo "$ac_cv_lib_gsl_gsl_matrix_transpose" >&6; } if test "x$ac_cv_lib_gsl_gsl_matrix_transpose" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_permutation_alloc is declared" >&5 $as_echo_n "checking whether gsl_permutation_alloc is declared... " >&6; } if test "${ac_cv_have_decl_gsl_permutation_alloc+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_permutation_alloc (void) gsl_permutation_alloc; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_permutation_alloc=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_permutation_alloc=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_permutation_alloc" >&5 $as_echo "$ac_cv_have_decl_gsl_permutation_alloc" >&6; } if test "x$ac_cv_have_decl_gsl_permutation_alloc" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_permutation_alloc in -lgsl" >&5 $as_echo_n "checking for gsl_permutation_alloc in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_permutation_alloc+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_permutation_alloc (); int main () { return gsl_permutation_alloc (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_permutation_alloc=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_permutation_alloc=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_permutation_alloc" >&5 $as_echo "$ac_cv_lib_gsl_gsl_permutation_alloc" >&6; } if test "x$ac_cv_lib_gsl_gsl_permutation_alloc" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_permutation_free is declared" >&5 $as_echo_n "checking whether gsl_permutation_free is declared... " >&6; } if test "${ac_cv_have_decl_gsl_permutation_free+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_permutation_free (void) gsl_permutation_free; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_permutation_free=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_permutation_free=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_permutation_free" >&5 $as_echo "$ac_cv_have_decl_gsl_permutation_free" >&6; } if test "x$ac_cv_have_decl_gsl_permutation_free" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_permutation_free in -lgsl" >&5 $as_echo_n "checking for gsl_permutation_free in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_permutation_free+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_permutation_free (); int main () { return gsl_permutation_free (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_permutation_free=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_permutation_free=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_permutation_free" >&5 $as_echo "$ac_cv_lib_gsl_gsl_permutation_free" >&6; } if test "x$ac_cv_lib_gsl_gsl_permutation_free" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_permutation_get is declared" >&5 $as_echo_n "checking whether gsl_permutation_get is declared... " >&6; } if test "${ac_cv_have_decl_gsl_permutation_get+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_permutation_get (void) gsl_permutation_get; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_permutation_get=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_permutation_get=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_permutation_get" >&5 $as_echo "$ac_cv_have_decl_gsl_permutation_get" >&6; } if test "x$ac_cv_have_decl_gsl_permutation_get" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_permutation_get in -lgsl" >&5 $as_echo_n "checking for gsl_permutation_get in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_permutation_get+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_permutation_get (); int main () { return gsl_permutation_get (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_permutation_get=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_permutation_get=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_permutation_get" >&5 $as_echo "$ac_cv_lib_gsl_gsl_permutation_get" >&6; } if test "x$ac_cv_lib_gsl_gsl_permutation_get" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_set_error_handler is declared" >&5 $as_echo_n "checking whether gsl_set_error_handler is declared... " >&6; } if test "${ac_cv_have_decl_gsl_set_error_handler+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_set_error_handler (void) gsl_set_error_handler; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_set_error_handler=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_set_error_handler=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_set_error_handler" >&5 $as_echo "$ac_cv_have_decl_gsl_set_error_handler" >&6; } if test "x$ac_cv_have_decl_gsl_set_error_handler" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_set_error_handler in -lgsl" >&5 $as_echo_n "checking for gsl_set_error_handler in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_set_error_handler+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_set_error_handler (); int main () { return gsl_set_error_handler (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_set_error_handler=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_set_error_handler=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_set_error_handler" >&5 $as_echo "$ac_cv_lib_gsl_gsl_set_error_handler" >&6; } if test "x$ac_cv_lib_gsl_gsl_set_error_handler" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_set_error_handler_off is declared" >&5 $as_echo_n "checking whether gsl_set_error_handler_off is declared... " >&6; } if test "${ac_cv_have_decl_gsl_set_error_handler_off+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_set_error_handler_off (void) gsl_set_error_handler_off; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_set_error_handler_off=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_set_error_handler_off=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_set_error_handler_off" >&5 $as_echo "$ac_cv_have_decl_gsl_set_error_handler_off" >&6; } if test "x$ac_cv_have_decl_gsl_set_error_handler_off" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_set_error_handler_off in -lgsl" >&5 $as_echo_n "checking for gsl_set_error_handler_off in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_set_error_handler_off+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_set_error_handler_off (); int main () { return gsl_set_error_handler_off (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_set_error_handler_off=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_set_error_handler_off=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_set_error_handler_off" >&5 $as_echo "$ac_cv_lib_gsl_gsl_set_error_handler_off" >&6; } if test "x$ac_cv_lib_gsl_gsl_set_error_handler_off" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_sf_airy_Ai_deriv_e is declared" >&5 $as_echo_n "checking whether gsl_sf_airy_Ai_deriv_e is declared... " >&6; } if test "${ac_cv_have_decl_gsl_sf_airy_Ai_deriv_e+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_sf_airy_Ai_deriv_e (void) gsl_sf_airy_Ai_deriv_e; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_sf_airy_Ai_deriv_e=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_sf_airy_Ai_deriv_e=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_sf_airy_Ai_deriv_e" >&5 $as_echo "$ac_cv_have_decl_gsl_sf_airy_Ai_deriv_e" >&6; } if test "x$ac_cv_have_decl_gsl_sf_airy_Ai_deriv_e" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_sf_airy_Ai_deriv_e in -lgsl" >&5 $as_echo_n "checking for gsl_sf_airy_Ai_deriv_e in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_sf_airy_Ai_deriv_e+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_sf_airy_Ai_deriv_e (); int main () { return gsl_sf_airy_Ai_deriv_e (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_sf_airy_Ai_deriv_e=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_sf_airy_Ai_deriv_e=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_sf_airy_Ai_deriv_e" >&5 $as_echo "$ac_cv_lib_gsl_gsl_sf_airy_Ai_deriv_e" >&6; } if test "x$ac_cv_lib_gsl_gsl_sf_airy_Ai_deriv_e" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_sf_airy_Ai_e is declared" >&5 $as_echo_n "checking whether gsl_sf_airy_Ai_e is declared... " >&6; } if test "${ac_cv_have_decl_gsl_sf_airy_Ai_e+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_sf_airy_Ai_e (void) gsl_sf_airy_Ai_e; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_sf_airy_Ai_e=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_sf_airy_Ai_e=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_sf_airy_Ai_e" >&5 $as_echo "$ac_cv_have_decl_gsl_sf_airy_Ai_e" >&6; } if test "x$ac_cv_have_decl_gsl_sf_airy_Ai_e" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_sf_airy_Ai_e in -lgsl" >&5 $as_echo_n "checking for gsl_sf_airy_Ai_e in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_sf_airy_Ai_e+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_sf_airy_Ai_e (); int main () { return gsl_sf_airy_Ai_e (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_sf_airy_Ai_e=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_sf_airy_Ai_e=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_sf_airy_Ai_e" >&5 $as_echo "$ac_cv_lib_gsl_gsl_sf_airy_Ai_e" >&6; } if test "x$ac_cv_lib_gsl_gsl_sf_airy_Ai_e" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_sf_airy_Bi_deriv_e is declared" >&5 $as_echo_n "checking whether gsl_sf_airy_Bi_deriv_e is declared... " >&6; } if test "${ac_cv_have_decl_gsl_sf_airy_Bi_deriv_e+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_sf_airy_Bi_deriv_e (void) gsl_sf_airy_Bi_deriv_e; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_sf_airy_Bi_deriv_e=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_sf_airy_Bi_deriv_e=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_sf_airy_Bi_deriv_e" >&5 $as_echo "$ac_cv_have_decl_gsl_sf_airy_Bi_deriv_e" >&6; } if test "x$ac_cv_have_decl_gsl_sf_airy_Bi_deriv_e" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_sf_airy_Bi_deriv_e in -lgsl" >&5 $as_echo_n "checking for gsl_sf_airy_Bi_deriv_e in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_sf_airy_Bi_deriv_e+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_sf_airy_Bi_deriv_e (); int main () { return gsl_sf_airy_Bi_deriv_e (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_sf_airy_Bi_deriv_e=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_sf_airy_Bi_deriv_e=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_sf_airy_Bi_deriv_e" >&5 $as_echo "$ac_cv_lib_gsl_gsl_sf_airy_Bi_deriv_e" >&6; } if test "x$ac_cv_lib_gsl_gsl_sf_airy_Bi_deriv_e" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_sf_airy_Bi_e is declared" >&5 $as_echo_n "checking whether gsl_sf_airy_Bi_e is declared... " >&6; } if test "${ac_cv_have_decl_gsl_sf_airy_Bi_e+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_sf_airy_Bi_e (void) gsl_sf_airy_Bi_e; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_sf_airy_Bi_e=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_sf_airy_Bi_e=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_sf_airy_Bi_e" >&5 $as_echo "$ac_cv_have_decl_gsl_sf_airy_Bi_e" >&6; } if test "x$ac_cv_have_decl_gsl_sf_airy_Bi_e" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_sf_airy_Bi_e in -lgsl" >&5 $as_echo_n "checking for gsl_sf_airy_Bi_e in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_sf_airy_Bi_e+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_sf_airy_Bi_e (); int main () { return gsl_sf_airy_Bi_e (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_sf_airy_Bi_e=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_sf_airy_Bi_e=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_sf_airy_Bi_e" >&5 $as_echo "$ac_cv_lib_gsl_gsl_sf_airy_Bi_e" >&6; } if test "x$ac_cv_lib_gsl_gsl_sf_airy_Bi_e" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_sf_bessel_In_e is declared" >&5 $as_echo_n "checking whether gsl_sf_bessel_In_e is declared... " >&6; } if test "${ac_cv_have_decl_gsl_sf_bessel_In_e+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_sf_bessel_In_e (void) gsl_sf_bessel_In_e; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_sf_bessel_In_e=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_sf_bessel_In_e=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_sf_bessel_In_e" >&5 $as_echo "$ac_cv_have_decl_gsl_sf_bessel_In_e" >&6; } if test "x$ac_cv_have_decl_gsl_sf_bessel_In_e" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_sf_bessel_In_e in -lgsl" >&5 $as_echo_n "checking for gsl_sf_bessel_In_e in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_sf_bessel_In_e+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_sf_bessel_In_e (); int main () { return gsl_sf_bessel_In_e (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_sf_bessel_In_e=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_sf_bessel_In_e=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_sf_bessel_In_e" >&5 $as_echo "$ac_cv_lib_gsl_gsl_sf_bessel_In_e" >&6; } if test "x$ac_cv_lib_gsl_gsl_sf_bessel_In_e" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_sf_bessel_In_scaled_e is declared" >&5 $as_echo_n "checking whether gsl_sf_bessel_In_scaled_e is declared... " >&6; } if test "${ac_cv_have_decl_gsl_sf_bessel_In_scaled_e+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_sf_bessel_In_scaled_e (void) gsl_sf_bessel_In_scaled_e; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_sf_bessel_In_scaled_e=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_sf_bessel_In_scaled_e=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_sf_bessel_In_scaled_e" >&5 $as_echo "$ac_cv_have_decl_gsl_sf_bessel_In_scaled_e" >&6; } if test "x$ac_cv_have_decl_gsl_sf_bessel_In_scaled_e" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_sf_bessel_In_scaled_e in -lgsl" >&5 $as_echo_n "checking for gsl_sf_bessel_In_scaled_e in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_sf_bessel_In_scaled_e+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_sf_bessel_In_scaled_e (); int main () { return gsl_sf_bessel_In_scaled_e (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_sf_bessel_In_scaled_e=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_sf_bessel_In_scaled_e=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_sf_bessel_In_scaled_e" >&5 $as_echo "$ac_cv_lib_gsl_gsl_sf_bessel_In_scaled_e" >&6; } if test "x$ac_cv_lib_gsl_gsl_sf_bessel_In_scaled_e" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_sf_bessel_Inu_e is declared" >&5 $as_echo_n "checking whether gsl_sf_bessel_Inu_e is declared... " >&6; } if test "${ac_cv_have_decl_gsl_sf_bessel_Inu_e+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_sf_bessel_Inu_e (void) gsl_sf_bessel_Inu_e; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_sf_bessel_Inu_e=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_sf_bessel_Inu_e=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_sf_bessel_Inu_e" >&5 $as_echo "$ac_cv_have_decl_gsl_sf_bessel_Inu_e" >&6; } if test "x$ac_cv_have_decl_gsl_sf_bessel_Inu_e" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_sf_bessel_Inu_e in -lgsl" >&5 $as_echo_n "checking for gsl_sf_bessel_Inu_e in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_sf_bessel_Inu_e+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_sf_bessel_Inu_e (); int main () { return gsl_sf_bessel_Inu_e (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_sf_bessel_Inu_e=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_sf_bessel_Inu_e=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_sf_bessel_Inu_e" >&5 $as_echo "$ac_cv_lib_gsl_gsl_sf_bessel_Inu_e" >&6; } if test "x$ac_cv_lib_gsl_gsl_sf_bessel_Inu_e" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_sf_bessel_Inu_scaled_e is declared" >&5 $as_echo_n "checking whether gsl_sf_bessel_Inu_scaled_e is declared... " >&6; } if test "${ac_cv_have_decl_gsl_sf_bessel_Inu_scaled_e+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_sf_bessel_Inu_scaled_e (void) gsl_sf_bessel_Inu_scaled_e; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_sf_bessel_Inu_scaled_e=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_sf_bessel_Inu_scaled_e=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_sf_bessel_Inu_scaled_e" >&5 $as_echo "$ac_cv_have_decl_gsl_sf_bessel_Inu_scaled_e" >&6; } if test "x$ac_cv_have_decl_gsl_sf_bessel_Inu_scaled_e" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_sf_bessel_Inu_scaled_e in -lgsl" >&5 $as_echo_n "checking for gsl_sf_bessel_Inu_scaled_e in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_sf_bessel_Inu_scaled_e+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_sf_bessel_Inu_scaled_e (); int main () { return gsl_sf_bessel_Inu_scaled_e (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_sf_bessel_Inu_scaled_e=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_sf_bessel_Inu_scaled_e=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_sf_bessel_Inu_scaled_e" >&5 $as_echo "$ac_cv_lib_gsl_gsl_sf_bessel_Inu_scaled_e" >&6; } if test "x$ac_cv_lib_gsl_gsl_sf_bessel_Inu_scaled_e" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_sf_bessel_Jn_e is declared" >&5 $as_echo_n "checking whether gsl_sf_bessel_Jn_e is declared... " >&6; } if test "${ac_cv_have_decl_gsl_sf_bessel_Jn_e+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_sf_bessel_Jn_e (void) gsl_sf_bessel_Jn_e; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_sf_bessel_Jn_e=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_sf_bessel_Jn_e=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_sf_bessel_Jn_e" >&5 $as_echo "$ac_cv_have_decl_gsl_sf_bessel_Jn_e" >&6; } if test "x$ac_cv_have_decl_gsl_sf_bessel_Jn_e" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_sf_bessel_Jn_e in -lgsl" >&5 $as_echo_n "checking for gsl_sf_bessel_Jn_e in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_sf_bessel_Jn_e+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_sf_bessel_Jn_e (); int main () { return gsl_sf_bessel_Jn_e (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_sf_bessel_Jn_e=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_sf_bessel_Jn_e=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_sf_bessel_Jn_e" >&5 $as_echo "$ac_cv_lib_gsl_gsl_sf_bessel_Jn_e" >&6; } if test "x$ac_cv_lib_gsl_gsl_sf_bessel_Jn_e" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_sf_bessel_Jnu_e is declared" >&5 $as_echo_n "checking whether gsl_sf_bessel_Jnu_e is declared... " >&6; } if test "${ac_cv_have_decl_gsl_sf_bessel_Jnu_e+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_sf_bessel_Jnu_e (void) gsl_sf_bessel_Jnu_e; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_sf_bessel_Jnu_e=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_sf_bessel_Jnu_e=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_sf_bessel_Jnu_e" >&5 $as_echo "$ac_cv_have_decl_gsl_sf_bessel_Jnu_e" >&6; } if test "x$ac_cv_have_decl_gsl_sf_bessel_Jnu_e" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_sf_bessel_Jnu_e in -lgsl" >&5 $as_echo_n "checking for gsl_sf_bessel_Jnu_e in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_sf_bessel_Jnu_e+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_sf_bessel_Jnu_e (); int main () { return gsl_sf_bessel_Jnu_e (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_sf_bessel_Jnu_e=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_sf_bessel_Jnu_e=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_sf_bessel_Jnu_e" >&5 $as_echo "$ac_cv_lib_gsl_gsl_sf_bessel_Jnu_e" >&6; } if test "x$ac_cv_lib_gsl_gsl_sf_bessel_Jnu_e" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_sf_bessel_Kn_e is declared" >&5 $as_echo_n "checking whether gsl_sf_bessel_Kn_e is declared... " >&6; } if test "${ac_cv_have_decl_gsl_sf_bessel_Kn_e+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_sf_bessel_Kn_e (void) gsl_sf_bessel_Kn_e; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_sf_bessel_Kn_e=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_sf_bessel_Kn_e=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_sf_bessel_Kn_e" >&5 $as_echo "$ac_cv_have_decl_gsl_sf_bessel_Kn_e" >&6; } if test "x$ac_cv_have_decl_gsl_sf_bessel_Kn_e" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_sf_bessel_Kn_e in -lgsl" >&5 $as_echo_n "checking for gsl_sf_bessel_Kn_e in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_sf_bessel_Kn_e+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_sf_bessel_Kn_e (); int main () { return gsl_sf_bessel_Kn_e (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_sf_bessel_Kn_e=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_sf_bessel_Kn_e=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_sf_bessel_Kn_e" >&5 $as_echo "$ac_cv_lib_gsl_gsl_sf_bessel_Kn_e" >&6; } if test "x$ac_cv_lib_gsl_gsl_sf_bessel_Kn_e" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_sf_bessel_Kn_scaled_e is declared" >&5 $as_echo_n "checking whether gsl_sf_bessel_Kn_scaled_e is declared... " >&6; } if test "${ac_cv_have_decl_gsl_sf_bessel_Kn_scaled_e+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_sf_bessel_Kn_scaled_e (void) gsl_sf_bessel_Kn_scaled_e; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_sf_bessel_Kn_scaled_e=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_sf_bessel_Kn_scaled_e=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_sf_bessel_Kn_scaled_e" >&5 $as_echo "$ac_cv_have_decl_gsl_sf_bessel_Kn_scaled_e" >&6; } if test "x$ac_cv_have_decl_gsl_sf_bessel_Kn_scaled_e" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_sf_bessel_Kn_scaled_e in -lgsl" >&5 $as_echo_n "checking for gsl_sf_bessel_Kn_scaled_e in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_sf_bessel_Kn_scaled_e+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_sf_bessel_Kn_scaled_e (); int main () { return gsl_sf_bessel_Kn_scaled_e (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_sf_bessel_Kn_scaled_e=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_sf_bessel_Kn_scaled_e=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_sf_bessel_Kn_scaled_e" >&5 $as_echo "$ac_cv_lib_gsl_gsl_sf_bessel_Kn_scaled_e" >&6; } if test "x$ac_cv_lib_gsl_gsl_sf_bessel_Kn_scaled_e" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_sf_bessel_Knu_e is declared" >&5 $as_echo_n "checking whether gsl_sf_bessel_Knu_e is declared... " >&6; } if test "${ac_cv_have_decl_gsl_sf_bessel_Knu_e+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_sf_bessel_Knu_e (void) gsl_sf_bessel_Knu_e; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_sf_bessel_Knu_e=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_sf_bessel_Knu_e=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_sf_bessel_Knu_e" >&5 $as_echo "$ac_cv_have_decl_gsl_sf_bessel_Knu_e" >&6; } if test "x$ac_cv_have_decl_gsl_sf_bessel_Knu_e" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_sf_bessel_Knu_e in -lgsl" >&5 $as_echo_n "checking for gsl_sf_bessel_Knu_e in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_sf_bessel_Knu_e+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_sf_bessel_Knu_e (); int main () { return gsl_sf_bessel_Knu_e (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_sf_bessel_Knu_e=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_sf_bessel_Knu_e=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_sf_bessel_Knu_e" >&5 $as_echo "$ac_cv_lib_gsl_gsl_sf_bessel_Knu_e" >&6; } if test "x$ac_cv_lib_gsl_gsl_sf_bessel_Knu_e" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_sf_bessel_Knu_scaled_e is declared" >&5 $as_echo_n "checking whether gsl_sf_bessel_Knu_scaled_e is declared... " >&6; } if test "${ac_cv_have_decl_gsl_sf_bessel_Knu_scaled_e+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_sf_bessel_Knu_scaled_e (void) gsl_sf_bessel_Knu_scaled_e; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_sf_bessel_Knu_scaled_e=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_sf_bessel_Knu_scaled_e=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_sf_bessel_Knu_scaled_e" >&5 $as_echo "$ac_cv_have_decl_gsl_sf_bessel_Knu_scaled_e" >&6; } if test "x$ac_cv_have_decl_gsl_sf_bessel_Knu_scaled_e" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_sf_bessel_Knu_scaled_e in -lgsl" >&5 $as_echo_n "checking for gsl_sf_bessel_Knu_scaled_e in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_sf_bessel_Knu_scaled_e+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_sf_bessel_Knu_scaled_e (); int main () { return gsl_sf_bessel_Knu_scaled_e (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_sf_bessel_Knu_scaled_e=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_sf_bessel_Knu_scaled_e=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_sf_bessel_Knu_scaled_e" >&5 $as_echo "$ac_cv_lib_gsl_gsl_sf_bessel_Knu_scaled_e" >&6; } if test "x$ac_cv_lib_gsl_gsl_sf_bessel_Knu_scaled_e" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_sf_bessel_Yn_e is declared" >&5 $as_echo_n "checking whether gsl_sf_bessel_Yn_e is declared... " >&6; } if test "${ac_cv_have_decl_gsl_sf_bessel_Yn_e+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_sf_bessel_Yn_e (void) gsl_sf_bessel_Yn_e; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_sf_bessel_Yn_e=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_sf_bessel_Yn_e=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_sf_bessel_Yn_e" >&5 $as_echo "$ac_cv_have_decl_gsl_sf_bessel_Yn_e" >&6; } if test "x$ac_cv_have_decl_gsl_sf_bessel_Yn_e" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_sf_bessel_Yn_e in -lgsl" >&5 $as_echo_n "checking for gsl_sf_bessel_Yn_e in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_sf_bessel_Yn_e+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_sf_bessel_Yn_e (); int main () { return gsl_sf_bessel_Yn_e (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_sf_bessel_Yn_e=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_sf_bessel_Yn_e=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_sf_bessel_Yn_e" >&5 $as_echo "$ac_cv_lib_gsl_gsl_sf_bessel_Yn_e" >&6; } if test "x$ac_cv_lib_gsl_gsl_sf_bessel_Yn_e" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_sf_bessel_Ynu_e is declared" >&5 $as_echo_n "checking whether gsl_sf_bessel_Ynu_e is declared... " >&6; } if test "${ac_cv_have_decl_gsl_sf_bessel_Ynu_e+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_sf_bessel_Ynu_e (void) gsl_sf_bessel_Ynu_e; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_sf_bessel_Ynu_e=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_sf_bessel_Ynu_e=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_sf_bessel_Ynu_e" >&5 $as_echo "$ac_cv_have_decl_gsl_sf_bessel_Ynu_e" >&6; } if test "x$ac_cv_have_decl_gsl_sf_bessel_Ynu_e" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_sf_bessel_Ynu_e in -lgsl" >&5 $as_echo_n "checking for gsl_sf_bessel_Ynu_e in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_sf_bessel_Ynu_e+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_sf_bessel_Ynu_e (); int main () { return gsl_sf_bessel_Ynu_e (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_sf_bessel_Ynu_e=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_sf_bessel_Ynu_e=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_sf_bessel_Ynu_e" >&5 $as_echo "$ac_cv_lib_gsl_gsl_sf_bessel_Ynu_e" >&6; } if test "x$ac_cv_lib_gsl_gsl_sf_bessel_Ynu_e" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_sf_bessel_il_scaled_e is declared" >&5 $as_echo_n "checking whether gsl_sf_bessel_il_scaled_e is declared... " >&6; } if test "${ac_cv_have_decl_gsl_sf_bessel_il_scaled_e+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_sf_bessel_il_scaled_e (void) gsl_sf_bessel_il_scaled_e; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_sf_bessel_il_scaled_e=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_sf_bessel_il_scaled_e=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_sf_bessel_il_scaled_e" >&5 $as_echo "$ac_cv_have_decl_gsl_sf_bessel_il_scaled_e" >&6; } if test "x$ac_cv_have_decl_gsl_sf_bessel_il_scaled_e" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_sf_bessel_il_scaled_e in -lgsl" >&5 $as_echo_n "checking for gsl_sf_bessel_il_scaled_e in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_sf_bessel_il_scaled_e+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_sf_bessel_il_scaled_e (); int main () { return gsl_sf_bessel_il_scaled_e (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_sf_bessel_il_scaled_e=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_sf_bessel_il_scaled_e=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_sf_bessel_il_scaled_e" >&5 $as_echo "$ac_cv_lib_gsl_gsl_sf_bessel_il_scaled_e" >&6; } if test "x$ac_cv_lib_gsl_gsl_sf_bessel_il_scaled_e" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_sf_bessel_jl_e is declared" >&5 $as_echo_n "checking whether gsl_sf_bessel_jl_e is declared... " >&6; } if test "${ac_cv_have_decl_gsl_sf_bessel_jl_e+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_sf_bessel_jl_e (void) gsl_sf_bessel_jl_e; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_sf_bessel_jl_e=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_sf_bessel_jl_e=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_sf_bessel_jl_e" >&5 $as_echo "$ac_cv_have_decl_gsl_sf_bessel_jl_e" >&6; } if test "x$ac_cv_have_decl_gsl_sf_bessel_jl_e" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_sf_bessel_jl_e in -lgsl" >&5 $as_echo_n "checking for gsl_sf_bessel_jl_e in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_sf_bessel_jl_e+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_sf_bessel_jl_e (); int main () { return gsl_sf_bessel_jl_e (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_sf_bessel_jl_e=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_sf_bessel_jl_e=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_sf_bessel_jl_e" >&5 $as_echo "$ac_cv_lib_gsl_gsl_sf_bessel_jl_e" >&6; } if test "x$ac_cv_lib_gsl_gsl_sf_bessel_jl_e" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_sf_bessel_kl_scaled_e is declared" >&5 $as_echo_n "checking whether gsl_sf_bessel_kl_scaled_e is declared... " >&6; } if test "${ac_cv_have_decl_gsl_sf_bessel_kl_scaled_e+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_sf_bessel_kl_scaled_e (void) gsl_sf_bessel_kl_scaled_e; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_sf_bessel_kl_scaled_e=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_sf_bessel_kl_scaled_e=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_sf_bessel_kl_scaled_e" >&5 $as_echo "$ac_cv_have_decl_gsl_sf_bessel_kl_scaled_e" >&6; } if test "x$ac_cv_have_decl_gsl_sf_bessel_kl_scaled_e" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_sf_bessel_kl_scaled_e in -lgsl" >&5 $as_echo_n "checking for gsl_sf_bessel_kl_scaled_e in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_sf_bessel_kl_scaled_e+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_sf_bessel_kl_scaled_e (); int main () { return gsl_sf_bessel_kl_scaled_e (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_sf_bessel_kl_scaled_e=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_sf_bessel_kl_scaled_e=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_sf_bessel_kl_scaled_e" >&5 $as_echo "$ac_cv_lib_gsl_gsl_sf_bessel_kl_scaled_e" >&6; } if test "x$ac_cv_lib_gsl_gsl_sf_bessel_kl_scaled_e" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_sf_bessel_yl_e is declared" >&5 $as_echo_n "checking whether gsl_sf_bessel_yl_e is declared... " >&6; } if test "${ac_cv_have_decl_gsl_sf_bessel_yl_e+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_sf_bessel_yl_e (void) gsl_sf_bessel_yl_e; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_sf_bessel_yl_e=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_sf_bessel_yl_e=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_sf_bessel_yl_e" >&5 $as_echo "$ac_cv_have_decl_gsl_sf_bessel_yl_e" >&6; } if test "x$ac_cv_have_decl_gsl_sf_bessel_yl_e" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_sf_bessel_yl_e in -lgsl" >&5 $as_echo_n "checking for gsl_sf_bessel_yl_e in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_sf_bessel_yl_e+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_sf_bessel_yl_e (); int main () { return gsl_sf_bessel_yl_e (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_sf_bessel_yl_e=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_sf_bessel_yl_e=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_sf_bessel_yl_e" >&5 $as_echo "$ac_cv_lib_gsl_gsl_sf_bessel_yl_e" >&6; } if test "x$ac_cv_lib_gsl_gsl_sf_bessel_yl_e" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_sf_beta_e is declared" >&5 $as_echo_n "checking whether gsl_sf_beta_e is declared... " >&6; } if test "${ac_cv_have_decl_gsl_sf_beta_e+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_sf_beta_e (void) gsl_sf_beta_e; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_sf_beta_e=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_sf_beta_e=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_sf_beta_e" >&5 $as_echo "$ac_cv_have_decl_gsl_sf_beta_e" >&6; } if test "x$ac_cv_have_decl_gsl_sf_beta_e" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_sf_beta_e in -lgsl" >&5 $as_echo_n "checking for gsl_sf_beta_e in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_sf_beta_e+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_sf_beta_e (); int main () { return gsl_sf_beta_e (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_sf_beta_e=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_sf_beta_e=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_sf_beta_e" >&5 $as_echo "$ac_cv_lib_gsl_gsl_sf_beta_e" >&6; } if test "x$ac_cv_lib_gsl_gsl_sf_beta_e" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_sf_beta_inc_e is declared" >&5 $as_echo_n "checking whether gsl_sf_beta_inc_e is declared... " >&6; } if test "${ac_cv_have_decl_gsl_sf_beta_inc_e+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_sf_beta_inc_e (void) gsl_sf_beta_inc_e; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_sf_beta_inc_e=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_sf_beta_inc_e=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_sf_beta_inc_e" >&5 $as_echo "$ac_cv_have_decl_gsl_sf_beta_inc_e" >&6; } if test "x$ac_cv_have_decl_gsl_sf_beta_inc_e" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_sf_beta_inc_e in -lgsl" >&5 $as_echo_n "checking for gsl_sf_beta_inc_e in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_sf_beta_inc_e+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_sf_beta_inc_e (); int main () { return gsl_sf_beta_inc_e (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_sf_beta_inc_e=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_sf_beta_inc_e=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_sf_beta_inc_e" >&5 $as_echo "$ac_cv_lib_gsl_gsl_sf_beta_inc_e" >&6; } if test "x$ac_cv_lib_gsl_gsl_sf_beta_inc_e" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_sf_ellint_Ecomp_e is declared" >&5 $as_echo_n "checking whether gsl_sf_ellint_Ecomp_e is declared... " >&6; } if test "${ac_cv_have_decl_gsl_sf_ellint_Ecomp_e+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_sf_ellint_Ecomp_e (void) gsl_sf_ellint_Ecomp_e; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_sf_ellint_Ecomp_e=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_sf_ellint_Ecomp_e=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_sf_ellint_Ecomp_e" >&5 $as_echo "$ac_cv_have_decl_gsl_sf_ellint_Ecomp_e" >&6; } if test "x$ac_cv_have_decl_gsl_sf_ellint_Ecomp_e" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_sf_ellint_Ecomp_e in -lgsl" >&5 $as_echo_n "checking for gsl_sf_ellint_Ecomp_e in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_sf_ellint_Ecomp_e+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_sf_ellint_Ecomp_e (); int main () { return gsl_sf_ellint_Ecomp_e (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_sf_ellint_Ecomp_e=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_sf_ellint_Ecomp_e=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_sf_ellint_Ecomp_e" >&5 $as_echo "$ac_cv_lib_gsl_gsl_sf_ellint_Ecomp_e" >&6; } if test "x$ac_cv_lib_gsl_gsl_sf_ellint_Ecomp_e" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_sf_ellint_Kcomp_e is declared" >&5 $as_echo_n "checking whether gsl_sf_ellint_Kcomp_e is declared... " >&6; } if test "${ac_cv_have_decl_gsl_sf_ellint_Kcomp_e+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_sf_ellint_Kcomp_e (void) gsl_sf_ellint_Kcomp_e; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_sf_ellint_Kcomp_e=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_sf_ellint_Kcomp_e=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_sf_ellint_Kcomp_e" >&5 $as_echo "$ac_cv_have_decl_gsl_sf_ellint_Kcomp_e" >&6; } if test "x$ac_cv_have_decl_gsl_sf_ellint_Kcomp_e" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_sf_ellint_Kcomp_e in -lgsl" >&5 $as_echo_n "checking for gsl_sf_ellint_Kcomp_e in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_sf_ellint_Kcomp_e+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_sf_ellint_Kcomp_e (); int main () { return gsl_sf_ellint_Kcomp_e (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_sf_ellint_Kcomp_e=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_sf_ellint_Kcomp_e=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_sf_ellint_Kcomp_e" >&5 $as_echo "$ac_cv_lib_gsl_gsl_sf_ellint_Kcomp_e" >&6; } if test "x$ac_cv_lib_gsl_gsl_sf_ellint_Kcomp_e" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_sf_ellint_RC_e is declared" >&5 $as_echo_n "checking whether gsl_sf_ellint_RC_e is declared... " >&6; } if test "${ac_cv_have_decl_gsl_sf_ellint_RC_e+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_sf_ellint_RC_e (void) gsl_sf_ellint_RC_e; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_sf_ellint_RC_e=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_sf_ellint_RC_e=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_sf_ellint_RC_e" >&5 $as_echo "$ac_cv_have_decl_gsl_sf_ellint_RC_e" >&6; } if test "x$ac_cv_have_decl_gsl_sf_ellint_RC_e" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_sf_ellint_RC_e in -lgsl" >&5 $as_echo_n "checking for gsl_sf_ellint_RC_e in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_sf_ellint_RC_e+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_sf_ellint_RC_e (); int main () { return gsl_sf_ellint_RC_e (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_sf_ellint_RC_e=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_sf_ellint_RC_e=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_sf_ellint_RC_e" >&5 $as_echo "$ac_cv_lib_gsl_gsl_sf_ellint_RC_e" >&6; } if test "x$ac_cv_lib_gsl_gsl_sf_ellint_RC_e" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_sf_ellint_RD_e is declared" >&5 $as_echo_n "checking whether gsl_sf_ellint_RD_e is declared... " >&6; } if test "${ac_cv_have_decl_gsl_sf_ellint_RD_e+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_sf_ellint_RD_e (void) gsl_sf_ellint_RD_e; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_sf_ellint_RD_e=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_sf_ellint_RD_e=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_sf_ellint_RD_e" >&5 $as_echo "$ac_cv_have_decl_gsl_sf_ellint_RD_e" >&6; } if test "x$ac_cv_have_decl_gsl_sf_ellint_RD_e" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_sf_ellint_RD_e in -lgsl" >&5 $as_echo_n "checking for gsl_sf_ellint_RD_e in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_sf_ellint_RD_e+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_sf_ellint_RD_e (); int main () { return gsl_sf_ellint_RD_e (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_sf_ellint_RD_e=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_sf_ellint_RD_e=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_sf_ellint_RD_e" >&5 $as_echo "$ac_cv_lib_gsl_gsl_sf_ellint_RD_e" >&6; } if test "x$ac_cv_lib_gsl_gsl_sf_ellint_RD_e" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_sf_ellint_RF_e is declared" >&5 $as_echo_n "checking whether gsl_sf_ellint_RF_e is declared... " >&6; } if test "${ac_cv_have_decl_gsl_sf_ellint_RF_e+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_sf_ellint_RF_e (void) gsl_sf_ellint_RF_e; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_sf_ellint_RF_e=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_sf_ellint_RF_e=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_sf_ellint_RF_e" >&5 $as_echo "$ac_cv_have_decl_gsl_sf_ellint_RF_e" >&6; } if test "x$ac_cv_have_decl_gsl_sf_ellint_RF_e" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_sf_ellint_RF_e in -lgsl" >&5 $as_echo_n "checking for gsl_sf_ellint_RF_e in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_sf_ellint_RF_e+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_sf_ellint_RF_e (); int main () { return gsl_sf_ellint_RF_e (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_sf_ellint_RF_e=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_sf_ellint_RF_e=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_sf_ellint_RF_e" >&5 $as_echo "$ac_cv_lib_gsl_gsl_sf_ellint_RF_e" >&6; } if test "x$ac_cv_lib_gsl_gsl_sf_ellint_RF_e" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_sf_ellint_RJ_e is declared" >&5 $as_echo_n "checking whether gsl_sf_ellint_RJ_e is declared... " >&6; } if test "${ac_cv_have_decl_gsl_sf_ellint_RJ_e+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_sf_ellint_RJ_e (void) gsl_sf_ellint_RJ_e; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_sf_ellint_RJ_e=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_sf_ellint_RJ_e=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_sf_ellint_RJ_e" >&5 $as_echo "$ac_cv_have_decl_gsl_sf_ellint_RJ_e" >&6; } if test "x$ac_cv_have_decl_gsl_sf_ellint_RJ_e" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_sf_ellint_RJ_e in -lgsl" >&5 $as_echo_n "checking for gsl_sf_ellint_RJ_e in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_sf_ellint_RJ_e+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_sf_ellint_RJ_e (); int main () { return gsl_sf_ellint_RJ_e (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_sf_ellint_RJ_e=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_sf_ellint_RJ_e=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_sf_ellint_RJ_e" >&5 $as_echo "$ac_cv_lib_gsl_gsl_sf_ellint_RJ_e" >&6; } if test "x$ac_cv_lib_gsl_gsl_sf_ellint_RJ_e" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_sf_erf_e is declared" >&5 $as_echo_n "checking whether gsl_sf_erf_e is declared... " >&6; } if test "${ac_cv_have_decl_gsl_sf_erf_e+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_sf_erf_e (void) gsl_sf_erf_e; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_sf_erf_e=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_sf_erf_e=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_sf_erf_e" >&5 $as_echo "$ac_cv_have_decl_gsl_sf_erf_e" >&6; } if test "x$ac_cv_have_decl_gsl_sf_erf_e" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_sf_erf_e in -lgsl" >&5 $as_echo_n "checking for gsl_sf_erf_e in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_sf_erf_e+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_sf_erf_e (); int main () { return gsl_sf_erf_e (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_sf_erf_e=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_sf_erf_e=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_sf_erf_e" >&5 $as_echo "$ac_cv_lib_gsl_gsl_sf_erf_e" >&6; } if test "x$ac_cv_lib_gsl_gsl_sf_erf_e" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_sf_erfc_e is declared" >&5 $as_echo_n "checking whether gsl_sf_erfc_e is declared... " >&6; } if test "${ac_cv_have_decl_gsl_sf_erfc_e+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_sf_erfc_e (void) gsl_sf_erfc_e; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_sf_erfc_e=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_sf_erfc_e=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_sf_erfc_e" >&5 $as_echo "$ac_cv_have_decl_gsl_sf_erfc_e" >&6; } if test "x$ac_cv_have_decl_gsl_sf_erfc_e" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_sf_erfc_e in -lgsl" >&5 $as_echo_n "checking for gsl_sf_erfc_e in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_sf_erfc_e+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_sf_erfc_e (); int main () { return gsl_sf_erfc_e (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_sf_erfc_e=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_sf_erfc_e=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_sf_erfc_e" >&5 $as_echo "$ac_cv_lib_gsl_gsl_sf_erfc_e" >&6; } if test "x$ac_cv_lib_gsl_gsl_sf_erfc_e" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_sf_fact is declared" >&5 $as_echo_n "checking whether gsl_sf_fact is declared... " >&6; } if test "${ac_cv_have_decl_gsl_sf_fact+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_sf_fact (void) gsl_sf_fact; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_sf_fact=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_sf_fact=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_sf_fact" >&5 $as_echo "$ac_cv_have_decl_gsl_sf_fact" >&6; } if test "x$ac_cv_have_decl_gsl_sf_fact" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_sf_fact in -lgsl" >&5 $as_echo_n "checking for gsl_sf_fact in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_sf_fact+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_sf_fact (); int main () { return gsl_sf_fact (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_sf_fact=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_sf_fact=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_sf_fact" >&5 $as_echo "$ac_cv_lib_gsl_gsl_sf_fact" >&6; } if test "x$ac_cv_lib_gsl_gsl_sf_fact" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_sf_gamma_e is declared" >&5 $as_echo_n "checking whether gsl_sf_gamma_e is declared... " >&6; } if test "${ac_cv_have_decl_gsl_sf_gamma_e+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_sf_gamma_e (void) gsl_sf_gamma_e; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_sf_gamma_e=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_sf_gamma_e=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_sf_gamma_e" >&5 $as_echo "$ac_cv_have_decl_gsl_sf_gamma_e" >&6; } if test "x$ac_cv_have_decl_gsl_sf_gamma_e" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_sf_gamma_e in -lgsl" >&5 $as_echo_n "checking for gsl_sf_gamma_e in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_sf_gamma_e+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_sf_gamma_e (); int main () { return gsl_sf_gamma_e (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_sf_gamma_e=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_sf_gamma_e=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_sf_gamma_e" >&5 $as_echo "$ac_cv_lib_gsl_gsl_sf_gamma_e" >&6; } if test "x$ac_cv_lib_gsl_gsl_sf_gamma_e" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_sf_gamma_inc_P_e is declared" >&5 $as_echo_n "checking whether gsl_sf_gamma_inc_P_e is declared... " >&6; } if test "${ac_cv_have_decl_gsl_sf_gamma_inc_P_e+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_sf_gamma_inc_P_e (void) gsl_sf_gamma_inc_P_e; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_sf_gamma_inc_P_e=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_sf_gamma_inc_P_e=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_sf_gamma_inc_P_e" >&5 $as_echo "$ac_cv_have_decl_gsl_sf_gamma_inc_P_e" >&6; } if test "x$ac_cv_have_decl_gsl_sf_gamma_inc_P_e" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_sf_gamma_inc_P_e in -lgsl" >&5 $as_echo_n "checking for gsl_sf_gamma_inc_P_e in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_sf_gamma_inc_P_e+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_sf_gamma_inc_P_e (); int main () { return gsl_sf_gamma_inc_P_e (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_sf_gamma_inc_P_e=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_sf_gamma_inc_P_e=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_sf_gamma_inc_P_e" >&5 $as_echo "$ac_cv_lib_gsl_gsl_sf_gamma_inc_P_e" >&6; } if test "x$ac_cv_lib_gsl_gsl_sf_gamma_inc_P_e" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_sf_lngamma_e is declared" >&5 $as_echo_n "checking whether gsl_sf_lngamma_e is declared... " >&6; } if test "${ac_cv_have_decl_gsl_sf_lngamma_e+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_sf_lngamma_e (void) gsl_sf_lngamma_e; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_sf_lngamma_e=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_sf_lngamma_e=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_sf_lngamma_e" >&5 $as_echo "$ac_cv_have_decl_gsl_sf_lngamma_e" >&6; } if test "x$ac_cv_have_decl_gsl_sf_lngamma_e" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_sf_lngamma_e in -lgsl" >&5 $as_echo_n "checking for gsl_sf_lngamma_e in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_sf_lngamma_e+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_sf_lngamma_e (); int main () { return gsl_sf_lngamma_e (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_sf_lngamma_e=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_sf_lngamma_e=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_sf_lngamma_e" >&5 $as_echo "$ac_cv_lib_gsl_gsl_sf_lngamma_e" >&6; } if test "x$ac_cv_lib_gsl_gsl_sf_lngamma_e" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_strerror is declared" >&5 $as_echo_n "checking whether gsl_strerror is declared... " >&6; } if test "${ac_cv_have_decl_gsl_strerror+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_strerror (void) gsl_strerror; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_strerror=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_strerror=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_strerror" >&5 $as_echo "$ac_cv_have_decl_gsl_strerror" >&6; } if test "x$ac_cv_have_decl_gsl_strerror" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_strerror in -lgsl" >&5 $as_echo_n "checking for gsl_strerror in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_strerror+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_strerror (); int main () { return gsl_strerror (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_strerror=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_strerror=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_strerror" >&5 $as_echo "$ac_cv_lib_gsl_gsl_strerror" >&6; } if test "x$ac_cv_lib_gsl_gsl_strerror" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_vector_add is declared" >&5 $as_echo_n "checking whether gsl_vector_add is declared... " >&6; } if test "${ac_cv_have_decl_gsl_vector_add+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_vector_add (void) gsl_vector_add; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_vector_add=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_vector_add=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_vector_add" >&5 $as_echo "$ac_cv_have_decl_gsl_vector_add" >&6; } if test "x$ac_cv_have_decl_gsl_vector_add" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_vector_add in -lgsl" >&5 $as_echo_n "checking for gsl_vector_add in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_vector_add+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_vector_add (); int main () { return gsl_vector_add (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_vector_add=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_vector_add=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_vector_add" >&5 $as_echo "$ac_cv_lib_gsl_gsl_vector_add" >&6; } if test "x$ac_cv_lib_gsl_gsl_vector_add" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_vector_alloc is declared" >&5 $as_echo_n "checking whether gsl_vector_alloc is declared... " >&6; } if test "${ac_cv_have_decl_gsl_vector_alloc+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_vector_alloc (void) gsl_vector_alloc; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_vector_alloc=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_vector_alloc=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_vector_alloc" >&5 $as_echo "$ac_cv_have_decl_gsl_vector_alloc" >&6; } if test "x$ac_cv_have_decl_gsl_vector_alloc" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_vector_alloc in -lgsl" >&5 $as_echo_n "checking for gsl_vector_alloc in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_vector_alloc+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_vector_alloc (); int main () { return gsl_vector_alloc (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_vector_alloc=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_vector_alloc=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_vector_alloc" >&5 $as_echo "$ac_cv_lib_gsl_gsl_vector_alloc" >&6; } if test "x$ac_cv_lib_gsl_gsl_vector_alloc" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_vector_complex_alloc is declared" >&5 $as_echo_n "checking whether gsl_vector_complex_alloc is declared... " >&6; } if test "${ac_cv_have_decl_gsl_vector_complex_alloc+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_vector_complex_alloc (void) gsl_vector_complex_alloc; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_vector_complex_alloc=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_vector_complex_alloc=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_vector_complex_alloc" >&5 $as_echo "$ac_cv_have_decl_gsl_vector_complex_alloc" >&6; } if test "x$ac_cv_have_decl_gsl_vector_complex_alloc" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_vector_complex_alloc in -lgsl" >&5 $as_echo_n "checking for gsl_vector_complex_alloc in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_vector_complex_alloc+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_vector_complex_alloc (); int main () { return gsl_vector_complex_alloc (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_vector_complex_alloc=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_vector_complex_alloc=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_vector_complex_alloc" >&5 $as_echo "$ac_cv_lib_gsl_gsl_vector_complex_alloc" >&6; } if test "x$ac_cv_lib_gsl_gsl_vector_complex_alloc" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_vector_complex_free is declared" >&5 $as_echo_n "checking whether gsl_vector_complex_free is declared... " >&6; } if test "${ac_cv_have_decl_gsl_vector_complex_free+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_vector_complex_free (void) gsl_vector_complex_free; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_vector_complex_free=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_vector_complex_free=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_vector_complex_free" >&5 $as_echo "$ac_cv_have_decl_gsl_vector_complex_free" >&6; } if test "x$ac_cv_have_decl_gsl_vector_complex_free" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_vector_complex_free in -lgsl" >&5 $as_echo_n "checking for gsl_vector_complex_free in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_vector_complex_free+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_vector_complex_free (); int main () { return gsl_vector_complex_free (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_vector_complex_free=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_vector_complex_free=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_vector_complex_free" >&5 $as_echo "$ac_cv_lib_gsl_gsl_vector_complex_free" >&6; } if test "x$ac_cv_lib_gsl_gsl_vector_complex_free" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_vector_complex_get is declared" >&5 $as_echo_n "checking whether gsl_vector_complex_get is declared... " >&6; } if test "${ac_cv_have_decl_gsl_vector_complex_get+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_vector_complex_get (void) gsl_vector_complex_get; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_vector_complex_get=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_vector_complex_get=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_vector_complex_get" >&5 $as_echo "$ac_cv_have_decl_gsl_vector_complex_get" >&6; } if test "x$ac_cv_have_decl_gsl_vector_complex_get" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_vector_complex_get in -lgsl" >&5 $as_echo_n "checking for gsl_vector_complex_get in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_vector_complex_get+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_vector_complex_get (); int main () { return gsl_vector_complex_get (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_vector_complex_get=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_vector_complex_get=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_vector_complex_get" >&5 $as_echo "$ac_cv_lib_gsl_gsl_vector_complex_get" >&6; } if test "x$ac_cv_lib_gsl_gsl_vector_complex_get" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_vector_complex_isnull is declared" >&5 $as_echo_n "checking whether gsl_vector_complex_isnull is declared... " >&6; } if test "${ac_cv_have_decl_gsl_vector_complex_isnull+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_vector_complex_isnull (void) gsl_vector_complex_isnull; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_vector_complex_isnull=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_vector_complex_isnull=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_vector_complex_isnull" >&5 $as_echo "$ac_cv_have_decl_gsl_vector_complex_isnull" >&6; } if test "x$ac_cv_have_decl_gsl_vector_complex_isnull" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_vector_complex_isnull in -lgsl" >&5 $as_echo_n "checking for gsl_vector_complex_isnull in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_vector_complex_isnull+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_vector_complex_isnull (); int main () { return gsl_vector_complex_isnull (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_vector_complex_isnull=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_vector_complex_isnull=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_vector_complex_isnull" >&5 $as_echo "$ac_cv_lib_gsl_gsl_vector_complex_isnull" >&6; } if test "x$ac_cv_lib_gsl_gsl_vector_complex_isnull" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_vector_complex_set is declared" >&5 $as_echo_n "checking whether gsl_vector_complex_set is declared... " >&6; } if test "${ac_cv_have_decl_gsl_vector_complex_set+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_vector_complex_set (void) gsl_vector_complex_set; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_vector_complex_set=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_vector_complex_set=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_vector_complex_set" >&5 $as_echo "$ac_cv_have_decl_gsl_vector_complex_set" >&6; } if test "x$ac_cv_have_decl_gsl_vector_complex_set" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_vector_complex_set in -lgsl" >&5 $as_echo_n "checking for gsl_vector_complex_set in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_vector_complex_set+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_vector_complex_set (); int main () { return gsl_vector_complex_set (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_vector_complex_set=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_vector_complex_set=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_vector_complex_set" >&5 $as_echo "$ac_cv_lib_gsl_gsl_vector_complex_set" >&6; } if test "x$ac_cv_lib_gsl_gsl_vector_complex_set" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_vector_complex_set_zero is declared" >&5 $as_echo_n "checking whether gsl_vector_complex_set_zero is declared... " >&6; } if test "${ac_cv_have_decl_gsl_vector_complex_set_zero+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_vector_complex_set_zero (void) gsl_vector_complex_set_zero; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_vector_complex_set_zero=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_vector_complex_set_zero=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_vector_complex_set_zero" >&5 $as_echo "$ac_cv_have_decl_gsl_vector_complex_set_zero" >&6; } if test "x$ac_cv_have_decl_gsl_vector_complex_set_zero" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_vector_complex_set_zero in -lgsl" >&5 $as_echo_n "checking for gsl_vector_complex_set_zero in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_vector_complex_set_zero+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_vector_complex_set_zero (); int main () { return gsl_vector_complex_set_zero (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_vector_complex_set_zero=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_vector_complex_set_zero=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_vector_complex_set_zero" >&5 $as_echo "$ac_cv_lib_gsl_gsl_vector_complex_set_zero" >&6; } if test "x$ac_cv_lib_gsl_gsl_vector_complex_set_zero" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_vector_free is declared" >&5 $as_echo_n "checking whether gsl_vector_free is declared... " >&6; } if test "${ac_cv_have_decl_gsl_vector_free+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_vector_free (void) gsl_vector_free; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_vector_free=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_vector_free=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_vector_free" >&5 $as_echo "$ac_cv_have_decl_gsl_vector_free" >&6; } if test "x$ac_cv_have_decl_gsl_vector_free" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_vector_free in -lgsl" >&5 $as_echo_n "checking for gsl_vector_free in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_vector_free+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_vector_free (); int main () { return gsl_vector_free (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_vector_free=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_vector_free=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_vector_free" >&5 $as_echo "$ac_cv_lib_gsl_gsl_vector_free" >&6; } if test "x$ac_cv_lib_gsl_gsl_vector_free" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_vector_get is declared" >&5 $as_echo_n "checking whether gsl_vector_get is declared... " >&6; } if test "${ac_cv_have_decl_gsl_vector_get+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_vector_get (void) gsl_vector_get; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_vector_get=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_vector_get=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_vector_get" >&5 $as_echo "$ac_cv_have_decl_gsl_vector_get" >&6; } if test "x$ac_cv_have_decl_gsl_vector_get" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_vector_get in -lgsl" >&5 $as_echo_n "checking for gsl_vector_get in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_vector_get+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_vector_get (); int main () { return gsl_vector_get (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_vector_get=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_vector_get=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_vector_get" >&5 $as_echo "$ac_cv_lib_gsl_gsl_vector_get" >&6; } if test "x$ac_cv_lib_gsl_gsl_vector_get" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_vector_isnull is declared" >&5 $as_echo_n "checking whether gsl_vector_isnull is declared... " >&6; } if test "${ac_cv_have_decl_gsl_vector_isnull+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_vector_isnull (void) gsl_vector_isnull; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_vector_isnull=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_vector_isnull=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_vector_isnull" >&5 $as_echo "$ac_cv_have_decl_gsl_vector_isnull" >&6; } if test "x$ac_cv_have_decl_gsl_vector_isnull" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_vector_isnull in -lgsl" >&5 $as_echo_n "checking for gsl_vector_isnull in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_vector_isnull+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_vector_isnull (); int main () { return gsl_vector_isnull (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_vector_isnull=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_vector_isnull=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_vector_isnull" >&5 $as_echo "$ac_cv_lib_gsl_gsl_vector_isnull" >&6; } if test "x$ac_cv_lib_gsl_gsl_vector_isnull" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_vector_scale is declared" >&5 $as_echo_n "checking whether gsl_vector_scale is declared... " >&6; } if test "${ac_cv_have_decl_gsl_vector_scale+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_vector_scale (void) gsl_vector_scale; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_vector_scale=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_vector_scale=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_vector_scale" >&5 $as_echo "$ac_cv_have_decl_gsl_vector_scale" >&6; } if test "x$ac_cv_have_decl_gsl_vector_scale" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_vector_scale in -lgsl" >&5 $as_echo_n "checking for gsl_vector_scale in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_vector_scale+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_vector_scale (); int main () { return gsl_vector_scale (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_vector_scale=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_vector_scale=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_vector_scale" >&5 $as_echo "$ac_cv_lib_gsl_gsl_vector_scale" >&6; } if test "x$ac_cv_lib_gsl_gsl_vector_scale" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_vector_set is declared" >&5 $as_echo_n "checking whether gsl_vector_set is declared... " >&6; } if test "${ac_cv_have_decl_gsl_vector_set+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_vector_set (void) gsl_vector_set; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_vector_set=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_vector_set=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_vector_set" >&5 $as_echo "$ac_cv_have_decl_gsl_vector_set" >&6; } if test "x$ac_cv_have_decl_gsl_vector_set" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_vector_set in -lgsl" >&5 $as_echo_n "checking for gsl_vector_set in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_vector_set+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_vector_set (); int main () { return gsl_vector_set (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_vector_set=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_vector_set=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_vector_set" >&5 $as_echo "$ac_cv_lib_gsl_gsl_vector_set" >&6; } if test "x$ac_cv_lib_gsl_gsl_vector_set" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_vector_set_zero is declared" >&5 $as_echo_n "checking whether gsl_vector_set_zero is declared... " >&6; } if test "${ac_cv_have_decl_gsl_vector_set_zero+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_vector_set_zero (void) gsl_vector_set_zero; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_vector_set_zero=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_vector_set_zero=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_vector_set_zero" >&5 $as_echo "$ac_cv_have_decl_gsl_vector_set_zero" >&6; } if test "x$ac_cv_have_decl_gsl_vector_set_zero" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_vector_set_zero in -lgsl" >&5 $as_echo_n "checking for gsl_vector_set_zero in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_vector_set_zero+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_vector_set_zero (); int main () { return gsl_vector_set_zero (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_vector_set_zero=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_vector_set_zero=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_vector_set_zero" >&5 $as_echo "$ac_cv_lib_gsl_gsl_vector_set_zero" >&6; } if test "x$ac_cv_lib_gsl_gsl_vector_set_zero" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_vector_sub is declared" >&5 $as_echo_n "checking whether gsl_vector_sub is declared... " >&6; } if test "${ac_cv_have_decl_gsl_vector_sub+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_vector_sub (void) gsl_vector_sub; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_vector_sub=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_vector_sub=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_vector_sub" >&5 $as_echo "$ac_cv_have_decl_gsl_vector_sub" >&6; } if test "x$ac_cv_have_decl_gsl_vector_sub" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_vector_sub in -lgsl" >&5 $as_echo_n "checking for gsl_vector_sub in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_vector_sub+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_vector_sub (); int main () { return gsl_vector_sub (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_vector_sub=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_vector_sub=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_vector_sub" >&5 $as_echo "$ac_cv_lib_gsl_gsl_vector_sub" >&6; } if test "x$ac_cv_lib_gsl_gsl_vector_sub" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi fi if test "x$enable_gsl" = "xyes"; then { $as_echo "$as_me:$LINENO: checking for gsl_blas_ddot in -lgsl" >&5 $as_echo_n "checking for gsl_blas_ddot in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_blas_ddot+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_blas_ddot (); int main () { return gsl_blas_ddot (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_blas_ddot=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_blas_ddot=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_blas_ddot" >&5 $as_echo "$ac_cv_lib_gsl_gsl_blas_ddot" >&6; } if test "x$ac_cv_lib_gsl_gsl_blas_ddot" = x""yes; then cat >>confdefs.h <<_ACEOF #define HAVE_LIBGSL 1 _ACEOF LIBS="-lgsl $LIBS" fi cat >>confdefs.h <<\_ACEOF #define HAVE_GNU_GSL 1 _ACEOF fi fi if test "x$enable_parallel" = "xyes"; then { $as_echo "$as_me:$LINENO: POSIX pthreads..." >&5 $as_echo "$as_me: POSIX pthreads..." >&6;} for ac_header in pthread.h do as_ac_Header=`$as_echo "ac_cv_header_$ac_header" | $as_tr_sh` if { as_var=$as_ac_Header; eval "test \"\${$as_var+set}\" = set"; }; then { $as_echo "$as_me:$LINENO: checking for $ac_header" >&5 $as_echo_n "checking for $ac_header... " >&6; } if { as_var=$as_ac_Header; eval "test \"\${$as_var+set}\" = set"; }; then $as_echo_n "(cached) " >&6 fi ac_res=`eval 'as_val=${'$as_ac_Header'} $as_echo "$as_val"'` { $as_echo "$as_me:$LINENO: result: $ac_res" >&5 $as_echo "$ac_res" >&6; } else # Is the header compilable? { $as_echo "$as_me:$LINENO: checking $ac_header usability" >&5 $as_echo_n "checking $ac_header usability... " >&6; } cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ $ac_includes_default #include <$ac_header> _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_header_compiler=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_header_compiler=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext { $as_echo "$as_me:$LINENO: result: $ac_header_compiler" >&5 $as_echo "$ac_header_compiler" >&6; } # Is the header present? { $as_echo "$as_me:$LINENO: checking $ac_header presence" >&5 $as_echo_n "checking $ac_header presence... " >&6; } cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include <$ac_header> _ACEOF if { (ac_try="$ac_cpp conftest.$ac_ext" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_cpp conftest.$ac_ext") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } >/dev/null && { test -z "$ac_c_preproc_warn_flag$ac_c_werror_flag" || test ! -s conftest.err }; then ac_header_preproc=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_header_preproc=no fi rm -f conftest.err conftest.$ac_ext { $as_echo "$as_me:$LINENO: result: $ac_header_preproc" >&5 $as_echo "$ac_header_preproc" >&6; } # So? What about this header? case $ac_header_compiler:$ac_header_preproc:$ac_c_preproc_warn_flag in yes:no: ) { $as_echo "$as_me:$LINENO: WARNING: $ac_header: accepted by the compiler, rejected by the preprocessor!" >&5 $as_echo "$as_me: WARNING: $ac_header: accepted by the compiler, rejected by the preprocessor!" >&2;} { $as_echo "$as_me:$LINENO: WARNING: $ac_header: proceeding with the compiler's result" >&5 $as_echo "$as_me: WARNING: $ac_header: proceeding with the compiler's result" >&2;} ac_header_preproc=yes ;; no:yes:* ) { $as_echo "$as_me:$LINENO: WARNING: $ac_header: present but cannot be compiled" >&5 $as_echo "$as_me: WARNING: $ac_header: present but cannot be compiled" >&2;} { $as_echo "$as_me:$LINENO: WARNING: $ac_header: check for missing prerequisite headers?" >&5 $as_echo "$as_me: WARNING: $ac_header: check for missing prerequisite headers?" >&2;} { $as_echo "$as_me:$LINENO: WARNING: $ac_header: see the Autoconf documentation" >&5 $as_echo "$as_me: WARNING: $ac_header: see the Autoconf documentation" >&2;} { $as_echo "$as_me:$LINENO: WARNING: $ac_header: section \"Present But Cannot Be Compiled\"" >&5 $as_echo "$as_me: WARNING: $ac_header: section \"Present But Cannot Be Compiled\"" >&2;} { $as_echo "$as_me:$LINENO: WARNING: $ac_header: proceeding with the preprocessor's result" >&5 $as_echo "$as_me: WARNING: $ac_header: proceeding with the preprocessor's result" >&2;} { $as_echo "$as_me:$LINENO: WARNING: $ac_header: in the future, the compiler will take precedence" >&5 $as_echo "$as_me: WARNING: $ac_header: in the future, the compiler will take precedence" >&2;} ( cat <<\_ASBOX ## ------------------------------------------------------- ## ## Report this to Marcel van der Veer ## ## ------------------------------------------------------- ## _ASBOX ) | sed "s/^/$as_me: WARNING: /" >&2 ;; esac { $as_echo "$as_me:$LINENO: checking for $ac_header" >&5 $as_echo_n "checking for $ac_header... " >&6; } if { as_var=$as_ac_Header; eval "test \"\${$as_var+set}\" = set"; }; then $as_echo_n "(cached) " >&6 else eval "$as_ac_Header=\$ac_header_preproc" fi ac_res=`eval 'as_val=${'$as_ac_Header'} $as_echo "$as_val"'` { $as_echo "$as_me:$LINENO: result: $ac_res" >&5 $as_echo "$ac_res" >&6; } fi as_val=`eval 'as_val=${'$as_ac_Header'} $as_echo "$as_val"'` if test "x$as_val" = x""yes; then cat >>confdefs.h <<_ACEOF #define `$as_echo "HAVE_$ac_header" | $as_tr_cpp` 1 _ACEOF else enable_parallel=no fi done { $as_echo "$as_me:$LINENO: checking whether pthread_attr_getstacksize is declared" >&5 $as_echo_n "checking whether pthread_attr_getstacksize is declared... " >&6; } if test "${ac_cv_have_decl_pthread_attr_getstacksize+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include int main () { #ifndef pthread_attr_getstacksize (void) pthread_attr_getstacksize; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_pthread_attr_getstacksize=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_pthread_attr_getstacksize=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_pthread_attr_getstacksize" >&5 $as_echo "$ac_cv_have_decl_pthread_attr_getstacksize" >&6; } if test "x$ac_cv_have_decl_pthread_attr_getstacksize" = x""yes; then : else enable_parallel=no fi { $as_echo "$as_me:$LINENO: checking for pthread_attr_getstacksize in -lpthread" >&5 $as_echo_n "checking for pthread_attr_getstacksize in -lpthread... " >&6; } if test "${ac_cv_lib_pthread_pthread_attr_getstacksize+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lpthread $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char pthread_attr_getstacksize (); int main () { return pthread_attr_getstacksize (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_pthread_pthread_attr_getstacksize=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_pthread_pthread_attr_getstacksize=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_pthread_pthread_attr_getstacksize" >&5 $as_echo "$ac_cv_lib_pthread_pthread_attr_getstacksize" >&6; } if test "x$ac_cv_lib_pthread_pthread_attr_getstacksize" = x""yes; then a68g_unexpected=yes else enable_parallel=no fi if test "x$enable_parallel" = "xyes"; then { $as_echo "$as_me:$LINENO: checking whether pthread_attr_init is declared" >&5 $as_echo_n "checking whether pthread_attr_init is declared... " >&6; } if test "${ac_cv_have_decl_pthread_attr_init+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include int main () { #ifndef pthread_attr_init (void) pthread_attr_init; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_pthread_attr_init=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_pthread_attr_init=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_pthread_attr_init" >&5 $as_echo "$ac_cv_have_decl_pthread_attr_init" >&6; } if test "x$ac_cv_have_decl_pthread_attr_init" = x""yes; then : else enable_parallel=no fi { $as_echo "$as_me:$LINENO: checking for pthread_attr_init in -lpthread" >&5 $as_echo_n "checking for pthread_attr_init in -lpthread... " >&6; } if test "${ac_cv_lib_pthread_pthread_attr_init+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lpthread $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char pthread_attr_init (); int main () { return pthread_attr_init (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_pthread_pthread_attr_init=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_pthread_pthread_attr_init=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_pthread_pthread_attr_init" >&5 $as_echo "$ac_cv_lib_pthread_pthread_attr_init" >&6; } if test "x$ac_cv_lib_pthread_pthread_attr_init" = x""yes; then a68g_unexpected=yes else enable_parallel=no fi { $as_echo "$as_me:$LINENO: checking whether pthread_attr_setstacksize is declared" >&5 $as_echo_n "checking whether pthread_attr_setstacksize is declared... " >&6; } if test "${ac_cv_have_decl_pthread_attr_setstacksize+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include int main () { #ifndef pthread_attr_setstacksize (void) pthread_attr_setstacksize; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_pthread_attr_setstacksize=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_pthread_attr_setstacksize=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_pthread_attr_setstacksize" >&5 $as_echo "$ac_cv_have_decl_pthread_attr_setstacksize" >&6; } if test "x$ac_cv_have_decl_pthread_attr_setstacksize" = x""yes; then : else enable_parallel=no fi { $as_echo "$as_me:$LINENO: checking for pthread_attr_setstacksize in -lpthread" >&5 $as_echo_n "checking for pthread_attr_setstacksize in -lpthread... " >&6; } if test "${ac_cv_lib_pthread_pthread_attr_setstacksize+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lpthread $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char pthread_attr_setstacksize (); int main () { return pthread_attr_setstacksize (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_pthread_pthread_attr_setstacksize=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_pthread_pthread_attr_setstacksize=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_pthread_pthread_attr_setstacksize" >&5 $as_echo "$ac_cv_lib_pthread_pthread_attr_setstacksize" >&6; } if test "x$ac_cv_lib_pthread_pthread_attr_setstacksize" = x""yes; then a68g_unexpected=yes else enable_parallel=no fi { $as_echo "$as_me:$LINENO: checking whether pthread_create is declared" >&5 $as_echo_n "checking whether pthread_create is declared... " >&6; } if test "${ac_cv_have_decl_pthread_create+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include int main () { #ifndef pthread_create (void) pthread_create; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_pthread_create=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_pthread_create=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_pthread_create" >&5 $as_echo "$ac_cv_have_decl_pthread_create" >&6; } if test "x$ac_cv_have_decl_pthread_create" = x""yes; then : else enable_parallel=no fi { $as_echo "$as_me:$LINENO: checking for pthread_create in -lpthread" >&5 $as_echo_n "checking for pthread_create in -lpthread... " >&6; } if test "${ac_cv_lib_pthread_pthread_create+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lpthread $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char pthread_create (); int main () { return pthread_create (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_pthread_pthread_create=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_pthread_pthread_create=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_pthread_pthread_create" >&5 $as_echo "$ac_cv_lib_pthread_pthread_create" >&6; } if test "x$ac_cv_lib_pthread_pthread_create" = x""yes; then a68g_unexpected=yes else enable_parallel=no fi { $as_echo "$as_me:$LINENO: checking whether pthread_equal is declared" >&5 $as_echo_n "checking whether pthread_equal is declared... " >&6; } if test "${ac_cv_have_decl_pthread_equal+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include int main () { #ifndef pthread_equal (void) pthread_equal; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_pthread_equal=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_pthread_equal=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_pthread_equal" >&5 $as_echo "$ac_cv_have_decl_pthread_equal" >&6; } if test "x$ac_cv_have_decl_pthread_equal" = x""yes; then : else enable_parallel=no fi { $as_echo "$as_me:$LINENO: checking for pthread_equal in -lpthread" >&5 $as_echo_n "checking for pthread_equal in -lpthread... " >&6; } if test "${ac_cv_lib_pthread_pthread_equal+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lpthread $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char pthread_equal (); int main () { return pthread_equal (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_pthread_pthread_equal=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_pthread_pthread_equal=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_pthread_pthread_equal" >&5 $as_echo "$ac_cv_lib_pthread_pthread_equal" >&6; } if test "x$ac_cv_lib_pthread_pthread_equal" = x""yes; then a68g_unexpected=yes else enable_parallel=no fi { $as_echo "$as_me:$LINENO: checking whether pthread_exit is declared" >&5 $as_echo_n "checking whether pthread_exit is declared... " >&6; } if test "${ac_cv_have_decl_pthread_exit+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include int main () { #ifndef pthread_exit (void) pthread_exit; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_pthread_exit=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_pthread_exit=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_pthread_exit" >&5 $as_echo "$ac_cv_have_decl_pthread_exit" >&6; } if test "x$ac_cv_have_decl_pthread_exit" = x""yes; then : else enable_parallel=no fi { $as_echo "$as_me:$LINENO: checking for pthread_exit in -lpthread" >&5 $as_echo_n "checking for pthread_exit in -lpthread... " >&6; } if test "${ac_cv_lib_pthread_pthread_exit+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lpthread $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char pthread_exit (); int main () { return pthread_exit (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_pthread_pthread_exit=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_pthread_pthread_exit=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_pthread_pthread_exit" >&5 $as_echo "$ac_cv_lib_pthread_pthread_exit" >&6; } if test "x$ac_cv_lib_pthread_pthread_exit" = x""yes; then a68g_unexpected=yes else enable_parallel=no fi { $as_echo "$as_me:$LINENO: checking whether pthread_join is declared" >&5 $as_echo_n "checking whether pthread_join is declared... " >&6; } if test "${ac_cv_have_decl_pthread_join+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include int main () { #ifndef pthread_join (void) pthread_join; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_pthread_join=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_pthread_join=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_pthread_join" >&5 $as_echo "$ac_cv_have_decl_pthread_join" >&6; } if test "x$ac_cv_have_decl_pthread_join" = x""yes; then : else enable_parallel=no fi { $as_echo "$as_me:$LINENO: checking for pthread_join in -lpthread" >&5 $as_echo_n "checking for pthread_join in -lpthread... " >&6; } if test "${ac_cv_lib_pthread_pthread_join+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lpthread $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char pthread_join (); int main () { return pthread_join (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_pthread_pthread_join=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_pthread_pthread_join=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_pthread_pthread_join" >&5 $as_echo "$ac_cv_lib_pthread_pthread_join" >&6; } if test "x$ac_cv_lib_pthread_pthread_join" = x""yes; then a68g_unexpected=yes else enable_parallel=no fi { $as_echo "$as_me:$LINENO: checking whether pthread_mutex_lock is declared" >&5 $as_echo_n "checking whether pthread_mutex_lock is declared... " >&6; } if test "${ac_cv_have_decl_pthread_mutex_lock+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include int main () { #ifndef pthread_mutex_lock (void) pthread_mutex_lock; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_pthread_mutex_lock=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_pthread_mutex_lock=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_pthread_mutex_lock" >&5 $as_echo "$ac_cv_have_decl_pthread_mutex_lock" >&6; } if test "x$ac_cv_have_decl_pthread_mutex_lock" = x""yes; then : else enable_parallel=no fi { $as_echo "$as_me:$LINENO: checking for pthread_mutex_lock in -lpthread" >&5 $as_echo_n "checking for pthread_mutex_lock in -lpthread... " >&6; } if test "${ac_cv_lib_pthread_pthread_mutex_lock+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lpthread $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char pthread_mutex_lock (); int main () { return pthread_mutex_lock (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_pthread_pthread_mutex_lock=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_pthread_pthread_mutex_lock=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_pthread_pthread_mutex_lock" >&5 $as_echo "$ac_cv_lib_pthread_pthread_mutex_lock" >&6; } if test "x$ac_cv_lib_pthread_pthread_mutex_lock" = x""yes; then a68g_unexpected=yes else enable_parallel=no fi { $as_echo "$as_me:$LINENO: checking whether pthread_mutex_unlock is declared" >&5 $as_echo_n "checking whether pthread_mutex_unlock is declared... " >&6; } if test "${ac_cv_have_decl_pthread_mutex_unlock+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include int main () { #ifndef pthread_mutex_unlock (void) pthread_mutex_unlock; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_pthread_mutex_unlock=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_pthread_mutex_unlock=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_pthread_mutex_unlock" >&5 $as_echo "$ac_cv_have_decl_pthread_mutex_unlock" >&6; } if test "x$ac_cv_have_decl_pthread_mutex_unlock" = x""yes; then : else enable_parallel=no fi { $as_echo "$as_me:$LINENO: checking for pthread_mutex_unlock in -lpthread" >&5 $as_echo_n "checking for pthread_mutex_unlock in -lpthread... " >&6; } if test "${ac_cv_lib_pthread_pthread_mutex_unlock+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lpthread $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char pthread_mutex_unlock (); int main () { return pthread_mutex_unlock (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_pthread_pthread_mutex_unlock=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_pthread_pthread_mutex_unlock=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_pthread_pthread_mutex_unlock" >&5 $as_echo "$ac_cv_lib_pthread_pthread_mutex_unlock" >&6; } if test "x$ac_cv_lib_pthread_pthread_mutex_unlock" = x""yes; then a68g_unexpected=yes else enable_parallel=no fi { $as_echo "$as_me:$LINENO: checking whether pthread_self is declared" >&5 $as_echo_n "checking whether pthread_self is declared... " >&6; } if test "${ac_cv_have_decl_pthread_self+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include int main () { #ifndef pthread_self (void) pthread_self; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_pthread_self=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_pthread_self=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_pthread_self" >&5 $as_echo "$ac_cv_have_decl_pthread_self" >&6; } if test "x$ac_cv_have_decl_pthread_self" = x""yes; then : else enable_parallel=no fi { $as_echo "$as_me:$LINENO: checking for pthread_self in -lpthread" >&5 $as_echo_n "checking for pthread_self in -lpthread... " >&6; } if test "${ac_cv_lib_pthread_pthread_self+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lpthread $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char pthread_self (); int main () { return pthread_self (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_pthread_pthread_self=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_pthread_pthread_self=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_pthread_pthread_self" >&5 $as_echo "$ac_cv_lib_pthread_pthread_self" >&6; } if test "x$ac_cv_lib_pthread_pthread_self" = x""yes; then a68g_unexpected=yes else enable_parallel=no fi fi if test "x$enable_parallel" = "xyes"; then { $as_echo "$as_me:$LINENO: checking for pthread_attr_getstacksize in -lpthread" >&5 $as_echo_n "checking for pthread_attr_getstacksize in -lpthread... " >&6; } if test "${ac_cv_lib_pthread_pthread_attr_getstacksize+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lpthread $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char pthread_attr_getstacksize (); int main () { return pthread_attr_getstacksize (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_pthread_pthread_attr_getstacksize=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_pthread_pthread_attr_getstacksize=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_pthread_pthread_attr_getstacksize" >&5 $as_echo "$ac_cv_lib_pthread_pthread_attr_getstacksize" >&6; } if test "x$ac_cv_lib_pthread_pthread_attr_getstacksize" = x""yes; then cat >>confdefs.h <<_ACEOF #define HAVE_LIBPTHREAD 1 _ACEOF LIBS="-lpthread $LIBS" fi cat >>confdefs.h <<\_ACEOF #define HAVE_PARALLEL_CLAUSE 1 _ACEOF fi fi if test "x$enable_postgresql" = "xyes"; then { $as_echo "$as_me:$LINENO: PostgreSQL..." >&5 $as_echo "$as_me: PostgreSQL..." >&6;} for ac_header in libpq-fe.h do as_ac_Header=`$as_echo "ac_cv_header_$ac_header" | $as_tr_sh` if { as_var=$as_ac_Header; eval "test \"\${$as_var+set}\" = set"; }; then { $as_echo "$as_me:$LINENO: checking for $ac_header" >&5 $as_echo_n "checking for $ac_header... " >&6; } if { as_var=$as_ac_Header; eval "test \"\${$as_var+set}\" = set"; }; then $as_echo_n "(cached) " >&6 fi ac_res=`eval 'as_val=${'$as_ac_Header'} $as_echo "$as_val"'` { $as_echo "$as_me:$LINENO: result: $ac_res" >&5 $as_echo "$ac_res" >&6; } else # Is the header compilable? { $as_echo "$as_me:$LINENO: checking $ac_header usability" >&5 $as_echo_n "checking $ac_header usability... " >&6; } cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ $ac_includes_default #include <$ac_header> _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_header_compiler=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_header_compiler=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext { $as_echo "$as_me:$LINENO: result: $ac_header_compiler" >&5 $as_echo "$ac_header_compiler" >&6; } # Is the header present? { $as_echo "$as_me:$LINENO: checking $ac_header presence" >&5 $as_echo_n "checking $ac_header presence... " >&6; } cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include <$ac_header> _ACEOF if { (ac_try="$ac_cpp conftest.$ac_ext" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_cpp conftest.$ac_ext") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } >/dev/null && { test -z "$ac_c_preproc_warn_flag$ac_c_werror_flag" || test ! -s conftest.err }; then ac_header_preproc=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_header_preproc=no fi rm -f conftest.err conftest.$ac_ext { $as_echo "$as_me:$LINENO: result: $ac_header_preproc" >&5 $as_echo "$ac_header_preproc" >&6; } # So? What about this header? case $ac_header_compiler:$ac_header_preproc:$ac_c_preproc_warn_flag in yes:no: ) { $as_echo "$as_me:$LINENO: WARNING: $ac_header: accepted by the compiler, rejected by the preprocessor!" >&5 $as_echo "$as_me: WARNING: $ac_header: accepted by the compiler, rejected by the preprocessor!" >&2;} { $as_echo "$as_me:$LINENO: WARNING: $ac_header: proceeding with the compiler's result" >&5 $as_echo "$as_me: WARNING: $ac_header: proceeding with the compiler's result" >&2;} ac_header_preproc=yes ;; no:yes:* ) { $as_echo "$as_me:$LINENO: WARNING: $ac_header: present but cannot be compiled" >&5 $as_echo "$as_me: WARNING: $ac_header: present but cannot be compiled" >&2;} { $as_echo "$as_me:$LINENO: WARNING: $ac_header: check for missing prerequisite headers?" >&5 $as_echo "$as_me: WARNING: $ac_header: check for missing prerequisite headers?" >&2;} { $as_echo "$as_me:$LINENO: WARNING: $ac_header: see the Autoconf documentation" >&5 $as_echo "$as_me: WARNING: $ac_header: see the Autoconf documentation" >&2;} { $as_echo "$as_me:$LINENO: WARNING: $ac_header: section \"Present But Cannot Be Compiled\"" >&5 $as_echo "$as_me: WARNING: $ac_header: section \"Present But Cannot Be Compiled\"" >&2;} { $as_echo "$as_me:$LINENO: WARNING: $ac_header: proceeding with the preprocessor's result" >&5 $as_echo "$as_me: WARNING: $ac_header: proceeding with the preprocessor's result" >&2;} { $as_echo "$as_me:$LINENO: WARNING: $ac_header: in the future, the compiler will take precedence" >&5 $as_echo "$as_me: WARNING: $ac_header: in the future, the compiler will take precedence" >&2;} ( cat <<\_ASBOX ## ------------------------------------------------------- ## ## Report this to Marcel van der Veer ## ## ------------------------------------------------------- ## _ASBOX ) | sed "s/^/$as_me: WARNING: /" >&2 ;; esac { $as_echo "$as_me:$LINENO: checking for $ac_header" >&5 $as_echo_n "checking for $ac_header... " >&6; } if { as_var=$as_ac_Header; eval "test \"\${$as_var+set}\" = set"; }; then $as_echo_n "(cached) " >&6 else eval "$as_ac_Header=\$ac_header_preproc" fi ac_res=`eval 'as_val=${'$as_ac_Header'} $as_echo "$as_val"'` { $as_echo "$as_me:$LINENO: result: $ac_res" >&5 $as_echo "$ac_res" >&6; } fi as_val=`eval 'as_val=${'$as_ac_Header'} $as_echo "$as_val"'` if test "x$as_val" = x""yes; then cat >>confdefs.h <<_ACEOF #define `$as_echo "HAVE_$ac_header" | $as_tr_cpp` 1 _ACEOF else enable_postgresql=no fi done { $as_echo "$as_me:$LINENO: checking whether PQbackendPID is declared" >&5 $as_echo_n "checking whether PQbackendPID is declared... " >&6; } if test "${ac_cv_have_decl_PQbackendPID+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include int main () { #ifndef PQbackendPID (void) PQbackendPID; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_PQbackendPID=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_PQbackendPID=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_PQbackendPID" >&5 $as_echo "$ac_cv_have_decl_PQbackendPID" >&6; } if test "x$ac_cv_have_decl_PQbackendPID" = x""yes; then : else enable_postgresql=no fi { $as_echo "$as_me:$LINENO: checking for PQbackendPID in -lpq" >&5 $as_echo_n "checking for PQbackendPID in -lpq... " >&6; } if test "${ac_cv_lib_pq_PQbackendPID+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lpq $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char PQbackendPID (); int main () { return PQbackendPID (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_pq_PQbackendPID=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_pq_PQbackendPID=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_pq_PQbackendPID" >&5 $as_echo "$ac_cv_lib_pq_PQbackendPID" >&6; } if test "x$ac_cv_lib_pq_PQbackendPID" = x""yes; then a68g_unexpected=yes else enable_postgresql=no fi if test "x$enable_postgresql" = "xyes"; then { $as_echo "$as_me:$LINENO: checking whether PQclear is declared" >&5 $as_echo_n "checking whether PQclear is declared... " >&6; } if test "${ac_cv_have_decl_PQclear+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include int main () { #ifndef PQclear (void) PQclear; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_PQclear=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_PQclear=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_PQclear" >&5 $as_echo "$ac_cv_have_decl_PQclear" >&6; } if test "x$ac_cv_have_decl_PQclear" = x""yes; then : else enable_postgresql=no fi { $as_echo "$as_me:$LINENO: checking for PQclear in -lpq" >&5 $as_echo_n "checking for PQclear in -lpq... " >&6; } if test "${ac_cv_lib_pq_PQclear+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lpq $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char PQclear (); int main () { return PQclear (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_pq_PQclear=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_pq_PQclear=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_pq_PQclear" >&5 $as_echo "$ac_cv_lib_pq_PQclear" >&6; } if test "x$ac_cv_lib_pq_PQclear" = x""yes; then a68g_unexpected=yes else enable_postgresql=no fi { $as_echo "$as_me:$LINENO: checking whether PQcmdStatus is declared" >&5 $as_echo_n "checking whether PQcmdStatus is declared... " >&6; } if test "${ac_cv_have_decl_PQcmdStatus+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include int main () { #ifndef PQcmdStatus (void) PQcmdStatus; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_PQcmdStatus=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_PQcmdStatus=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_PQcmdStatus" >&5 $as_echo "$ac_cv_have_decl_PQcmdStatus" >&6; } if test "x$ac_cv_have_decl_PQcmdStatus" = x""yes; then : else enable_postgresql=no fi { $as_echo "$as_me:$LINENO: checking for PQcmdStatus in -lpq" >&5 $as_echo_n "checking for PQcmdStatus in -lpq... " >&6; } if test "${ac_cv_lib_pq_PQcmdStatus+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lpq $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char PQcmdStatus (); int main () { return PQcmdStatus (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_pq_PQcmdStatus=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_pq_PQcmdStatus=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_pq_PQcmdStatus" >&5 $as_echo "$ac_cv_lib_pq_PQcmdStatus" >&6; } if test "x$ac_cv_lib_pq_PQcmdStatus" = x""yes; then a68g_unexpected=yes else enable_postgresql=no fi { $as_echo "$as_me:$LINENO: checking whether PQcmdTuples is declared" >&5 $as_echo_n "checking whether PQcmdTuples is declared... " >&6; } if test "${ac_cv_have_decl_PQcmdTuples+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include int main () { #ifndef PQcmdTuples (void) PQcmdTuples; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_PQcmdTuples=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_PQcmdTuples=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_PQcmdTuples" >&5 $as_echo "$ac_cv_have_decl_PQcmdTuples" >&6; } if test "x$ac_cv_have_decl_PQcmdTuples" = x""yes; then : else enable_postgresql=no fi { $as_echo "$as_me:$LINENO: checking for PQcmdTuples in -lpq" >&5 $as_echo_n "checking for PQcmdTuples in -lpq... " >&6; } if test "${ac_cv_lib_pq_PQcmdTuples+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lpq $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char PQcmdTuples (); int main () { return PQcmdTuples (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_pq_PQcmdTuples=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_pq_PQcmdTuples=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_pq_PQcmdTuples" >&5 $as_echo "$ac_cv_lib_pq_PQcmdTuples" >&6; } if test "x$ac_cv_lib_pq_PQcmdTuples" = x""yes; then a68g_unexpected=yes else enable_postgresql=no fi { $as_echo "$as_me:$LINENO: checking whether PQconnectdb is declared" >&5 $as_echo_n "checking whether PQconnectdb is declared... " >&6; } if test "${ac_cv_have_decl_PQconnectdb+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include int main () { #ifndef PQconnectdb (void) PQconnectdb; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_PQconnectdb=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_PQconnectdb=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_PQconnectdb" >&5 $as_echo "$ac_cv_have_decl_PQconnectdb" >&6; } if test "x$ac_cv_have_decl_PQconnectdb" = x""yes; then : else enable_postgresql=no fi { $as_echo "$as_me:$LINENO: checking for PQconnectdb in -lpq" >&5 $as_echo_n "checking for PQconnectdb in -lpq... " >&6; } if test "${ac_cv_lib_pq_PQconnectdb+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lpq $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char PQconnectdb (); int main () { return PQconnectdb (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_pq_PQconnectdb=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_pq_PQconnectdb=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_pq_PQconnectdb" >&5 $as_echo "$ac_cv_lib_pq_PQconnectdb" >&6; } if test "x$ac_cv_lib_pq_PQconnectdb" = x""yes; then a68g_unexpected=yes else enable_postgresql=no fi { $as_echo "$as_me:$LINENO: checking whether PQdb is declared" >&5 $as_echo_n "checking whether PQdb is declared... " >&6; } if test "${ac_cv_have_decl_PQdb+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include int main () { #ifndef PQdb (void) PQdb; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_PQdb=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_PQdb=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_PQdb" >&5 $as_echo "$ac_cv_have_decl_PQdb" >&6; } if test "x$ac_cv_have_decl_PQdb" = x""yes; then : else enable_postgresql=no fi { $as_echo "$as_me:$LINENO: checking for PQdb in -lpq" >&5 $as_echo_n "checking for PQdb in -lpq... " >&6; } if test "${ac_cv_lib_pq_PQdb+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lpq $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char PQdb (); int main () { return PQdb (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_pq_PQdb=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_pq_PQdb=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_pq_PQdb" >&5 $as_echo "$ac_cv_lib_pq_PQdb" >&6; } if test "x$ac_cv_lib_pq_PQdb" = x""yes; then a68g_unexpected=yes else enable_postgresql=no fi { $as_echo "$as_me:$LINENO: checking whether PQerrorMessage is declared" >&5 $as_echo_n "checking whether PQerrorMessage is declared... " >&6; } if test "${ac_cv_have_decl_PQerrorMessage+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include int main () { #ifndef PQerrorMessage (void) PQerrorMessage; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_PQerrorMessage=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_PQerrorMessage=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_PQerrorMessage" >&5 $as_echo "$ac_cv_have_decl_PQerrorMessage" >&6; } if test "x$ac_cv_have_decl_PQerrorMessage" = x""yes; then : else enable_postgresql=no fi { $as_echo "$as_me:$LINENO: checking for PQerrorMessage in -lpq" >&5 $as_echo_n "checking for PQerrorMessage in -lpq... " >&6; } if test "${ac_cv_lib_pq_PQerrorMessage+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lpq $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char PQerrorMessage (); int main () { return PQerrorMessage (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_pq_PQerrorMessage=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_pq_PQerrorMessage=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_pq_PQerrorMessage" >&5 $as_echo "$ac_cv_lib_pq_PQerrorMessage" >&6; } if test "x$ac_cv_lib_pq_PQerrorMessage" = x""yes; then a68g_unexpected=yes else enable_postgresql=no fi { $as_echo "$as_me:$LINENO: checking whether PQexec is declared" >&5 $as_echo_n "checking whether PQexec is declared... " >&6; } if test "${ac_cv_have_decl_PQexec+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include int main () { #ifndef PQexec (void) PQexec; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_PQexec=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_PQexec=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_PQexec" >&5 $as_echo "$ac_cv_have_decl_PQexec" >&6; } if test "x$ac_cv_have_decl_PQexec" = x""yes; then : else enable_postgresql=no fi { $as_echo "$as_me:$LINENO: checking for PQexec in -lpq" >&5 $as_echo_n "checking for PQexec in -lpq... " >&6; } if test "${ac_cv_lib_pq_PQexec+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lpq $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char PQexec (); int main () { return PQexec (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_pq_PQexec=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_pq_PQexec=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_pq_PQexec" >&5 $as_echo "$ac_cv_lib_pq_PQexec" >&6; } if test "x$ac_cv_lib_pq_PQexec" = x""yes; then a68g_unexpected=yes else enable_postgresql=no fi { $as_echo "$as_me:$LINENO: checking whether PQfformat is declared" >&5 $as_echo_n "checking whether PQfformat is declared... " >&6; } if test "${ac_cv_have_decl_PQfformat+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include int main () { #ifndef PQfformat (void) PQfformat; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_PQfformat=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_PQfformat=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_PQfformat" >&5 $as_echo "$ac_cv_have_decl_PQfformat" >&6; } if test "x$ac_cv_have_decl_PQfformat" = x""yes; then : else enable_postgresql=no fi { $as_echo "$as_me:$LINENO: checking for PQfformat in -lpq" >&5 $as_echo_n "checking for PQfformat in -lpq... " >&6; } if test "${ac_cv_lib_pq_PQfformat+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lpq $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char PQfformat (); int main () { return PQfformat (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_pq_PQfformat=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_pq_PQfformat=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_pq_PQfformat" >&5 $as_echo "$ac_cv_lib_pq_PQfformat" >&6; } if test "x$ac_cv_lib_pq_PQfformat" = x""yes; then a68g_unexpected=yes else enable_postgresql=no fi { $as_echo "$as_me:$LINENO: checking whether PQfinish is declared" >&5 $as_echo_n "checking whether PQfinish is declared... " >&6; } if test "${ac_cv_have_decl_PQfinish+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include int main () { #ifndef PQfinish (void) PQfinish; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_PQfinish=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_PQfinish=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_PQfinish" >&5 $as_echo "$ac_cv_have_decl_PQfinish" >&6; } if test "x$ac_cv_have_decl_PQfinish" = x""yes; then : else enable_postgresql=no fi { $as_echo "$as_me:$LINENO: checking for PQfinish in -lpq" >&5 $as_echo_n "checking for PQfinish in -lpq... " >&6; } if test "${ac_cv_lib_pq_PQfinish+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lpq $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char PQfinish (); int main () { return PQfinish (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_pq_PQfinish=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_pq_PQfinish=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_pq_PQfinish" >&5 $as_echo "$ac_cv_lib_pq_PQfinish" >&6; } if test "x$ac_cv_lib_pq_PQfinish" = x""yes; then a68g_unexpected=yes else enable_postgresql=no fi { $as_echo "$as_me:$LINENO: checking whether PQfname is declared" >&5 $as_echo_n "checking whether PQfname is declared... " >&6; } if test "${ac_cv_have_decl_PQfname+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include int main () { #ifndef PQfname (void) PQfname; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_PQfname=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_PQfname=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_PQfname" >&5 $as_echo "$ac_cv_have_decl_PQfname" >&6; } if test "x$ac_cv_have_decl_PQfname" = x""yes; then : else enable_postgresql=no fi { $as_echo "$as_me:$LINENO: checking for PQfname in -lpq" >&5 $as_echo_n "checking for PQfname in -lpq... " >&6; } if test "${ac_cv_lib_pq_PQfname+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lpq $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char PQfname (); int main () { return PQfname (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_pq_PQfname=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_pq_PQfname=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_pq_PQfname" >&5 $as_echo "$ac_cv_lib_pq_PQfname" >&6; } if test "x$ac_cv_lib_pq_PQfname" = x""yes; then a68g_unexpected=yes else enable_postgresql=no fi { $as_echo "$as_me:$LINENO: checking whether PQfnumber is declared" >&5 $as_echo_n "checking whether PQfnumber is declared... " >&6; } if test "${ac_cv_have_decl_PQfnumber+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include int main () { #ifndef PQfnumber (void) PQfnumber; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_PQfnumber=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_PQfnumber=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_PQfnumber" >&5 $as_echo "$ac_cv_have_decl_PQfnumber" >&6; } if test "x$ac_cv_have_decl_PQfnumber" = x""yes; then : else enable_postgresql=no fi { $as_echo "$as_me:$LINENO: checking for PQfnumber in -lpq" >&5 $as_echo_n "checking for PQfnumber in -lpq... " >&6; } if test "${ac_cv_lib_pq_PQfnumber+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lpq $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char PQfnumber (); int main () { return PQfnumber (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_pq_PQfnumber=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_pq_PQfnumber=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_pq_PQfnumber" >&5 $as_echo "$ac_cv_lib_pq_PQfnumber" >&6; } if test "x$ac_cv_lib_pq_PQfnumber" = x""yes; then a68g_unexpected=yes else enable_postgresql=no fi { $as_echo "$as_me:$LINENO: checking whether PQgetisnull is declared" >&5 $as_echo_n "checking whether PQgetisnull is declared... " >&6; } if test "${ac_cv_have_decl_PQgetisnull+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include int main () { #ifndef PQgetisnull (void) PQgetisnull; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_PQgetisnull=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_PQgetisnull=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_PQgetisnull" >&5 $as_echo "$ac_cv_have_decl_PQgetisnull" >&6; } if test "x$ac_cv_have_decl_PQgetisnull" = x""yes; then : else enable_postgresql=no fi { $as_echo "$as_me:$LINENO: checking for PQgetisnull in -lpq" >&5 $as_echo_n "checking for PQgetisnull in -lpq... " >&6; } if test "${ac_cv_lib_pq_PQgetisnull+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lpq $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char PQgetisnull (); int main () { return PQgetisnull (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_pq_PQgetisnull=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_pq_PQgetisnull=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_pq_PQgetisnull" >&5 $as_echo "$ac_cv_lib_pq_PQgetisnull" >&6; } if test "x$ac_cv_lib_pq_PQgetisnull" = x""yes; then a68g_unexpected=yes else enable_postgresql=no fi { $as_echo "$as_me:$LINENO: checking whether PQgetvalue is declared" >&5 $as_echo_n "checking whether PQgetvalue is declared... " >&6; } if test "${ac_cv_have_decl_PQgetvalue+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include int main () { #ifndef PQgetvalue (void) PQgetvalue; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_PQgetvalue=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_PQgetvalue=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_PQgetvalue" >&5 $as_echo "$ac_cv_have_decl_PQgetvalue" >&6; } if test "x$ac_cv_have_decl_PQgetvalue" = x""yes; then : else enable_postgresql=no fi { $as_echo "$as_me:$LINENO: checking for PQgetvalue in -lpq" >&5 $as_echo_n "checking for PQgetvalue in -lpq... " >&6; } if test "${ac_cv_lib_pq_PQgetvalue+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lpq $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char PQgetvalue (); int main () { return PQgetvalue (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_pq_PQgetvalue=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_pq_PQgetvalue=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_pq_PQgetvalue" >&5 $as_echo "$ac_cv_lib_pq_PQgetvalue" >&6; } if test "x$ac_cv_lib_pq_PQgetvalue" = x""yes; then a68g_unexpected=yes else enable_postgresql=no fi { $as_echo "$as_me:$LINENO: checking whether PQhost is declared" >&5 $as_echo_n "checking whether PQhost is declared... " >&6; } if test "${ac_cv_have_decl_PQhost+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include int main () { #ifndef PQhost (void) PQhost; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_PQhost=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_PQhost=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_PQhost" >&5 $as_echo "$ac_cv_have_decl_PQhost" >&6; } if test "x$ac_cv_have_decl_PQhost" = x""yes; then : else enable_postgresql=no fi { $as_echo "$as_me:$LINENO: checking for PQhost in -lpq" >&5 $as_echo_n "checking for PQhost in -lpq... " >&6; } if test "${ac_cv_lib_pq_PQhost+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lpq $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char PQhost (); int main () { return PQhost (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_pq_PQhost=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_pq_PQhost=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_pq_PQhost" >&5 $as_echo "$ac_cv_lib_pq_PQhost" >&6; } if test "x$ac_cv_lib_pq_PQhost" = x""yes; then a68g_unexpected=yes else enable_postgresql=no fi { $as_echo "$as_me:$LINENO: checking whether PQnfields is declared" >&5 $as_echo_n "checking whether PQnfields is declared... " >&6; } if test "${ac_cv_have_decl_PQnfields+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include int main () { #ifndef PQnfields (void) PQnfields; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_PQnfields=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_PQnfields=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_PQnfields" >&5 $as_echo "$ac_cv_have_decl_PQnfields" >&6; } if test "x$ac_cv_have_decl_PQnfields" = x""yes; then : else enable_postgresql=no fi { $as_echo "$as_me:$LINENO: checking for PQnfields in -lpq" >&5 $as_echo_n "checking for PQnfields in -lpq... " >&6; } if test "${ac_cv_lib_pq_PQnfields+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lpq $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char PQnfields (); int main () { return PQnfields (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_pq_PQnfields=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_pq_PQnfields=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_pq_PQnfields" >&5 $as_echo "$ac_cv_lib_pq_PQnfields" >&6; } if test "x$ac_cv_lib_pq_PQnfields" = x""yes; then a68g_unexpected=yes else enable_postgresql=no fi { $as_echo "$as_me:$LINENO: checking whether PQntuples is declared" >&5 $as_echo_n "checking whether PQntuples is declared... " >&6; } if test "${ac_cv_have_decl_PQntuples+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include int main () { #ifndef PQntuples (void) PQntuples; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_PQntuples=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_PQntuples=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_PQntuples" >&5 $as_echo "$ac_cv_have_decl_PQntuples" >&6; } if test "x$ac_cv_have_decl_PQntuples" = x""yes; then : else enable_postgresql=no fi { $as_echo "$as_me:$LINENO: checking for PQntuples in -lpq" >&5 $as_echo_n "checking for PQntuples in -lpq... " >&6; } if test "${ac_cv_lib_pq_PQntuples+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lpq $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char PQntuples (); int main () { return PQntuples (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_pq_PQntuples=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_pq_PQntuples=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_pq_PQntuples" >&5 $as_echo "$ac_cv_lib_pq_PQntuples" >&6; } if test "x$ac_cv_lib_pq_PQntuples" = x""yes; then a68g_unexpected=yes else enable_postgresql=no fi { $as_echo "$as_me:$LINENO: checking whether PQoptions is declared" >&5 $as_echo_n "checking whether PQoptions is declared... " >&6; } if test "${ac_cv_have_decl_PQoptions+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include int main () { #ifndef PQoptions (void) PQoptions; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_PQoptions=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_PQoptions=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_PQoptions" >&5 $as_echo "$ac_cv_have_decl_PQoptions" >&6; } if test "x$ac_cv_have_decl_PQoptions" = x""yes; then : else enable_postgresql=no fi { $as_echo "$as_me:$LINENO: checking for PQoptions in -lpq" >&5 $as_echo_n "checking for PQoptions in -lpq... " >&6; } if test "${ac_cv_lib_pq_PQoptions+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lpq $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char PQoptions (); int main () { return PQoptions (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_pq_PQoptions=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_pq_PQoptions=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_pq_PQoptions" >&5 $as_echo "$ac_cv_lib_pq_PQoptions" >&6; } if test "x$ac_cv_lib_pq_PQoptions" = x""yes; then a68g_unexpected=yes else enable_postgresql=no fi { $as_echo "$as_me:$LINENO: checking whether PQparameterStatus is declared" >&5 $as_echo_n "checking whether PQparameterStatus is declared... " >&6; } if test "${ac_cv_have_decl_PQparameterStatus+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include int main () { #ifndef PQparameterStatus (void) PQparameterStatus; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_PQparameterStatus=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_PQparameterStatus=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_PQparameterStatus" >&5 $as_echo "$ac_cv_have_decl_PQparameterStatus" >&6; } if test "x$ac_cv_have_decl_PQparameterStatus" = x""yes; then : else enable_postgresql=no fi { $as_echo "$as_me:$LINENO: checking for PQparameterStatus in -lpq" >&5 $as_echo_n "checking for PQparameterStatus in -lpq... " >&6; } if test "${ac_cv_lib_pq_PQparameterStatus+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lpq $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char PQparameterStatus (); int main () { return PQparameterStatus (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_pq_PQparameterStatus=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_pq_PQparameterStatus=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_pq_PQparameterStatus" >&5 $as_echo "$ac_cv_lib_pq_PQparameterStatus" >&6; } if test "x$ac_cv_lib_pq_PQparameterStatus" = x""yes; then a68g_unexpected=yes else enable_postgresql=no fi { $as_echo "$as_me:$LINENO: checking whether PQpass is declared" >&5 $as_echo_n "checking whether PQpass is declared... " >&6; } if test "${ac_cv_have_decl_PQpass+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include int main () { #ifndef PQpass (void) PQpass; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_PQpass=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_PQpass=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_PQpass" >&5 $as_echo "$ac_cv_have_decl_PQpass" >&6; } if test "x$ac_cv_have_decl_PQpass" = x""yes; then : else enable_postgresql=no fi { $as_echo "$as_me:$LINENO: checking for PQpass in -lpq" >&5 $as_echo_n "checking for PQpass in -lpq... " >&6; } if test "${ac_cv_lib_pq_PQpass+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lpq $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char PQpass (); int main () { return PQpass (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_pq_PQpass=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_pq_PQpass=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_pq_PQpass" >&5 $as_echo "$ac_cv_lib_pq_PQpass" >&6; } if test "x$ac_cv_lib_pq_PQpass" = x""yes; then a68g_unexpected=yes else enable_postgresql=no fi { $as_echo "$as_me:$LINENO: checking whether PQport is declared" >&5 $as_echo_n "checking whether PQport is declared... " >&6; } if test "${ac_cv_have_decl_PQport+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include int main () { #ifndef PQport (void) PQport; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_PQport=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_PQport=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_PQport" >&5 $as_echo "$ac_cv_have_decl_PQport" >&6; } if test "x$ac_cv_have_decl_PQport" = x""yes; then : else enable_postgresql=no fi { $as_echo "$as_me:$LINENO: checking for PQport in -lpq" >&5 $as_echo_n "checking for PQport in -lpq... " >&6; } if test "${ac_cv_lib_pq_PQport+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lpq $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char PQport (); int main () { return PQport (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_pq_PQport=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_pq_PQport=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_pq_PQport" >&5 $as_echo "$ac_cv_lib_pq_PQport" >&6; } if test "x$ac_cv_lib_pq_PQport" = x""yes; then a68g_unexpected=yes else enable_postgresql=no fi { $as_echo "$as_me:$LINENO: checking whether PQprotocolVersion is declared" >&5 $as_echo_n "checking whether PQprotocolVersion is declared... " >&6; } if test "${ac_cv_have_decl_PQprotocolVersion+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include int main () { #ifndef PQprotocolVersion (void) PQprotocolVersion; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_PQprotocolVersion=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_PQprotocolVersion=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_PQprotocolVersion" >&5 $as_echo "$ac_cv_have_decl_PQprotocolVersion" >&6; } if test "x$ac_cv_have_decl_PQprotocolVersion" = x""yes; then : else enable_postgresql=no fi { $as_echo "$as_me:$LINENO: checking for PQprotocolVersion in -lpq" >&5 $as_echo_n "checking for PQprotocolVersion in -lpq... " >&6; } if test "${ac_cv_lib_pq_PQprotocolVersion+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lpq $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char PQprotocolVersion (); int main () { return PQprotocolVersion (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_pq_PQprotocolVersion=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_pq_PQprotocolVersion=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_pq_PQprotocolVersion" >&5 $as_echo "$ac_cv_lib_pq_PQprotocolVersion" >&6; } if test "x$ac_cv_lib_pq_PQprotocolVersion" = x""yes; then a68g_unexpected=yes else enable_postgresql=no fi { $as_echo "$as_me:$LINENO: checking whether PQreset is declared" >&5 $as_echo_n "checking whether PQreset is declared... " >&6; } if test "${ac_cv_have_decl_PQreset+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include int main () { #ifndef PQreset (void) PQreset; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_PQreset=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_PQreset=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_PQreset" >&5 $as_echo "$ac_cv_have_decl_PQreset" >&6; } if test "x$ac_cv_have_decl_PQreset" = x""yes; then : else enable_postgresql=no fi { $as_echo "$as_me:$LINENO: checking for PQreset in -lpq" >&5 $as_echo_n "checking for PQreset in -lpq... " >&6; } if test "${ac_cv_lib_pq_PQreset+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lpq $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char PQreset (); int main () { return PQreset (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_pq_PQreset=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_pq_PQreset=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_pq_PQreset" >&5 $as_echo "$ac_cv_lib_pq_PQreset" >&6; } if test "x$ac_cv_lib_pq_PQreset" = x""yes; then a68g_unexpected=yes else enable_postgresql=no fi { $as_echo "$as_me:$LINENO: checking whether PQresultErrorMessage is declared" >&5 $as_echo_n "checking whether PQresultErrorMessage is declared... " >&6; } if test "${ac_cv_have_decl_PQresultErrorMessage+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include int main () { #ifndef PQresultErrorMessage (void) PQresultErrorMessage; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_PQresultErrorMessage=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_PQresultErrorMessage=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_PQresultErrorMessage" >&5 $as_echo "$ac_cv_have_decl_PQresultErrorMessage" >&6; } if test "x$ac_cv_have_decl_PQresultErrorMessage" = x""yes; then : else enable_postgresql=no fi { $as_echo "$as_me:$LINENO: checking for PQresultErrorMessage in -lpq" >&5 $as_echo_n "checking for PQresultErrorMessage in -lpq... " >&6; } if test "${ac_cv_lib_pq_PQresultErrorMessage+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lpq $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char PQresultErrorMessage (); int main () { return PQresultErrorMessage (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_pq_PQresultErrorMessage=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_pq_PQresultErrorMessage=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_pq_PQresultErrorMessage" >&5 $as_echo "$ac_cv_lib_pq_PQresultErrorMessage" >&6; } if test "x$ac_cv_lib_pq_PQresultErrorMessage" = x""yes; then a68g_unexpected=yes else enable_postgresql=no fi { $as_echo "$as_me:$LINENO: checking whether PQresultStatus is declared" >&5 $as_echo_n "checking whether PQresultStatus is declared... " >&6; } if test "${ac_cv_have_decl_PQresultStatus+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include int main () { #ifndef PQresultStatus (void) PQresultStatus; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_PQresultStatus=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_PQresultStatus=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_PQresultStatus" >&5 $as_echo "$ac_cv_have_decl_PQresultStatus" >&6; } if test "x$ac_cv_have_decl_PQresultStatus" = x""yes; then : else enable_postgresql=no fi { $as_echo "$as_me:$LINENO: checking for PQresultStatus in -lpq" >&5 $as_echo_n "checking for PQresultStatus in -lpq... " >&6; } if test "${ac_cv_lib_pq_PQresultStatus+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lpq $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char PQresultStatus (); int main () { return PQresultStatus (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_pq_PQresultStatus=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_pq_PQresultStatus=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_pq_PQresultStatus" >&5 $as_echo "$ac_cv_lib_pq_PQresultStatus" >&6; } if test "x$ac_cv_lib_pq_PQresultStatus" = x""yes; then a68g_unexpected=yes else enable_postgresql=no fi { $as_echo "$as_me:$LINENO: checking whether PQserverVersion is declared" >&5 $as_echo_n "checking whether PQserverVersion is declared... " >&6; } if test "${ac_cv_have_decl_PQserverVersion+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include int main () { #ifndef PQserverVersion (void) PQserverVersion; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_PQserverVersion=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_PQserverVersion=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_PQserverVersion" >&5 $as_echo "$ac_cv_have_decl_PQserverVersion" >&6; } if test "x$ac_cv_have_decl_PQserverVersion" = x""yes; then : else enable_postgresql=no fi { $as_echo "$as_me:$LINENO: checking for PQserverVersion in -lpq" >&5 $as_echo_n "checking for PQserverVersion in -lpq... " >&6; } if test "${ac_cv_lib_pq_PQserverVersion+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lpq $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char PQserverVersion (); int main () { return PQserverVersion (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_pq_PQserverVersion=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_pq_PQserverVersion=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_pq_PQserverVersion" >&5 $as_echo "$ac_cv_lib_pq_PQserverVersion" >&6; } if test "x$ac_cv_lib_pq_PQserverVersion" = x""yes; then a68g_unexpected=yes else enable_postgresql=no fi { $as_echo "$as_me:$LINENO: checking whether PQsocket is declared" >&5 $as_echo_n "checking whether PQsocket is declared... " >&6; } if test "${ac_cv_have_decl_PQsocket+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include int main () { #ifndef PQsocket (void) PQsocket; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_PQsocket=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_PQsocket=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_PQsocket" >&5 $as_echo "$ac_cv_have_decl_PQsocket" >&6; } if test "x$ac_cv_have_decl_PQsocket" = x""yes; then : else enable_postgresql=no fi { $as_echo "$as_me:$LINENO: checking for PQsocket in -lpq" >&5 $as_echo_n "checking for PQsocket in -lpq... " >&6; } if test "${ac_cv_lib_pq_PQsocket+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lpq $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char PQsocket (); int main () { return PQsocket (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_pq_PQsocket=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_pq_PQsocket=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_pq_PQsocket" >&5 $as_echo "$ac_cv_lib_pq_PQsocket" >&6; } if test "x$ac_cv_lib_pq_PQsocket" = x""yes; then a68g_unexpected=yes else enable_postgresql=no fi { $as_echo "$as_me:$LINENO: checking whether PQstatus is declared" >&5 $as_echo_n "checking whether PQstatus is declared... " >&6; } if test "${ac_cv_have_decl_PQstatus+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include int main () { #ifndef PQstatus (void) PQstatus; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_PQstatus=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_PQstatus=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_PQstatus" >&5 $as_echo "$ac_cv_have_decl_PQstatus" >&6; } if test "x$ac_cv_have_decl_PQstatus" = x""yes; then : else enable_postgresql=no fi { $as_echo "$as_me:$LINENO: checking for PQstatus in -lpq" >&5 $as_echo_n "checking for PQstatus in -lpq... " >&6; } if test "${ac_cv_lib_pq_PQstatus+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lpq $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char PQstatus (); int main () { return PQstatus (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_pq_PQstatus=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_pq_PQstatus=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_pq_PQstatus" >&5 $as_echo "$ac_cv_lib_pq_PQstatus" >&6; } if test "x$ac_cv_lib_pq_PQstatus" = x""yes; then a68g_unexpected=yes else enable_postgresql=no fi { $as_echo "$as_me:$LINENO: checking whether PQtty is declared" >&5 $as_echo_n "checking whether PQtty is declared... " >&6; } if test "${ac_cv_have_decl_PQtty+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include int main () { #ifndef PQtty (void) PQtty; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_PQtty=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_PQtty=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_PQtty" >&5 $as_echo "$ac_cv_have_decl_PQtty" >&6; } if test "x$ac_cv_have_decl_PQtty" = x""yes; then : else enable_postgresql=no fi { $as_echo "$as_me:$LINENO: checking for PQtty in -lpq" >&5 $as_echo_n "checking for PQtty in -lpq... " >&6; } if test "${ac_cv_lib_pq_PQtty+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lpq $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char PQtty (); int main () { return PQtty (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_pq_PQtty=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_pq_PQtty=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_pq_PQtty" >&5 $as_echo "$ac_cv_lib_pq_PQtty" >&6; } if test "x$ac_cv_lib_pq_PQtty" = x""yes; then a68g_unexpected=yes else enable_postgresql=no fi { $as_echo "$as_me:$LINENO: checking whether PQuser is declared" >&5 $as_echo_n "checking whether PQuser is declared... " >&6; } if test "${ac_cv_have_decl_PQuser+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include int main () { #ifndef PQuser (void) PQuser; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_PQuser=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_PQuser=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_PQuser" >&5 $as_echo "$ac_cv_have_decl_PQuser" >&6; } if test "x$ac_cv_have_decl_PQuser" = x""yes; then : else enable_postgresql=no fi { $as_echo "$as_me:$LINENO: checking for PQuser in -lpq" >&5 $as_echo_n "checking for PQuser in -lpq... " >&6; } if test "${ac_cv_lib_pq_PQuser+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lpq $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char PQuser (); int main () { return PQuser (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_pq_PQuser=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_pq_PQuser=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_pq_PQuser" >&5 $as_echo "$ac_cv_lib_pq_PQuser" >&6; } if test "x$ac_cv_lib_pq_PQuser" = x""yes; then a68g_unexpected=yes else enable_postgresql=no fi fi if test "x$enable_postgresql" = "xyes"; then { $as_echo "$as_me:$LINENO: checking for PQbackendPID in -lpq" >&5 $as_echo_n "checking for PQbackendPID in -lpq... " >&6; } if test "${ac_cv_lib_pq_PQbackendPID+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lpq $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char PQbackendPID (); int main () { return PQbackendPID (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_pq_PQbackendPID=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_pq_PQbackendPID=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_pq_PQbackendPID" >&5 $as_echo "$ac_cv_lib_pq_PQbackendPID" >&6; } if test "x$ac_cv_lib_pq_PQbackendPID" = x""yes; then cat >>confdefs.h <<_ACEOF #define HAVE_LIBPQ 1 _ACEOF LIBS="-lpq $LIBS" fi cat >>confdefs.h <<\_ACEOF #define HAVE_POSTGRESQL 1 _ACEOF fi fi if test "x$enable_compiler" = "xyes"; then { $as_echo "$as_me:$LINENO: Dynamic loader..." >&5 $as_echo "$as_me: Dynamic loader..." >&6;} for ac_header in dlfcn.h do as_ac_Header=`$as_echo "ac_cv_header_$ac_header" | $as_tr_sh` if { as_var=$as_ac_Header; eval "test \"\${$as_var+set}\" = set"; }; then { $as_echo "$as_me:$LINENO: checking for $ac_header" >&5 $as_echo_n "checking for $ac_header... " >&6; } if { as_var=$as_ac_Header; eval "test \"\${$as_var+set}\" = set"; }; then $as_echo_n "(cached) " >&6 fi ac_res=`eval 'as_val=${'$as_ac_Header'} $as_echo "$as_val"'` { $as_echo "$as_me:$LINENO: result: $ac_res" >&5 $as_echo "$ac_res" >&6; } else # Is the header compilable? { $as_echo "$as_me:$LINENO: checking $ac_header usability" >&5 $as_echo_n "checking $ac_header usability... " >&6; } cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ $ac_includes_default #include <$ac_header> _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_header_compiler=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_header_compiler=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext { $as_echo "$as_me:$LINENO: result: $ac_header_compiler" >&5 $as_echo "$ac_header_compiler" >&6; } # Is the header present? { $as_echo "$as_me:$LINENO: checking $ac_header presence" >&5 $as_echo_n "checking $ac_header presence... " >&6; } cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include <$ac_header> _ACEOF if { (ac_try="$ac_cpp conftest.$ac_ext" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_cpp conftest.$ac_ext") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } >/dev/null && { test -z "$ac_c_preproc_warn_flag$ac_c_werror_flag" || test ! -s conftest.err }; then ac_header_preproc=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_header_preproc=no fi rm -f conftest.err conftest.$ac_ext { $as_echo "$as_me:$LINENO: result: $ac_header_preproc" >&5 $as_echo "$ac_header_preproc" >&6; } # So? What about this header? case $ac_header_compiler:$ac_header_preproc:$ac_c_preproc_warn_flag in yes:no: ) { $as_echo "$as_me:$LINENO: WARNING: $ac_header: accepted by the compiler, rejected by the preprocessor!" >&5 $as_echo "$as_me: WARNING: $ac_header: accepted by the compiler, rejected by the preprocessor!" >&2;} { $as_echo "$as_me:$LINENO: WARNING: $ac_header: proceeding with the compiler's result" >&5 $as_echo "$as_me: WARNING: $ac_header: proceeding with the compiler's result" >&2;} ac_header_preproc=yes ;; no:yes:* ) { $as_echo "$as_me:$LINENO: WARNING: $ac_header: present but cannot be compiled" >&5 $as_echo "$as_me: WARNING: $ac_header: present but cannot be compiled" >&2;} { $as_echo "$as_me:$LINENO: WARNING: $ac_header: check for missing prerequisite headers?" >&5 $as_echo "$as_me: WARNING: $ac_header: check for missing prerequisite headers?" >&2;} { $as_echo "$as_me:$LINENO: WARNING: $ac_header: see the Autoconf documentation" >&5 $as_echo "$as_me: WARNING: $ac_header: see the Autoconf documentation" >&2;} { $as_echo "$as_me:$LINENO: WARNING: $ac_header: section \"Present But Cannot Be Compiled\"" >&5 $as_echo "$as_me: WARNING: $ac_header: section \"Present But Cannot Be Compiled\"" >&2;} { $as_echo "$as_me:$LINENO: WARNING: $ac_header: proceeding with the preprocessor's result" >&5 $as_echo "$as_me: WARNING: $ac_header: proceeding with the preprocessor's result" >&2;} { $as_echo "$as_me:$LINENO: WARNING: $ac_header: in the future, the compiler will take precedence" >&5 $as_echo "$as_me: WARNING: $ac_header: in the future, the compiler will take precedence" >&2;} ( cat <<\_ASBOX ## ------------------------------------------------------- ## ## Report this to Marcel van der Veer ## ## ------------------------------------------------------- ## _ASBOX ) | sed "s/^/$as_me: WARNING: /" >&2 ;; esac { $as_echo "$as_me:$LINENO: checking for $ac_header" >&5 $as_echo_n "checking for $ac_header... " >&6; } if { as_var=$as_ac_Header; eval "test \"\${$as_var+set}\" = set"; }; then $as_echo_n "(cached) " >&6 else eval "$as_ac_Header=\$ac_header_preproc" fi ac_res=`eval 'as_val=${'$as_ac_Header'} $as_echo "$as_val"'` { $as_echo "$as_me:$LINENO: result: $ac_res" >&5 $as_echo "$ac_res" >&6; } fi as_val=`eval 'as_val=${'$as_ac_Header'} $as_echo "$as_val"'` if test "x$as_val" = x""yes; then cat >>confdefs.h <<_ACEOF #define `$as_echo "HAVE_$ac_header" | $as_tr_cpp` 1 _ACEOF fi done { $as_echo "$as_me:$LINENO: checking whether dlopen is declared" >&5 $as_echo_n "checking whether dlopen is declared... " >&6; } if test "${ac_cv_have_decl_dlopen+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include int main () { #ifndef dlopen (void) dlopen; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_dlopen=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_dlopen=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_dlopen" >&5 $as_echo "$ac_cv_have_decl_dlopen" >&6; } if test "x$ac_cv_have_decl_dlopen" = x""yes; then : else enable_compiler=no fi { $as_echo "$as_me:$LINENO: checking for dlopen in -ldl" >&5 $as_echo_n "checking for dlopen in -ldl... " >&6; } if test "${ac_cv_lib_dl_dlopen+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-ldl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char dlopen (); int main () { return dlopen (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_dl_dlopen=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_dl_dlopen=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_dl_dlopen" >&5 $as_echo "$ac_cv_lib_dl_dlopen" >&6; } if test "x$ac_cv_lib_dl_dlopen" = x""yes; then a68g_unexpected=yes else enable_compiler=no fi if test "x$enable_compiler" = "xyes"; then { $as_echo "$as_me:$LINENO: checking whether dlsym is declared" >&5 $as_echo_n "checking whether dlsym is declared... " >&6; } if test "${ac_cv_have_decl_dlsym+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include int main () { #ifndef dlsym (void) dlsym; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_dlsym=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_dlsym=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_dlsym" >&5 $as_echo "$ac_cv_have_decl_dlsym" >&6; } if test "x$ac_cv_have_decl_dlsym" = x""yes; then : else enable_compiler=no fi { $as_echo "$as_me:$LINENO: checking for dlsym in -ldl" >&5 $as_echo_n "checking for dlsym in -ldl... " >&6; } if test "${ac_cv_lib_dl_dlsym+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-ldl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char dlsym (); int main () { return dlsym (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_dl_dlsym=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_dl_dlsym=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_dl_dlsym" >&5 $as_echo "$ac_cv_lib_dl_dlsym" >&6; } if test "x$ac_cv_lib_dl_dlsym" = x""yes; then a68g_unexpected=yes else enable_compiler=no fi { $as_echo "$as_me:$LINENO: checking whether dlerror is declared" >&5 $as_echo_n "checking whether dlerror is declared... " >&6; } if test "${ac_cv_have_decl_dlerror+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include int main () { #ifndef dlerror (void) dlerror; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_dlerror=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_dlerror=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_dlerror" >&5 $as_echo "$ac_cv_have_decl_dlerror" >&6; } if test "x$ac_cv_have_decl_dlerror" = x""yes; then : else enable_compiler=no fi { $as_echo "$as_me:$LINENO: checking for dlerror in -ldl" >&5 $as_echo_n "checking for dlerror in -ldl... " >&6; } if test "${ac_cv_lib_dl_dlerror+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-ldl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char dlerror (); int main () { return dlerror (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_dl_dlerror=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_dl_dlerror=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_dl_dlerror" >&5 $as_echo "$ac_cv_lib_dl_dlerror" >&6; } if test "x$ac_cv_lib_dl_dlerror" = x""yes; then a68g_unexpected=yes else enable_compiler=no fi { $as_echo "$as_me:$LINENO: checking whether dlclose is declared" >&5 $as_echo_n "checking whether dlclose is declared... " >&6; } if test "${ac_cv_have_decl_dlclose+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include int main () { #ifndef dlclose (void) dlclose; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_dlclose=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_dlclose=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_dlclose" >&5 $as_echo "$ac_cv_have_decl_dlclose" >&6; } if test "x$ac_cv_have_decl_dlclose" = x""yes; then : else enable_compiler=no fi { $as_echo "$as_me:$LINENO: checking for dlclose in -ldl" >&5 $as_echo_n "checking for dlclose in -ldl... " >&6; } if test "${ac_cv_lib_dl_dlclose+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-ldl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char dlclose (); int main () { return dlclose (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_dl_dlclose=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_dl_dlclose=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_dl_dlclose" >&5 $as_echo "$ac_cv_lib_dl_dlclose" >&6; } if test "x$ac_cv_lib_dl_dlclose" = x""yes; then a68g_unexpected=yes else enable_compiler=no fi fi if test "x$enable_compiler" = "xyes"; then { $as_echo "$as_me:$LINENO: checking for dlopen in -ldl" >&5 $as_echo_n "checking for dlopen in -ldl... " >&6; } if test "${ac_cv_lib_dl_dlopen+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-ldl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char dlopen (); int main () { return dlopen (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_dl_dlopen=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_dl_dlopen=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_dl_dlopen" >&5 $as_echo "$ac_cv_lib_dl_dlopen" >&6; } if test "x$ac_cv_lib_dl_dlopen" = x""yes; then cat >>confdefs.h <<_ACEOF #define HAVE_LIBDL 1 _ACEOF LIBS="-ldl $LIBS" fi cat >>confdefs.h <<\_ACEOF #define HAVE_DL 1 _ACEOF fi fi # # Generate files. # ac_config_files="$ac_config_files Makefile" cat >confcache <<\_ACEOF # This file is a shell script that caches the results of configure # tests run on this system so they can be shared between configure # scripts and configure runs, see configure's option --config-cache. # It is not useful on other systems. If it contains results you don't # want to keep, you may remove or edit it. # # config.status only pays attention to the cache file if you give it # the --recheck option to rerun configure. # # `ac_cv_env_foo' variables (set or unset) will be overridden when # loading this file, other *unset* `ac_cv_foo' will be assigned the # following values. _ACEOF # The following way of writing the cache mishandles newlines in values, # but we know of no workaround that is simple, portable, and efficient. # So, we kill variables containing newlines. # Ultrix sh set writes to stderr and can't be redirected directly, # and sets the high bit in the cache file unless we assign to the vars. ( for ac_var in `(set) 2>&1 | sed -n 's/^\([a-zA-Z_][a-zA-Z0-9_]*\)=.*/\1/p'`; do eval ac_val=\$$ac_var case $ac_val in #( *${as_nl}*) case $ac_var in #( *_cv_*) { $as_echo "$as_me:$LINENO: WARNING: cache variable $ac_var contains a newline" >&5 $as_echo "$as_me: WARNING: cache variable $ac_var contains a newline" >&2;} ;; esac case $ac_var in #( _ | IFS | as_nl) ;; #( BASH_ARGV | BASH_SOURCE) eval $ac_var= ;; #( *) $as_unset $ac_var ;; esac ;; esac done (set) 2>&1 | case $as_nl`(ac_space=' '; set) 2>&1` in #( *${as_nl}ac_space=\ *) # `set' does not quote correctly, so add quotes (double-quote # substitution turns \\\\ into \\, and sed turns \\ into \). sed -n \ "s/'/'\\\\''/g; s/^\\([_$as_cr_alnum]*_cv_[_$as_cr_alnum]*\\)=\\(.*\\)/\\1='\\2'/p" ;; #( *) # `set' quotes correctly as required by POSIX, so do not add quotes. sed -n "/^[_$as_cr_alnum]*_cv_[_$as_cr_alnum]*=/p" ;; esac | sort ) | sed ' /^ac_cv_env_/b end t clear :clear s/^\([^=]*\)=\(.*[{}].*\)$/test "${\1+set}" = set || &/ t end s/^\([^=]*\)=\(.*\)$/\1=${\1=\2}/ :end' >>confcache if diff "$cache_file" confcache >/dev/null 2>&1; then :; else if test -w "$cache_file"; then test "x$cache_file" != "x/dev/null" && { $as_echo "$as_me:$LINENO: updating cache $cache_file" >&5 $as_echo "$as_me: updating cache $cache_file" >&6;} cat confcache >$cache_file else { $as_echo "$as_me:$LINENO: not updating unwritable cache $cache_file" >&5 $as_echo "$as_me: not updating unwritable cache $cache_file" >&6;} fi fi rm -f confcache test "x$prefix" = xNONE && prefix=$ac_default_prefix # Let make expand exec_prefix. test "x$exec_prefix" = xNONE && exec_prefix='${prefix}' DEFS=-DHAVE_CONFIG_H ac_libobjs= ac_ltlibobjs= for ac_i in : $LIBOBJS; do test "x$ac_i" = x: && continue # 1. Remove the extension, and $U if already installed. ac_script='s/\$U\././;s/\.o$//;s/\.obj$//' ac_i=`$as_echo "$ac_i" | sed "$ac_script"` # 2. Prepend LIBOBJDIR. When used with automake>=1.10 LIBOBJDIR # will be set to the directory where LIBOBJS objects are built. ac_libobjs="$ac_libobjs \${LIBOBJDIR}$ac_i\$U.$ac_objext" ac_ltlibobjs="$ac_ltlibobjs \${LIBOBJDIR}$ac_i"'$U.lo' done LIBOBJS=$ac_libobjs LTLIBOBJS=$ac_ltlibobjs if test -z "${AMDEP_TRUE}" && test -z "${AMDEP_FALSE}"; then { { $as_echo "$as_me:$LINENO: error: conditional \"AMDEP\" was never defined. Usually this means the macro was only invoked conditionally." >&5 $as_echo "$as_me: error: conditional \"AMDEP\" was never defined. Usually this means the macro was only invoked conditionally." >&2;} { (exit 1); exit 1; }; } fi if test -z "${am__fastdepCC_TRUE}" && test -z "${am__fastdepCC_FALSE}"; then { { $as_echo "$as_me:$LINENO: error: conditional \"am__fastdepCC\" was never defined. Usually this means the macro was only invoked conditionally." >&5 $as_echo "$as_me: error: conditional \"am__fastdepCC\" was never defined. Usually this means the macro was only invoked conditionally." >&2;} { (exit 1); exit 1; }; } fi if test -z "${EXPORT_DYNAMIC_TRUE}" && test -z "${EXPORT_DYNAMIC_FALSE}"; then { { $as_echo "$as_me:$LINENO: error: conditional \"EXPORT_DYNAMIC\" was never defined. Usually this means the macro was only invoked conditionally." >&5 $as_echo "$as_me: error: conditional \"EXPORT_DYNAMIC\" was never defined. Usually this means the macro was only invoked conditionally." >&2;} { (exit 1); exit 1; }; } fi : ${CONFIG_STATUS=./config.status} ac_write_fail=0 ac_clean_files_save=$ac_clean_files ac_clean_files="$ac_clean_files $CONFIG_STATUS" { $as_echo "$as_me:$LINENO: creating $CONFIG_STATUS" >&5 $as_echo "$as_me: creating $CONFIG_STATUS" >&6;} cat >$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 #! $SHELL # Generated by $as_me. # Run this file to recreate the current configuration. # Compiler output produced by configure, useful for debugging # configure, is in config.log if it exists. debug=false ac_cs_recheck=false ac_cs_silent=false SHELL=\${CONFIG_SHELL-$SHELL} _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 ## --------------------- ## ## M4sh Initialization. ## ## --------------------- ## # Be more Bourne compatible DUALCASE=1; export DUALCASE # for MKS sh if test -n "${ZSH_VERSION+set}" && (emulate sh) >/dev/null 2>&1; then emulate sh NULLCMD=: # Pre-4.2 versions of Zsh do word splitting on ${1+"$@"}, which # is contrary to our usage. Disable this feature. alias -g '${1+"$@"}'='"$@"' setopt NO_GLOB_SUBST else case `(set -o) 2>/dev/null` in *posix*) set -o posix ;; esac fi # PATH needs CR # Avoid depending upon Character Ranges. as_cr_letters='abcdefghijklmnopqrstuvwxyz' as_cr_LETTERS='ABCDEFGHIJKLMNOPQRSTUVWXYZ' as_cr_Letters=$as_cr_letters$as_cr_LETTERS as_cr_digits='0123456789' as_cr_alnum=$as_cr_Letters$as_cr_digits as_nl=' ' export as_nl # Printing a long string crashes Solaris 7 /usr/bin/printf. as_echo='\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\' as_echo=$as_echo$as_echo$as_echo$as_echo$as_echo as_echo=$as_echo$as_echo$as_echo$as_echo$as_echo$as_echo if (test "X`printf %s $as_echo`" = "X$as_echo") 2>/dev/null; then as_echo='printf %s\n' as_echo_n='printf %s' else if test "X`(/usr/ucb/echo -n -n $as_echo) 2>/dev/null`" = "X-n $as_echo"; then as_echo_body='eval /usr/ucb/echo -n "$1$as_nl"' as_echo_n='/usr/ucb/echo -n' else as_echo_body='eval expr "X$1" : "X\\(.*\\)"' as_echo_n_body='eval arg=$1; case $arg in *"$as_nl"*) expr "X$arg" : "X\\(.*\\)$as_nl"; arg=`expr "X$arg" : ".*$as_nl\\(.*\\)"`;; esac; expr "X$arg" : "X\\(.*\\)" | tr -d "$as_nl" ' export as_echo_n_body as_echo_n='sh -c $as_echo_n_body as_echo' fi export as_echo_body as_echo='sh -c $as_echo_body as_echo' fi # The user is always right. if test "${PATH_SEPARATOR+set}" != set; then PATH_SEPARATOR=: (PATH='/bin;/bin'; FPATH=$PATH; sh -c :) >/dev/null 2>&1 && { (PATH='/bin:/bin'; FPATH=$PATH; sh -c :) >/dev/null 2>&1 || PATH_SEPARATOR=';' } fi # Support unset when possible. if ( (MAIL=60; unset MAIL) || exit) >/dev/null 2>&1; then as_unset=unset else as_unset=false fi # IFS # We need space, tab and new line, in precisely that order. Quoting is # there to prevent editors from complaining about space-tab. # (If _AS_PATH_WALK were called with IFS unset, it would disable word # splitting by setting IFS to empty value.) IFS=" "" $as_nl" # Find who we are. Look in the path if we contain no directory separator. case $0 in *[\\/]* ) as_myself=$0 ;; *) as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. test -r "$as_dir/$0" && as_myself=$as_dir/$0 && break done IFS=$as_save_IFS ;; esac # We did not find ourselves, most probably we were run as `sh COMMAND' # in which case we are not to be found in the path. if test "x$as_myself" = x; then as_myself=$0 fi if test ! -f "$as_myself"; then $as_echo "$as_myself: error: cannot find myself; rerun with an absolute file name" >&2 { (exit 1); exit 1; } fi # Work around bugs in pre-3.0 UWIN ksh. for as_var in ENV MAIL MAILPATH do ($as_unset $as_var) >/dev/null 2>&1 && $as_unset $as_var done PS1='$ ' PS2='> ' PS4='+ ' # NLS nuisances. LC_ALL=C export LC_ALL LANGUAGE=C export LANGUAGE # Required to use basename. if expr a : '\(a\)' >/dev/null 2>&1 && test "X`expr 00001 : '.*\(...\)'`" = X001; then as_expr=expr else as_expr=false fi if (basename -- /) >/dev/null 2>&1 && test "X`basename -- / 2>&1`" = "X/"; then as_basename=basename else as_basename=false fi # Name of the executable. as_me=`$as_basename -- "$0" || $as_expr X/"$0" : '.*/\([^/][^/]*\)/*$' \| \ X"$0" : 'X\(//\)$' \| \ X"$0" : 'X\(/\)' \| . 2>/dev/null || $as_echo X/"$0" | sed '/^.*\/\([^/][^/]*\)\/*$/{ s//\1/ q } /^X\/\(\/\/\)$/{ s//\1/ q } /^X\/\(\/\).*/{ s//\1/ q } s/.*/./; q'` # CDPATH. $as_unset CDPATH as_lineno_1=$LINENO as_lineno_2=$LINENO test "x$as_lineno_1" != "x$as_lineno_2" && test "x`expr $as_lineno_1 + 1`" = "x$as_lineno_2" || { # Create $as_me.lineno as a copy of $as_myself, but with $LINENO # uniformly replaced by the line number. The first 'sed' inserts a # line-number line after each line using $LINENO; the second 'sed' # does the real work. The second script uses 'N' to pair each # line-number line with the line containing $LINENO, and appends # trailing '-' during substitution so that $LINENO is not a special # case at line end. # (Raja R Harinath suggested sed '=', and Paul Eggert wrote the # scripts with optimization help from Paolo Bonzini. Blame Lee # E. McMahon (1931-1989) for sed's syntax. :-) sed -n ' p /[$]LINENO/= ' <$as_myself | sed ' s/[$]LINENO.*/&-/ t lineno b :lineno N :loop s/[$]LINENO\([^'$as_cr_alnum'_].*\n\)\(.*\)/\2\1\2/ t loop s/-\n.*// ' >$as_me.lineno && chmod +x "$as_me.lineno" || { $as_echo "$as_me: error: cannot create $as_me.lineno; rerun with a POSIX shell" >&2 { (exit 1); exit 1; }; } # Don't try to exec as it changes $[0], causing all sort of problems # (the dirname of $[0] is not the place where we might find the # original and so on. Autoconf is especially sensitive to this). . "./$as_me.lineno" # Exit status is that of the last command. exit } if (as_dir=`dirname -- /` && test "X$as_dir" = X/) >/dev/null 2>&1; then as_dirname=dirname else as_dirname=false fi ECHO_C= ECHO_N= ECHO_T= case `echo -n x` in -n*) case `echo 'x\c'` in *c*) ECHO_T=' ';; # ECHO_T is single tab character. *) ECHO_C='\c';; esac;; *) ECHO_N='-n';; esac if expr a : '\(a\)' >/dev/null 2>&1 && test "X`expr 00001 : '.*\(...\)'`" = X001; then as_expr=expr else as_expr=false fi rm -f conf$$ conf$$.exe conf$$.file if test -d conf$$.dir; then rm -f conf$$.dir/conf$$.file else rm -f conf$$.dir mkdir conf$$.dir 2>/dev/null fi if (echo >conf$$.file) 2>/dev/null; then if ln -s conf$$.file conf$$ 2>/dev/null; then as_ln_s='ln -s' # ... but there are two gotchas: # 1) On MSYS, both `ln -s file dir' and `ln file dir' fail. # 2) DJGPP < 2.04 has no symlinks; `ln -s' creates a wrapper executable. # In both cases, we have to default to `cp -p'. ln -s conf$$.file conf$$.dir 2>/dev/null && test ! -f conf$$.exe || as_ln_s='cp -p' elif ln conf$$.file conf$$ 2>/dev/null; then as_ln_s=ln else as_ln_s='cp -p' fi else as_ln_s='cp -p' fi rm -f conf$$ conf$$.exe conf$$.dir/conf$$.file conf$$.file rmdir conf$$.dir 2>/dev/null if mkdir -p . 2>/dev/null; then as_mkdir_p=: else test -d ./-p && rmdir ./-p as_mkdir_p=false fi if test -x / >/dev/null 2>&1; then as_test_x='test -x' else if ls -dL / >/dev/null 2>&1; then as_ls_L_option=L else as_ls_L_option= fi as_test_x=' eval sh -c '\'' if test -d "$1"; then test -d "$1/."; else case $1 in -*)set "./$1";; esac; case `ls -ld'$as_ls_L_option' "$1" 2>/dev/null` in ???[sx]*):;;*)false;;esac;fi '\'' sh ' fi as_executable_p=$as_test_x # Sed expression to map a string onto a valid CPP name. as_tr_cpp="eval sed 'y%*$as_cr_letters%P$as_cr_LETTERS%;s%[^_$as_cr_alnum]%_%g'" # Sed expression to map a string onto a valid variable name. as_tr_sh="eval sed 'y%*+%pp%;s%[^_$as_cr_alnum]%_%g'" exec 6>&1 # Save the log message, to keep $[0] and so on meaningful, and to # report actual input values of CONFIG_FILES etc. instead of their # values after options handling. ac_log=" This file was extended by algol68g $as_me 2.4.1, which was generated by GNU Autoconf 2.63. Invocation command line was CONFIG_FILES = $CONFIG_FILES CONFIG_HEADERS = $CONFIG_HEADERS CONFIG_LINKS = $CONFIG_LINKS CONFIG_COMMANDS = $CONFIG_COMMANDS $ $0 $@ on `(hostname || uname -n) 2>/dev/null | sed 1q` " _ACEOF case $ac_config_files in *" "*) set x $ac_config_files; shift; ac_config_files=$*;; esac case $ac_config_headers in *" "*) set x $ac_config_headers; shift; ac_config_headers=$*;; esac cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 # Files that config.status was made for. config_files="$ac_config_files" config_headers="$ac_config_headers" config_commands="$ac_config_commands" _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 ac_cs_usage="\ \`$as_me' instantiates files from templates according to the current configuration. Usage: $0 [OPTION]... [FILE]... -h, --help print this help, then exit -V, --version print version number and configuration settings, then exit -q, --quiet, --silent do not print progress messages -d, --debug don't remove temporary files --recheck update $as_me by reconfiguring in the same conditions --file=FILE[:TEMPLATE] instantiate the configuration file FILE --header=FILE[:TEMPLATE] instantiate the configuration header FILE Configuration files: $config_files Configuration headers: $config_headers Configuration commands: $config_commands Report bugs to ." _ACEOF cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 ac_cs_version="\\ algol68g config.status 2.4.1 configured by $0, generated by GNU Autoconf 2.63, with options \\"`$as_echo "$ac_configure_args" | sed 's/^ //; s/[\\""\`\$]/\\\\&/g'`\\" Copyright (C) 2008 Free Software Foundation, Inc. This config.status script is free software; the Free Software Foundation gives unlimited permission to copy, distribute and modify it." ac_pwd='$ac_pwd' srcdir='$srcdir' INSTALL='$INSTALL' MKDIR_P='$MKDIR_P' AWK='$AWK' test -n "\$AWK" || AWK=awk _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 # The default lists apply if the user does not specify any file. ac_need_defaults=: while test $# != 0 do case $1 in --*=*) ac_option=`expr "X$1" : 'X\([^=]*\)='` ac_optarg=`expr "X$1" : 'X[^=]*=\(.*\)'` ac_shift=: ;; *) ac_option=$1 ac_optarg=$2 ac_shift=shift ;; esac case $ac_option in # Handling of the options. -recheck | --recheck | --rechec | --reche | --rech | --rec | --re | --r) ac_cs_recheck=: ;; --version | --versio | --versi | --vers | --ver | --ve | --v | -V ) $as_echo "$ac_cs_version"; exit ;; --debug | --debu | --deb | --de | --d | -d ) debug=: ;; --file | --fil | --fi | --f ) $ac_shift case $ac_optarg in *\'*) ac_optarg=`$as_echo "$ac_optarg" | sed "s/'/'\\\\\\\\''/g"` ;; esac CONFIG_FILES="$CONFIG_FILES '$ac_optarg'" ac_need_defaults=false;; --header | --heade | --head | --hea ) $ac_shift case $ac_optarg in *\'*) ac_optarg=`$as_echo "$ac_optarg" | sed "s/'/'\\\\\\\\''/g"` ;; esac CONFIG_HEADERS="$CONFIG_HEADERS '$ac_optarg'" ac_need_defaults=false;; --he | --h) # Conflict between --help and --header { $as_echo "$as_me: error: ambiguous option: $1 Try \`$0 --help' for more information." >&2 { (exit 1); exit 1; }; };; --help | --hel | -h ) $as_echo "$ac_cs_usage"; exit ;; -q | -quiet | --quiet | --quie | --qui | --qu | --q \ | -silent | --silent | --silen | --sile | --sil | --si | --s) ac_cs_silent=: ;; # This is an error. -*) { $as_echo "$as_me: error: unrecognized option: $1 Try \`$0 --help' for more information." >&2 { (exit 1); exit 1; }; } ;; *) ac_config_targets="$ac_config_targets $1" ac_need_defaults=false ;; esac shift done ac_configure_extra_args= if $ac_cs_silent; then exec 6>/dev/null ac_configure_extra_args="$ac_configure_extra_args --silent" fi _ACEOF cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 if \$ac_cs_recheck; then set X '$SHELL' '$0' $ac_configure_args \$ac_configure_extra_args --no-create --no-recursion shift \$as_echo "running CONFIG_SHELL=$SHELL \$*" >&6 CONFIG_SHELL='$SHELL' export CONFIG_SHELL exec "\$@" fi _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 exec 5>>config.log { echo sed 'h;s/./-/g;s/^.../## /;s/...$/ ##/;p;x;p;x' <<_ASBOX ## Running $as_me. ## _ASBOX $as_echo "$ac_log" } >&5 _ACEOF cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 # # INIT-COMMANDS # AMDEP_TRUE="$AMDEP_TRUE" ac_aux_dir="$ac_aux_dir" _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 # Handling of arguments. for ac_config_target in $ac_config_targets do case $ac_config_target in "source/a68g-config.h") CONFIG_HEADERS="$CONFIG_HEADERS source/a68g-config.h" ;; "depfiles") CONFIG_COMMANDS="$CONFIG_COMMANDS depfiles" ;; "Makefile") CONFIG_FILES="$CONFIG_FILES Makefile" ;; *) { { $as_echo "$as_me:$LINENO: error: invalid argument: $ac_config_target" >&5 $as_echo "$as_me: error: invalid argument: $ac_config_target" >&2;} { (exit 1); exit 1; }; };; esac done # If the user did not use the arguments to specify the items to instantiate, # then the envvar interface is used. Set only those that are not. # We use the long form for the default assignment because of an extremely # bizarre bug on SunOS 4.1.3. if $ac_need_defaults; then test "${CONFIG_FILES+set}" = set || CONFIG_FILES=$config_files test "${CONFIG_HEADERS+set}" = set || CONFIG_HEADERS=$config_headers test "${CONFIG_COMMANDS+set}" = set || CONFIG_COMMANDS=$config_commands fi # Have a temporary directory for convenience. Make it in the build tree # simply because there is no reason against having it here, and in addition, # creating and moving files from /tmp can sometimes cause problems. # Hook for its removal unless debugging. # Note that there is a small window in which the directory will not be cleaned: # after its creation but before its name has been assigned to `$tmp'. $debug || { tmp= trap 'exit_status=$? { test -z "$tmp" || test ! -d "$tmp" || rm -fr "$tmp"; } && exit $exit_status ' 0 trap '{ (exit 1); exit 1; }' 1 2 13 15 } # Create a (secure) tmp directory for tmp files. { tmp=`(umask 077 && mktemp -d "./confXXXXXX") 2>/dev/null` && test -n "$tmp" && test -d "$tmp" } || { tmp=./conf$$-$RANDOM (umask 077 && mkdir "$tmp") } || { $as_echo "$as_me: cannot create a temporary directory in ." >&2 { (exit 1); exit 1; } } # Set up the scripts for CONFIG_FILES section. # No need to generate them if there are no CONFIG_FILES. # This happens for instance with `./config.status config.h'. if test -n "$CONFIG_FILES"; then ac_cr=' ' ac_cs_awk_cr=`$AWK 'BEGIN { print "a\rb" }' /dev/null` if test "$ac_cs_awk_cr" = "a${ac_cr}b"; then ac_cs_awk_cr='\\r' else ac_cs_awk_cr=$ac_cr fi echo 'BEGIN {' >"$tmp/subs1.awk" && _ACEOF { echo "cat >conf$$subs.awk <<_ACEOF" && echo "$ac_subst_vars" | sed 's/.*/&!$&$ac_delim/' && echo "_ACEOF" } >conf$$subs.sh || { { $as_echo "$as_me:$LINENO: error: could not make $CONFIG_STATUS" >&5 $as_echo "$as_me: error: could not make $CONFIG_STATUS" >&2;} { (exit 1); exit 1; }; } ac_delim_num=`echo "$ac_subst_vars" | grep -c '$'` ac_delim='%!_!# ' for ac_last_try in false false false false false :; do . ./conf$$subs.sh || { { $as_echo "$as_me:$LINENO: error: could not make $CONFIG_STATUS" >&5 $as_echo "$as_me: error: could not make $CONFIG_STATUS" >&2;} { (exit 1); exit 1; }; } ac_delim_n=`sed -n "s/.*$ac_delim\$/X/p" conf$$subs.awk | grep -c X` if test $ac_delim_n = $ac_delim_num; then break elif $ac_last_try; then { { $as_echo "$as_me:$LINENO: error: could not make $CONFIG_STATUS" >&5 $as_echo "$as_me: error: could not make $CONFIG_STATUS" >&2;} { (exit 1); exit 1; }; } else ac_delim="$ac_delim!$ac_delim _$ac_delim!! " fi done rm -f conf$$subs.sh cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 cat >>"\$tmp/subs1.awk" <<\\_ACAWK && _ACEOF sed -n ' h s/^/S["/; s/!.*/"]=/ p g s/^[^!]*!// :repl t repl s/'"$ac_delim"'$// t delim :nl h s/\(.\{148\}\).*/\1/ t more1 s/["\\]/\\&/g; s/^/"/; s/$/\\n"\\/ p n b repl :more1 s/["\\]/\\&/g; s/^/"/; s/$/"\\/ p g s/.\{148\}// t nl :delim h s/\(.\{148\}\).*/\1/ t more2 s/["\\]/\\&/g; s/^/"/; s/$/"/ p b :more2 s/["\\]/\\&/g; s/^/"/; s/$/"\\/ p g s/.\{148\}// t delim ' >$CONFIG_STATUS || ac_write_fail=1 rm -f conf$$subs.awk cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 _ACAWK cat >>"\$tmp/subs1.awk" <<_ACAWK && for (key in S) S_is_set[key] = 1 FS = "" } { line = $ 0 nfields = split(line, field, "@") substed = 0 len = length(field[1]) for (i = 2; i < nfields; i++) { key = field[i] keylen = length(key) if (S_is_set[key]) { value = S[key] line = substr(line, 1, len) "" value "" substr(line, len + keylen + 3) len += length(value) + length(field[++i]) substed = 1 } else len += 1 + keylen } print line } _ACAWK _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 if sed "s/$ac_cr//" < /dev/null > /dev/null 2>&1; then sed "s/$ac_cr\$//; s/$ac_cr/$ac_cs_awk_cr/g" else cat fi < "$tmp/subs1.awk" > "$tmp/subs.awk" \ || { { $as_echo "$as_me:$LINENO: error: could not setup config files machinery" >&5 $as_echo "$as_me: error: could not setup config files machinery" >&2;} { (exit 1); exit 1; }; } _ACEOF # VPATH may cause trouble with some makes, so we remove $(srcdir), # ${srcdir} and @srcdir@ from VPATH if srcdir is ".", strip leading and # trailing colons and then remove the whole line if VPATH becomes empty # (actually we leave an empty line to preserve line numbers). if test "x$srcdir" = x.; then ac_vpsub='/^[ ]*VPATH[ ]*=/{ s/:*\$(srcdir):*/:/ s/:*\${srcdir}:*/:/ s/:*@srcdir@:*/:/ s/^\([^=]*=[ ]*\):*/\1/ s/:*$// s/^[^=]*=[ ]*$// }' fi cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 fi # test -n "$CONFIG_FILES" # Set up the scripts for CONFIG_HEADERS section. # No need to generate them if there are no CONFIG_HEADERS. # This happens for instance with `./config.status Makefile'. if test -n "$CONFIG_HEADERS"; then cat >"$tmp/defines.awk" <<\_ACAWK || BEGIN { _ACEOF # Transform confdefs.h into an awk script `defines.awk', embedded as # here-document in config.status, that substitutes the proper values into # config.h.in to produce config.h. # Create a delimiter string that does not exist in confdefs.h, to ease # handling of long lines. ac_delim='%!_!# ' for ac_last_try in false false :; do ac_t=`sed -n "/$ac_delim/p" confdefs.h` if test -z "$ac_t"; then break elif $ac_last_try; then { { $as_echo "$as_me:$LINENO: error: could not make $CONFIG_HEADERS" >&5 $as_echo "$as_me: error: could not make $CONFIG_HEADERS" >&2;} { (exit 1); exit 1; }; } else ac_delim="$ac_delim!$ac_delim _$ac_delim!! " fi done # For the awk script, D is an array of macro values keyed by name, # likewise P contains macro parameters if any. Preserve backslash # newline sequences. ac_word_re=[_$as_cr_Letters][_$as_cr_alnum]* sed -n ' s/.\{148\}/&'"$ac_delim"'/g t rset :rset s/^[ ]*#[ ]*define[ ][ ]*/ / t def d :def s/\\$// t bsnl s/["\\]/\\&/g s/^ \('"$ac_word_re"'\)\(([^()]*)\)[ ]*\(.*\)/P["\1"]="\2"\ D["\1"]=" \3"/p s/^ \('"$ac_word_re"'\)[ ]*\(.*\)/D["\1"]=" \2"/p d :bsnl s/["\\]/\\&/g s/^ \('"$ac_word_re"'\)\(([^()]*)\)[ ]*\(.*\)/P["\1"]="\2"\ D["\1"]=" \3\\\\\\n"\\/p t cont s/^ \('"$ac_word_re"'\)[ ]*\(.*\)/D["\1"]=" \2\\\\\\n"\\/p t cont d :cont n s/.\{148\}/&'"$ac_delim"'/g t clear :clear s/\\$// t bsnlc s/["\\]/\\&/g; s/^/"/; s/$/"/p d :bsnlc s/["\\]/\\&/g; s/^/"/; s/$/\\\\\\n"\\/p b cont ' >$CONFIG_STATUS || ac_write_fail=1 cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 for (key in D) D_is_set[key] = 1 FS = "" } /^[\t ]*#[\t ]*(define|undef)[\t ]+$ac_word_re([\t (]|\$)/ { line = \$ 0 split(line, arg, " ") if (arg[1] == "#") { defundef = arg[2] mac1 = arg[3] } else { defundef = substr(arg[1], 2) mac1 = arg[2] } split(mac1, mac2, "(") #) macro = mac2[1] prefix = substr(line, 1, index(line, defundef) - 1) if (D_is_set[macro]) { # Preserve the white space surrounding the "#". print prefix "define", macro P[macro] D[macro] next } else { # Replace #undef with comments. This is necessary, for example, # in the case of _POSIX_SOURCE, which is predefined and required # on some systems where configure will not decide to define it. if (defundef == "undef") { print "/*", prefix defundef, macro, "*/" next } } } { print } _ACAWK _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 { { $as_echo "$as_me:$LINENO: error: could not setup config headers machinery" >&5 $as_echo "$as_me: error: could not setup config headers machinery" >&2;} { (exit 1); exit 1; }; } fi # test -n "$CONFIG_HEADERS" eval set X " :F $CONFIG_FILES :H $CONFIG_HEADERS :C $CONFIG_COMMANDS" shift for ac_tag do case $ac_tag in :[FHLC]) ac_mode=$ac_tag; continue;; esac case $ac_mode$ac_tag in :[FHL]*:*);; :L* | :C*:*) { { $as_echo "$as_me:$LINENO: error: invalid tag $ac_tag" >&5 $as_echo "$as_me: error: invalid tag $ac_tag" >&2;} { (exit 1); exit 1; }; };; :[FH]-) ac_tag=-:-;; :[FH]*) ac_tag=$ac_tag:$ac_tag.in;; esac ac_save_IFS=$IFS IFS=: set x $ac_tag IFS=$ac_save_IFS shift ac_file=$1 shift case $ac_mode in :L) ac_source=$1;; :[FH]) ac_file_inputs= for ac_f do case $ac_f in -) ac_f="$tmp/stdin";; *) # Look for the file first in the build tree, then in the source tree # (if the path is not absolute). The absolute path cannot be DOS-style, # because $ac_f cannot contain `:'. test -f "$ac_f" || case $ac_f in [\\/$]*) false;; *) test -f "$srcdir/$ac_f" && ac_f="$srcdir/$ac_f";; esac || { { $as_echo "$as_me:$LINENO: error: cannot find input file: $ac_f" >&5 $as_echo "$as_me: error: cannot find input file: $ac_f" >&2;} { (exit 1); exit 1; }; };; esac case $ac_f in *\'*) ac_f=`$as_echo "$ac_f" | sed "s/'/'\\\\\\\\''/g"`;; esac ac_file_inputs="$ac_file_inputs '$ac_f'" done # Let's still pretend it is `configure' which instantiates (i.e., don't # use $as_me), people would be surprised to read: # /* config.h. Generated by config.status. */ configure_input='Generated from '` $as_echo "$*" | sed 's|^[^:]*/||;s|:[^:]*/|, |g' `' by configure.' if test x"$ac_file" != x-; then configure_input="$ac_file. $configure_input" { $as_echo "$as_me:$LINENO: creating $ac_file" >&5 $as_echo "$as_me: creating $ac_file" >&6;} fi # Neutralize special characters interpreted by sed in replacement strings. case $configure_input in #( *\&* | *\|* | *\\* ) ac_sed_conf_input=`$as_echo "$configure_input" | sed 's/[\\\\&|]/\\\\&/g'`;; #( *) ac_sed_conf_input=$configure_input;; esac case $ac_tag in *:-:* | *:-) cat >"$tmp/stdin" \ || { { $as_echo "$as_me:$LINENO: error: could not create $ac_file" >&5 $as_echo "$as_me: error: could not create $ac_file" >&2;} { (exit 1); exit 1; }; } ;; esac ;; esac ac_dir=`$as_dirname -- "$ac_file" || $as_expr X"$ac_file" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ X"$ac_file" : 'X\(//\)[^/]' \| \ X"$ac_file" : 'X\(//\)$' \| \ X"$ac_file" : 'X\(/\)' \| . 2>/dev/null || $as_echo X"$ac_file" | sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ s//\1/ q } /^X\(\/\/\)[^/].*/{ s//\1/ q } /^X\(\/\/\)$/{ s//\1/ q } /^X\(\/\).*/{ s//\1/ q } s/.*/./; q'` { as_dir="$ac_dir" case $as_dir in #( -*) as_dir=./$as_dir;; esac test -d "$as_dir" || { $as_mkdir_p && mkdir -p "$as_dir"; } || { as_dirs= while :; do case $as_dir in #( *\'*) as_qdir=`$as_echo "$as_dir" | sed "s/'/'\\\\\\\\''/g"`;; #'( *) as_qdir=$as_dir;; esac as_dirs="'$as_qdir' $as_dirs" as_dir=`$as_dirname -- "$as_dir" || $as_expr X"$as_dir" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ X"$as_dir" : 'X\(//\)[^/]' \| \ X"$as_dir" : 'X\(//\)$' \| \ X"$as_dir" : 'X\(/\)' \| . 2>/dev/null || $as_echo X"$as_dir" | sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ s//\1/ q } /^X\(\/\/\)[^/].*/{ s//\1/ q } /^X\(\/\/\)$/{ s//\1/ q } /^X\(\/\).*/{ s//\1/ q } s/.*/./; q'` test -d "$as_dir" && break done test -z "$as_dirs" || eval "mkdir $as_dirs" } || test -d "$as_dir" || { { $as_echo "$as_me:$LINENO: error: cannot create directory $as_dir" >&5 $as_echo "$as_me: error: cannot create directory $as_dir" >&2;} { (exit 1); exit 1; }; }; } ac_builddir=. case "$ac_dir" in .) ac_dir_suffix= ac_top_builddir_sub=. ac_top_build_prefix= ;; *) ac_dir_suffix=/`$as_echo "$ac_dir" | sed 's|^\.[\\/]||'` # A ".." for each directory in $ac_dir_suffix. ac_top_builddir_sub=`$as_echo "$ac_dir_suffix" | sed 's|/[^\\/]*|/..|g;s|/||'` case $ac_top_builddir_sub in "") ac_top_builddir_sub=. ac_top_build_prefix= ;; *) ac_top_build_prefix=$ac_top_builddir_sub/ ;; esac ;; esac ac_abs_top_builddir=$ac_pwd ac_abs_builddir=$ac_pwd$ac_dir_suffix # for backward compatibility: ac_top_builddir=$ac_top_build_prefix case $srcdir in .) # We are building in place. ac_srcdir=. ac_top_srcdir=$ac_top_builddir_sub ac_abs_top_srcdir=$ac_pwd ;; [\\/]* | ?:[\\/]* ) # Absolute name. ac_srcdir=$srcdir$ac_dir_suffix; ac_top_srcdir=$srcdir ac_abs_top_srcdir=$srcdir ;; *) # Relative name. ac_srcdir=$ac_top_build_prefix$srcdir$ac_dir_suffix ac_top_srcdir=$ac_top_build_prefix$srcdir ac_abs_top_srcdir=$ac_pwd/$srcdir ;; esac ac_abs_srcdir=$ac_abs_top_srcdir$ac_dir_suffix case $ac_mode in :F) # # CONFIG_FILE # case $INSTALL in [\\/$]* | ?:[\\/]* ) ac_INSTALL=$INSTALL ;; *) ac_INSTALL=$ac_top_build_prefix$INSTALL ;; esac ac_MKDIR_P=$MKDIR_P case $MKDIR_P in [\\/$]* | ?:[\\/]* ) ;; */*) ac_MKDIR_P=$ac_top_build_prefix$MKDIR_P ;; esac _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 # If the template does not know about datarootdir, expand it. # FIXME: This hack should be removed a few years after 2.60. ac_datarootdir_hack=; ac_datarootdir_seen= ac_sed_dataroot=' /datarootdir/ { p q } /@datadir@/p /@docdir@/p /@infodir@/p /@localedir@/p /@mandir@/p ' case `eval "sed -n \"\$ac_sed_dataroot\" $ac_file_inputs"` in *datarootdir*) ac_datarootdir_seen=yes;; *@datadir@*|*@docdir@*|*@infodir@*|*@localedir@*|*@mandir@*) { $as_echo "$as_me:$LINENO: WARNING: $ac_file_inputs seems to ignore the --datarootdir setting" >&5 $as_echo "$as_me: WARNING: $ac_file_inputs seems to ignore the --datarootdir setting" >&2;} _ACEOF cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 ac_datarootdir_hack=' s&@datadir@&$datadir&g s&@docdir@&$docdir&g s&@infodir@&$infodir&g s&@localedir@&$localedir&g s&@mandir@&$mandir&g s&\\\${datarootdir}&$datarootdir&g' ;; esac _ACEOF # Neutralize VPATH when `$srcdir' = `.'. # Shell code in configure.ac might set extrasub. # FIXME: do we really want to maintain this feature? cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 ac_sed_extra="$ac_vpsub $extrasub _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 :t /@[a-zA-Z_][a-zA-Z_0-9]*@/!b s|@configure_input@|$ac_sed_conf_input|;t t s&@top_builddir@&$ac_top_builddir_sub&;t t s&@top_build_prefix@&$ac_top_build_prefix&;t t s&@srcdir@&$ac_srcdir&;t t s&@abs_srcdir@&$ac_abs_srcdir&;t t s&@top_srcdir@&$ac_top_srcdir&;t t s&@abs_top_srcdir@&$ac_abs_top_srcdir&;t t s&@builddir@&$ac_builddir&;t t s&@abs_builddir@&$ac_abs_builddir&;t t s&@abs_top_builddir@&$ac_abs_top_builddir&;t t s&@INSTALL@&$ac_INSTALL&;t t s&@MKDIR_P@&$ac_MKDIR_P&;t t $ac_datarootdir_hack " eval sed \"\$ac_sed_extra\" "$ac_file_inputs" | $AWK -f "$tmp/subs.awk" >$tmp/out \ || { { $as_echo "$as_me:$LINENO: error: could not create $ac_file" >&5 $as_echo "$as_me: error: could not create $ac_file" >&2;} { (exit 1); exit 1; }; } test -z "$ac_datarootdir_hack$ac_datarootdir_seen" && { ac_out=`sed -n '/\${datarootdir}/p' "$tmp/out"`; test -n "$ac_out"; } && { ac_out=`sed -n '/^[ ]*datarootdir[ ]*:*=/p' "$tmp/out"`; test -z "$ac_out"; } && { $as_echo "$as_me:$LINENO: WARNING: $ac_file contains a reference to the variable \`datarootdir' which seems to be undefined. Please make sure it is defined." >&5 $as_echo "$as_me: WARNING: $ac_file contains a reference to the variable \`datarootdir' which seems to be undefined. Please make sure it is defined." >&2;} rm -f "$tmp/stdin" case $ac_file in -) cat "$tmp/out" && rm -f "$tmp/out";; *) rm -f "$ac_file" && mv "$tmp/out" "$ac_file";; esac \ || { { $as_echo "$as_me:$LINENO: error: could not create $ac_file" >&5 $as_echo "$as_me: error: could not create $ac_file" >&2;} { (exit 1); exit 1; }; } ;; :H) # # CONFIG_HEADER # if test x"$ac_file" != x-; then { $as_echo "/* $configure_input */" \ && eval '$AWK -f "$tmp/defines.awk"' "$ac_file_inputs" } >"$tmp/config.h" \ || { { $as_echo "$as_me:$LINENO: error: could not create $ac_file" >&5 $as_echo "$as_me: error: could not create $ac_file" >&2;} { (exit 1); exit 1; }; } if diff "$ac_file" "$tmp/config.h" >/dev/null 2>&1; then { $as_echo "$as_me:$LINENO: $ac_file is unchanged" >&5 $as_echo "$as_me: $ac_file is unchanged" >&6;} else rm -f "$ac_file" mv "$tmp/config.h" "$ac_file" \ || { { $as_echo "$as_me:$LINENO: error: could not create $ac_file" >&5 $as_echo "$as_me: error: could not create $ac_file" >&2;} { (exit 1); exit 1; }; } fi else $as_echo "/* $configure_input */" \ && eval '$AWK -f "$tmp/defines.awk"' "$ac_file_inputs" \ || { { $as_echo "$as_me:$LINENO: error: could not create -" >&5 $as_echo "$as_me: error: could not create -" >&2;} { (exit 1); exit 1; }; } fi # Compute "$ac_file"'s index in $config_headers. _am_arg="$ac_file" _am_stamp_count=1 for _am_header in $config_headers :; do case $_am_header in $_am_arg | $_am_arg:* ) break ;; * ) _am_stamp_count=`expr $_am_stamp_count + 1` ;; esac done echo "timestamp for $_am_arg" >`$as_dirname -- "$_am_arg" || $as_expr X"$_am_arg" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ X"$_am_arg" : 'X\(//\)[^/]' \| \ X"$_am_arg" : 'X\(//\)$' \| \ X"$_am_arg" : 'X\(/\)' \| . 2>/dev/null || $as_echo X"$_am_arg" | sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ s//\1/ q } /^X\(\/\/\)[^/].*/{ s//\1/ q } /^X\(\/\/\)$/{ s//\1/ q } /^X\(\/\).*/{ s//\1/ q } s/.*/./; q'`/stamp-h$_am_stamp_count ;; :C) { $as_echo "$as_me:$LINENO: executing $ac_file commands" >&5 $as_echo "$as_me: executing $ac_file commands" >&6;} ;; esac case $ac_file$ac_mode in "depfiles":C) test x"$AMDEP_TRUE" != x"" || for mf in $CONFIG_FILES; do # Strip MF so we end up with the name of the file. mf=`echo "$mf" | sed -e 's/:.*$//'` # Check whether this is an Automake generated Makefile or not. # We used to match only the files named `Makefile.in', but # some people rename them; so instead we look at the file content. # Grep'ing the first line is not enough: some people post-process # each Makefile.in and add a new line on top of each file to say so. # Grep'ing the whole file is not good either: AIX grep has a line # limit of 2048, but all sed's we know have understand at least 4000. if sed -n 's,^#.*generated by automake.*,X,p' "$mf" | grep X >/dev/null 2>&1; then dirpart=`$as_dirname -- "$mf" || $as_expr X"$mf" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ X"$mf" : 'X\(//\)[^/]' \| \ X"$mf" : 'X\(//\)$' \| \ X"$mf" : 'X\(/\)' \| . 2>/dev/null || $as_echo X"$mf" | sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ s//\1/ q } /^X\(\/\/\)[^/].*/{ s//\1/ q } /^X\(\/\/\)$/{ s//\1/ q } /^X\(\/\).*/{ s//\1/ q } s/.*/./; q'` else continue fi # Extract the definition of DEPDIR, am__include, and am__quote # from the Makefile without running `make'. DEPDIR=`sed -n 's/^DEPDIR = //p' < "$mf"` test -z "$DEPDIR" && continue am__include=`sed -n 's/^am__include = //p' < "$mf"` test -z "am__include" && continue am__quote=`sed -n 's/^am__quote = //p' < "$mf"` # When using ansi2knr, U may be empty or an underscore; expand it U=`sed -n 's/^U = //p' < "$mf"` # Find all dependency output files, they are included files with # $(DEPDIR) in their names. We invoke sed twice because it is the # simplest approach to changing $(DEPDIR) to its actual value in the # expansion. for file in `sed -n " s/^$am__include $am__quote\(.*(DEPDIR).*\)$am__quote"'$/\1/p' <"$mf" | \ sed -e 's/\$(DEPDIR)/'"$DEPDIR"'/g' -e 's/\$U/'"$U"'/g'`; do # Make sure the directory exists. test -f "$dirpart/$file" && continue fdir=`$as_dirname -- "$file" || $as_expr X"$file" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ X"$file" : 'X\(//\)[^/]' \| \ X"$file" : 'X\(//\)$' \| \ X"$file" : 'X\(/\)' \| . 2>/dev/null || $as_echo X"$file" | sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ s//\1/ q } /^X\(\/\/\)[^/].*/{ s//\1/ q } /^X\(\/\/\)$/{ s//\1/ q } /^X\(\/\).*/{ s//\1/ q } s/.*/./; q'` { as_dir=$dirpart/$fdir case $as_dir in #( -*) as_dir=./$as_dir;; esac test -d "$as_dir" || { $as_mkdir_p && mkdir -p "$as_dir"; } || { as_dirs= while :; do case $as_dir in #( *\'*) as_qdir=`$as_echo "$as_dir" | sed "s/'/'\\\\\\\\''/g"`;; #'( *) as_qdir=$as_dir;; esac as_dirs="'$as_qdir' $as_dirs" as_dir=`$as_dirname -- "$as_dir" || $as_expr X"$as_dir" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ X"$as_dir" : 'X\(//\)[^/]' \| \ X"$as_dir" : 'X\(//\)$' \| \ X"$as_dir" : 'X\(/\)' \| . 2>/dev/null || $as_echo X"$as_dir" | sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ s//\1/ q } /^X\(\/\/\)[^/].*/{ s//\1/ q } /^X\(\/\/\)$/{ s//\1/ q } /^X\(\/\).*/{ s//\1/ q } s/.*/./; q'` test -d "$as_dir" && break done test -z "$as_dirs" || eval "mkdir $as_dirs" } || test -d "$as_dir" || { { $as_echo "$as_me:$LINENO: error: cannot create directory $as_dir" >&5 $as_echo "$as_me: error: cannot create directory $as_dir" >&2;} { (exit 1); exit 1; }; }; } # echo "creating $dirpart/$file" echo '# dummy' > "$dirpart/$file" done done ;; esac done # for ac_tag { (exit 0); exit 0; } _ACEOF chmod +x $CONFIG_STATUS ac_clean_files=$ac_clean_files_save test $ac_write_fail = 0 || { { $as_echo "$as_me:$LINENO: error: write failure creating $CONFIG_STATUS" >&5 $as_echo "$as_me: error: write failure creating $CONFIG_STATUS" >&2;} { (exit 1); exit 1; }; } # configure is writing to config.log, and then calls config.status. # config.status does its own redirection, appending to config.log. # Unfortunately, on DOS this fails, as config.log is still kept open # by configure, so config.status won't be able to write to it; its # output is simply discarded. So we exec the FD to /dev/null, # effectively closing config.log, so it can be properly (re)opened and # appended to by config.status. When coming back to configure, we # need to make the FD available again. if test "$no_create" != yes; then ac_cs_success=: ac_config_status_args= test "$silent" = yes && ac_config_status_args="$ac_config_status_args --quiet" exec 5>/dev/null $SHELL $CONFIG_STATUS $ac_config_status_args || ac_cs_success=false exec 5>>config.log # Use ||, not &&, to avoid exiting from the if with $? = 1, which # would make configure fail if this is the last instruction. $ac_cs_success || { (exit 1); exit 1; } fi if test -n "$ac_unrecognized_opts" && test "$enable_option_checking" != no; then { $as_echo "$as_me:$LINENO: WARNING: unrecognized options: $ac_unrecognized_opts" >&5 $as_echo "$as_me: WARNING: unrecognized options: $ac_unrecognized_opts" >&2;} fi { $as_echo "$as_me:$LINENO: " >&5 $as_echo "$as_me: " >&6;} { $as_echo "$as_me:$LINENO: algol68g-2.4.1 by Marcel van der Veer " >&5 $as_echo "$as_me: algol68g-2.4.1 by Marcel van der Veer " >&6;} if test "x$a68g_exists" = "xyes"; then { $as_echo "$as_me:$LINENO: algol68g already exists on this system" >&5 $as_echo "$as_me: algol68g already exists on this system" >&6;} fi if test "x$enable_parallel" = "xyes"; then { $as_echo "$as_me:$LINENO: building with parallel clause" >&5 $as_echo "$as_me: building with parallel clause" >&6;} fi if test "x$enable_plotutils" = "xyes"; then { $as_echo "$as_me:$LINENO: building with GNU plotutils" >&5 $as_echo "$as_me: building with GNU plotutils" >&6;} fi if test "x$enable_gsl" = "xyes"; then { $as_echo "$as_me:$LINENO: building with GNU scientific library" >&5 $as_echo "$as_me: building with GNU scientific library" >&6;} fi if test "x$enable_postgresql" = "xyes"; then { $as_echo "$as_me:$LINENO: building with PostgreSQL" >&5 $as_echo "$as_me: building with PostgreSQL" >&6;} fi if test "x$enable_compiler" = "xyes"; then { $as_echo "$as_me:$LINENO: building compiler-interpreter" >&5 $as_echo "$as_me: building compiler-interpreter" >&6;} else { $as_echo "$as_me:$LINENO: building interpreter-only" >&5 $as_echo "$as_me: building interpreter-only" >&6;} fi { $as_echo "$as_me:$LINENO: now type 'make' optionally followed by 'make check' or 'make install'" >&5 $as_echo "$as_me: now type 'make' optionally followed by 'make check' or 'make install'" >&6;} algol68g-2.4.1/configure.ac0000644000175000001440000005406611771657077012401 00000000000000AC_INIT([algol68g], [2.4.1], [Marcel van der Veer ]) # # Algol 68 Genie "configure.ac" from "a68g-tools". # AC_PREREQ([2.60]) # Check whether compiler supports $1 as a command-line option. # If it does, add the string to CFLAGS. AC_DEFUN([A68G_AC_PROG_CC_CFLAGS], [AC_MSG_CHECKING([whether $CC accepts $1]) a68g_ac_save_CFLAGS=$CFLAGS CFLAGS="$a68g_ac_save_CFLAGS $1" _AC_COMPILE_IFELSE([AC_LANG_PROGRAM()], AC_MSG_RESULT(yes), [CFLAGS="$a68g_ac_save_CFLAGS" AC_MSG_RESULT(no)]) ]) # Check whether $1 is in GNU plotutils. AC_DEFUN([A68G_AC_PLOTUTILS], [AC_CHECK_DECL([$1], [], [enable_plotutils=no], [ #include #include ]) AC_CHECK_LIB([plot], [$1], [a68g_unexpected=yes], [enable_plotutils=no]) ]) # Check whether $1 is in GNU GSL. AC_DEFUN([A68G_AC_GSL], [AC_CHECK_DECL([$1], [], [enable_gsl=no], [ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include ]) AC_CHECK_LIB([gsl], [$1], [a68g_unexpected=yes], [enable_gsl=no]) ]) # Check whether $1 is in PostgreSQL. AC_DEFUN([A68G_AC_POSTGRESQL], [AC_CHECK_DECL([$1], [], [enable_postgresql=no], [ #include ]) AC_CHECK_LIB([pq], [$1], [a68g_unexpected=yes], [enable_postgresql=no]) ]) # Check whether $1 is in pthread. AC_DEFUN([A68G_AC_PTHREAD], [AC_CHECK_DECL([$1], [], [enable_parallel=no], [ #include ]) AC_CHECK_LIB([pthread], [$1], [a68g_unexpected=yes], [enable_parallel=no]) ]) # Check whether $1 is in dl. AC_DEFUN([A68G_AC_DL], [AC_CHECK_DECL([$1], [], [enable_compiler=no], [ #include ]) AC_CHECK_LIB([dl], [$1], [a68g_unexpected=yes], [enable_compiler=no]) ]) # # Platform ids. # AC_MSG_NOTICE([host system...]) AC_CANONICAL_BUILD AC_CANONICAL_HOST AC_CANONICAL_TARGET AC_MSG_CHECKING([platform]) case "$host" in # # Linux. # *86-*-gnu | *86_64-*-gnu | *86-*-linux* | *86_64-*-linux*) AC_DEFINE(HAVE_LINUX, 1, [Define this if LINUX was detected]) AC_DEFINE(HAVE_IEEE_754, 1, [Define this if IEEE_754 compliant]) AC_MSG_RESULT([linux]) ;; # # Mac OS X. # *86-*-*darwin* | *86_64-*-*darwin*) AC_DEFINE(HAVE_MAC_OS_X, 1, [Define this if DARWIN was detected]) AC_DEFINE(HAVE_IEEE_754, 1, [Define this if IEEE_754 compliant]) AC_MSG_RESULT([mac os x]) ;; # # FreeBSD. # *86-*-freebsd* | *86_64-*-freebsd*) AC_DEFINE(HAVE_FREEBSD, 1, [Define this if FreeBSD was detected]) AC_DEFINE(HAVE_IEEE_754, 1, [Define this if IEEE_754 compliant]) AC_MSG_RESULT([freebsd]) ;; # # NetBSD. # *86-*-netbsd* | *86_64-*-netbsd*) AC_DEFINE(HAVE_NETBSD, 1, [Define this if NetBSD was detected]) AC_DEFINE(HAVE_IEEE_754, 1, [Define this if IEEE_754 compliant]) AC_MSG_RESULT([netbsd]) ;; # # OpenBSD. # *86-*-openbsd* | *86_64-*-openbsd*) AC_DEFINE(HAVE_OPENBSD, 1, [Define this if OpenBSD was detected]) AC_MSG_WARN([configuring interpreter-only on OpenBSD]) AC_MSG_RESULT([openbsd]) enable_compiler=no ;; # # Others, untested. # *) AC_DEFINE(HAVE_UNTESTED, 1, [Define this if untested OS was detected]) AC_MSG_WARN([configuring interpreter-only on untested platform]) AC_MSG_RESULT([interpreter-only]) enable_compiler=no ;; esac # # Extra options. # AC_ARG_ENABLE(arch, [AS_HELP_STRING([--enable-arch=cpu], [if using gcc, enable emitting architecture-tuned assembly code (default is "no")])], , enable_arch=no) AC_ARG_ENABLE(compiler, [AS_HELP_STRING([--enable-compiler], [enable unit compiler (default is "yes")])], , enable_compiler=yes) AC_ARG_ENABLE(curses, [AS_HELP_STRING([--enable-curses], [if installed, enable curses library (default is "yes")])], , enable_curses=yes) AC_ARG_ENABLE(readline, [AS_HELP_STRING([--enable-readline], [if installed, enable readline library (default is "yes")])], , enable_readline=yes) AC_ARG_ENABLE(gsl, [AS_HELP_STRING([--enable-gsl], [if installed, enable GNU Scientific Library (default is "yes")])], , enable_gsl=yes) AC_ARG_ENABLE(parallel, [AS_HELP_STRING([--enable-parallel], [enable Algol 68 parallel-clause (default is "yes")])], , enable_parallel=yes) AC_ARG_ENABLE(pic, [AS_HELP_STRING([--enable-pic=option], [if using gcc, enable option to generate PIC (default is "-fPIC")])], , enable_pic="-fPIC") AC_ARG_ENABLE(prescott, [AS_HELP_STRING([--enable-prescott], [if using gcc, enable optimisation for P4 Prescott (default is "no")])], , enable_prescott=no) AC_ARG_ENABLE(plotutils, [AS_HELP_STRING([--enable-plotutils], [if installed, enable GNU plotting utilities (default is "yes")])], , enable_plotutils=yes) AC_ARG_ENABLE(postgresql, [AS_HELP_STRING([--enable-postgresql], [if installed, enable PostgreSQL (default is "yes")])], , enable_postgresql=yes) # # Initialisation. # AC_MSG_NOTICE([initialising...]) AM_INIT_AUTOMAKE([subdir-objects]) AC_PREFIX_DEFAULT(/usr/local) AC_CONFIG_SRCDIR([source/a68g.h]) AC_CONFIG_HEADERS([source/a68g-config.h]) AC_PROG_INSTALL AC_CHECK_PROG(a68g_exists, a68g, "yes") # # C compiler. # AC_MSG_NOTICE([C compiler...]) AC_LANG(C) AC_PROG_CC([clang gcc cc]) if test "x$GCC" != "xyes"; then a68g_ac_compiler=no AC_MSG_WARN([gcc is the preferred C compiler; configuring interpreter-only]) else AC_DEFINE(HAVE_GCC, 1, [Define this if GCC was detected]) if test "x$enable_prescott" != "xno"; then CFLAGS="-O3 -fomit-frame-pointer -march=prescott -funroll-loops" enable_pic="no" fi A68G_AC_PROG_CC_CFLAGS([-pedantic]) A68G_AC_PROG_CC_CFLAGS([-W]) A68G_AC_PROG_CC_CFLAGS([-Wall]) A68G_AC_PROG_CC_CFLAGS([-Wextra]) A68G_AC_PROG_CC_CFLAGS([-Wshadow]) # A68G_AC_PROG_CC_CFLAGS([-Wconversion]) Too much warnings! A68G_AC_PROG_CC_CFLAGS([-Wstrict-prototypes]) A68G_AC_PROG_CC_CFLAGS([-Wchar-subscripts]) # # Test on gcc capabilities. # # # Check -Wl,--export-dynamic, needed for creating shared objects. # # Check whether we can link to a particular function, not just whether we can link. # In fact, we must actually check that the resulting program runs. # a68g_ac_arg="-Wl,--export-dynamic" AC_MSG_CHECKING([if $CC accepts $a68g_ac_arg]) a68g_ac_save_LDFLAGS=$LDFLAGS LDFLAGS="$a68g_ac_save_LDFLAGS $a68g_ac_arg" AC_RUN_IFELSE([AC_LANG_PROGRAM([extern void exit (); void (*fptr) () = exit;],[])], [AC_MSG_RESULT(yes) AC_DEFINE(HAVE_EXPORT_DYNAMIC, 1, [Define this if EXPORT_DYNAMIC is recognised]) ], [AC_MSG_RESULT(no) AC_MSG_WARN([--export-dynamic is not accepted; configuring interpreter-only]) a68g_ac_compiler=no LDFLAGS=$a68g_ac_save_LDFLAGS ], [AC_MSG_RESULT(assuming no) AC_MSG_WARN([--export-dynamic is not accepted; configuring interpreter-only]) a68g_ac_compiler=no LDFLAGS=$a68g_ac_save_LDFLAGS ] ) fi AM_CONDITIONAL([EXPORT_DYNAMIC], [test "x$a68g_ac_compiler" = "xyes"]) # # Optionally, tune for a specific processor. # if test "x$enable_arch" != "xno"; then AC_MSG_CHECKING([whether $CC accepts -march=$enable_arch]) a68g_ac_save_CFLAGS=$CFLAGS a68g_ac_march="-march=$enable_arch" CFLAGS="$a68g_ac_save_CFLAGS $a68g_ac_march" _AC_COMPILE_IFELSE([AC_LANG_PROGRAM()], [AC_MSG_RESULT(yes) AC_DEFINE_UNQUOTED(HAVE_TUNING, "$a68g_ac_march", [Define this if user wants to tune for a specific CPU]) ], [AC_MSG_RESULT(no) AC_MSG_WARN([your CPU name is not accepted; resetting to default]) CFLAGS="$a68g_ac_save_CFLAGS" ] ) fi # # Some platforms want another or no PIC option. # if test "x$enable_compiler" = "xyes"; then if test "x$enable_pic" != "xno"; then AC_MSG_CHECKING([whether $CC accepts $enable_pic]) a68g_ac_save_CFLAGS=$CFLAGS CFLAGS="$a68g_ac_save_CFLAGS $enable_pic" _AC_COMPILE_IFELSE([AC_LANG_PROGRAM()], [AC_MSG_RESULT(yes) AC_DEFINE_UNQUOTED(HAVE_PIC, "$enable_pic", [Define this as PIC option]) ], [AC_MSG_RESULT(no) AC_MSG_WARN([your PIC option is not accepted; configuring interpreter-only]) ] ) CFLAGS="$a68g_ac_save_CFLAGS" fi fi AM_PROG_CC_C_O AC_PROG_CPP AC_MSG_NOTICE([types...]) AC_C_CHAR_UNSIGNED AC_TYPE_MODE_T AC_TYPE_SIZE_T AC_TYPE_SSIZE_T AC_TYPE_UINT16_T AC_MSG_CHECKING([__off_t or off_t]) AC_COMPILE_IFELSE( [[ #include #include __off_t dummy; ]], [AC_MSG_RESULT([__off_t])], [AC_MSG_RESULT([off_t]) AC_DEFINE(__off_t, off_t, [Define this if we have no __off_t])] ) AC_MSG_CHECKING([__pid_t or pid_t]) AC_COMPILE_IFELSE( [[ #include #include __pid_t dummy; ]], [AC_MSG_RESULT([__pid_t])], [AC_MSG_RESULT([pid_t]) AC_DEFINE(__pid_t, pid_t, [Define this if we have no __pid_t])] ) AC_MSG_CHECKING([__mode_t or mode_t]) AC_COMPILE_IFELSE( [[ #include #include __mode_t dummy; ]], [AC_MSG_RESULT([__mode_t])], [AC_MSG_RESULT([mode_t]) AC_DEFINE(__mode_t, mode_t, [Define this if we have no __mode_t])] ) # # Extra include directories. # AC_MSG_NOTICE([extra include directories...]) if test -d /usr/local/pgsql/include; then AC_DEFINE(HAVE_USR_LOCAL_PGSQL_INCLUDE, 1, [Define this if /usr/local/pgsql/include was detected]) CFLAGS="$CFLAGS -I/usr/local/pgsql/include" CPPFLAGS="$CPPFLAGS -I/usr/local/pgsql/include" CXXFLAGS="$CXXFLAGS -I/usr/local/pgsql/include" LDFLAGS="$LDFLAGS -L/usr/local/pgsql/lib" fi if test -d /usr/pkg/pgsql/include; then AC_DEFINE(HAVE_USR_PKG_PGSQL_INCLUDE, 1, [Define this if /usr/pkg/pgsql/include was detected]) CFLAGS="$CFLAGS -I/usr/pkg/pgsql/include" CPPFLAGS="$CPPFLAGS -I/usr/pkg/pgsql/include" CXXFLAGS="$CXXFLAGS -I/usr/pkg/pgsql/include" LDFLAGS="$LDFLAGS -L/usr/pkg/pgsql/lib" fi if test -d /opt/local/pgsql/include; then AC_DEFINE(HAVE_OPT_LOCAL_PGSQL_INCLUDE, 1, [Define this if /opt/local/pgsql/include was detected]) CFLAGS="$CFLAGS -I/opt/local/pgsql/include" CPPFLAGS="$CPPFLAGS -I/opt/local/pgsql/include" CXXFLAGS="$CXXFLAGS -I/opt/local/pgsql/include" LDFLAGS="$LDFLAGS -L/opt/local/pgsql/lib" fi # # Checks for header files. # AC_MSG_NOTICE([standard header files...]) # # test is GSL proof. # AC_CHECK_HEADERS([math.h]) AC_CHECK_LIB([m], [cos]) AC_HEADER_STDC AC_HEADER_ASSERT AC_HEADER_DIRENT AC_HEADER_SYS_WAIT AC_HEADER_TIOCGWINSZ AC_CHECK_HEADERS([assert.h ctype.h errno.h fcntl.h float.h limits.h netdb.h netinet/in.h regex.h setjmp.h signal.h stdarg.h stddef.h stdio.h sys/ioctl.h sys/resource.h sys/socket.h sys/time.h termios.h time.h]) # # Functions we expect # AC_MSG_NOTICE([standard functions...]) AC_CHECK_FUNCS(exit) AC_CHECK_FUNCS(fprintf) AC_CHECK_FUNCS(free) AC_CHECK_FUNCS(longjmp) AC_CHECK_FUNCS(malloc) AC_CHECK_FUNCS(memcpy) AC_CHECK_FUNCS(memmove) AC_CHECK_FUNCS(memset) AC_CHECK_FUNCS(printf) AC_CHECK_FUNCS(setjmp) AC_CHECK_FUNCS(signal) AC_CHECK_FUNCS(snprintf) AC_CHECK_FUNCS(strcmp) AC_CHECK_FUNCS(strncmp) AC_CHECK_FUNCS(strncpy) AC_MSG_NOTICE([optional headers and libraries...]) if test "x$enable_curses" = "xyes"; then AC_CHECK_HEADERS([curses.h], [], [enable_curses=no], []) if test "x$enable_curses" = "xno"; then AC_CHECK_HEADERS([ncurses/curses.h], [enable_curses=yes], [], []) fi if test "x$enable_curses" = "xyes"; then AC_CHECK_LIB([ncurses], [initscr], [], [enable_curses=no]) if test "x$enable_curses" = "xyes"; then if test "x$enable_readline" = "xyes"; then AC_CHECK_HEADERS([readline/readline.h], [], [enable_readline=no], []) AC_CHECK_HEADERS([readline/history.h], [], [enable_readline=no], []) if test "x$enable_readline" = "xyes"; then AC_CHECK_LIB([readline], [readline], [], [enable_readline=no], [-lcurses]) if test "x$enable_readline" = "xyes"; then AC_DEFINE(HAVE_READLINE, 1, [Define this if readline was detected]) fi fi fi fi if test "x$enable_curses" = "xno"; then AC_CHECK_LIB([curses], [initscr], [enable_curses=yes], []) fi if test "x$enable_curses" = "xyes"; then AC_DEFINE(HAVE_CURSES, 1, [Define this if curses was detected]) fi fi fi if test "x$enable_plotutils" = "xyes"; then AC_MSG_NOTICE([GNU plotutils...]) AC_CHECK_HEADERS([plot.h], [], [enable_plotutils=no], []) A68G_AC_PLOTUTILS(pl_alabel_r) if test "x$enable_plotutils" = "xyes"; then A68G_AC_PLOTUTILS(pl_bgcolor_r) A68G_AC_PLOTUTILS(pl_bgcolorname_r) A68G_AC_PLOTUTILS(pl_color_r) A68G_AC_PLOTUTILS(pl_colorname_r) A68G_AC_PLOTUTILS(pl_erase_r) A68G_AC_PLOTUTILS(pl_fbox_r) A68G_AC_PLOTUTILS(pl_fcircle_r) A68G_AC_PLOTUTILS(pl_fillcolor_r) A68G_AC_PLOTUTILS(pl_fillcolorname_r) A68G_AC_PLOTUTILS(pl_filltype_r) A68G_AC_PLOTUTILS(pl_fline_r) A68G_AC_PLOTUTILS(pl_fmove_r) A68G_AC_PLOTUTILS(pl_fontname_r) A68G_AC_PLOTUTILS(pl_fontsize_r) A68G_AC_PLOTUTILS(pl_fpoint_r) A68G_AC_PLOTUTILS(pl_linemod_r) A68G_AC_PLOTUTILS(pl_linewidth_r) A68G_AC_PLOTUTILS(pl_newplparams) A68G_AC_PLOTUTILS(pl_openpl_r) A68G_AC_PLOTUTILS(pl_pencolor_r) A68G_AC_PLOTUTILS(pl_pencolorname_r) A68G_AC_PLOTUTILS(pl_setplparam) A68G_AC_PLOTUTILS(pl_space_r) A68G_AC_PLOTUTILS(pl_textangle_r) fi if test "x$enable_plotutils" = "xyes"; then AC_CHECK_LIB([plot], [pl_alabel_r]) AC_DEFINE(HAVE_GNU_PLOTUTILS, 1, [Define this if a good GNU plotutils installation was detected]) fi fi if test "x$enable_gsl" = "xyes"; then AC_MSG_NOTICE([GNU scientific library...]) AC_CHECK_HEADERS([gsl/gsl_blas.h gsl/gsl_complex.h gsl/gsl_complex_math.h gsl/gsl_errno.h gsl/gsl_fft_complex.h gsl/gsl_integration.h gsl/gsl_linalg.h gsl/gsl_math.h gsl/gsl_matrix.h gsl/gsl_permutation.h gsl/gsl_sf.h gsl/gsl_vector.h], [], [enable_gsl=no], []) AC_CHECK_LIB([gslcblas], [cblas_dgemm], [], [enable_gsl=no]) A68G_AC_GSL(gsl_blas_ddot) if test "x$enable_gsl" = "xyes"; then A68G_AC_GSL(gsl_blas_dgemm) A68G_AC_GSL(gsl_blas_dgemv) A68G_AC_GSL(gsl_blas_zaxpy) A68G_AC_GSL(gsl_blas_zdotc) A68G_AC_GSL(gsl_blas_zdscal) A68G_AC_GSL(gsl_blas_zgemm) A68G_AC_GSL(gsl_blas_zgemv) A68G_AC_GSL(gsl_blas_zscal) A68G_AC_GSL(gsl_complex_arccosh) A68G_AC_GSL(gsl_complex_arcsinh) A68G_AC_GSL(gsl_complex_arctanh) A68G_AC_GSL(gsl_complex_cosh) A68G_AC_GSL(gsl_complex_inverse) A68G_AC_GSL(gsl_complex_mul) A68G_AC_GSL(gsl_complex_sinh) A68G_AC_GSL(gsl_complex_tanh) A68G_AC_GSL(gsl_fft_complex_backward) A68G_AC_GSL(gsl_fft_complex_forward) A68G_AC_GSL(gsl_fft_complex_inverse) A68G_AC_GSL(gsl_fft_complex_wavetable_alloc) A68G_AC_GSL(gsl_fft_complex_wavetable_free) A68G_AC_GSL(gsl_fft_complex_workspace_alloc) A68G_AC_GSL(gsl_fft_complex_workspace_free) A68G_AC_GSL(gsl_integration_qagiu) A68G_AC_GSL(gsl_integration_workspace_alloc) A68G_AC_GSL(gsl_integration_workspace_free) A68G_AC_GSL(gsl_linalg_LU_decomp) A68G_AC_GSL(gsl_linalg_LU_det) A68G_AC_GSL(gsl_linalg_LU_invert) A68G_AC_GSL(gsl_linalg_LU_refine) A68G_AC_GSL(gsl_linalg_LU_solve) A68G_AC_GSL(gsl_linalg_QR_decomp) A68G_AC_GSL(gsl_linalg_QR_lssolve) A68G_AC_GSL(gsl_linalg_QR_solve) A68G_AC_GSL(gsl_linalg_SV_decomp) A68G_AC_GSL(gsl_linalg_SV_solve) A68G_AC_GSL(gsl_linalg_cholesky_decomp) A68G_AC_GSL(gsl_linalg_cholesky_solve) A68G_AC_GSL(gsl_linalg_complex_LU_decomp) A68G_AC_GSL(gsl_linalg_complex_LU_det) A68G_AC_GSL(gsl_linalg_complex_LU_invert) A68G_AC_GSL(gsl_linalg_complex_LU_refine) A68G_AC_GSL(gsl_linalg_complex_LU_solve) A68G_AC_GSL(gsl_matrix_add) A68G_AC_GSL(gsl_matrix_alloc) A68G_AC_GSL(gsl_matrix_complex_add) A68G_AC_GSL(gsl_matrix_complex_alloc) A68G_AC_GSL(gsl_matrix_complex_free) A68G_AC_GSL(gsl_matrix_complex_get) A68G_AC_GSL(gsl_matrix_complex_isnull) A68G_AC_GSL(gsl_matrix_complex_scale) A68G_AC_GSL(gsl_matrix_complex_set) A68G_AC_GSL(gsl_matrix_complex_set_zero) A68G_AC_GSL(gsl_matrix_complex_sub) A68G_AC_GSL(gsl_matrix_complex_transpose) A68G_AC_GSL(gsl_matrix_free) A68G_AC_GSL(gsl_matrix_get) A68G_AC_GSL(gsl_matrix_isnull) A68G_AC_GSL(gsl_matrix_scale) A68G_AC_GSL(gsl_matrix_set) A68G_AC_GSL(gsl_matrix_set_zero) A68G_AC_GSL(gsl_matrix_sub) A68G_AC_GSL(gsl_matrix_transpose) A68G_AC_GSL(gsl_permutation_alloc) A68G_AC_GSL(gsl_permutation_free) A68G_AC_GSL(gsl_permutation_get) A68G_AC_GSL(gsl_set_error_handler) A68G_AC_GSL(gsl_set_error_handler_off) A68G_AC_GSL(gsl_sf_airy_Ai_deriv_e) A68G_AC_GSL(gsl_sf_airy_Ai_e) A68G_AC_GSL(gsl_sf_airy_Bi_deriv_e) A68G_AC_GSL(gsl_sf_airy_Bi_e) A68G_AC_GSL(gsl_sf_bessel_In_e) A68G_AC_GSL(gsl_sf_bessel_In_scaled_e) A68G_AC_GSL(gsl_sf_bessel_Inu_e) A68G_AC_GSL(gsl_sf_bessel_Inu_scaled_e) A68G_AC_GSL(gsl_sf_bessel_Jn_e) A68G_AC_GSL(gsl_sf_bessel_Jnu_e) A68G_AC_GSL(gsl_sf_bessel_Kn_e) A68G_AC_GSL(gsl_sf_bessel_Kn_scaled_e) A68G_AC_GSL(gsl_sf_bessel_Knu_e) A68G_AC_GSL(gsl_sf_bessel_Knu_scaled_e) A68G_AC_GSL(gsl_sf_bessel_Yn_e) A68G_AC_GSL(gsl_sf_bessel_Ynu_e) A68G_AC_GSL(gsl_sf_bessel_il_scaled_e) A68G_AC_GSL(gsl_sf_bessel_jl_e) A68G_AC_GSL(gsl_sf_bessel_kl_scaled_e) A68G_AC_GSL(gsl_sf_bessel_yl_e) A68G_AC_GSL(gsl_sf_beta_e) A68G_AC_GSL(gsl_sf_beta_inc_e) A68G_AC_GSL(gsl_sf_ellint_Ecomp_e) A68G_AC_GSL(gsl_sf_ellint_Kcomp_e) A68G_AC_GSL(gsl_sf_ellint_RC_e) A68G_AC_GSL(gsl_sf_ellint_RD_e) A68G_AC_GSL(gsl_sf_ellint_RF_e) A68G_AC_GSL(gsl_sf_ellint_RJ_e) A68G_AC_GSL(gsl_sf_erf_e) A68G_AC_GSL(gsl_sf_erfc_e) A68G_AC_GSL(gsl_sf_fact) A68G_AC_GSL(gsl_sf_gamma_e) A68G_AC_GSL(gsl_sf_gamma_inc_P_e) A68G_AC_GSL(gsl_sf_lngamma_e) A68G_AC_GSL(gsl_strerror) A68G_AC_GSL(gsl_vector_add) A68G_AC_GSL(gsl_vector_alloc) A68G_AC_GSL(gsl_vector_complex_alloc) A68G_AC_GSL(gsl_vector_complex_free) A68G_AC_GSL(gsl_vector_complex_get) A68G_AC_GSL(gsl_vector_complex_isnull) A68G_AC_GSL(gsl_vector_complex_set) A68G_AC_GSL(gsl_vector_complex_set_zero) A68G_AC_GSL(gsl_vector_free) A68G_AC_GSL(gsl_vector_get) A68G_AC_GSL(gsl_vector_isnull) A68G_AC_GSL(gsl_vector_scale) A68G_AC_GSL(gsl_vector_set) A68G_AC_GSL(gsl_vector_set_zero) A68G_AC_GSL(gsl_vector_sub) fi if test "x$enable_gsl" = "xyes"; then AC_CHECK_LIB([gsl], [gsl_blas_ddot]) AC_DEFINE(HAVE_GNU_GSL, 1, [Define this if a good GNU GSL installation was detected]) fi fi if test "x$enable_parallel" = "xyes"; then AC_MSG_NOTICE([POSIX pthreads...]) AC_CHECK_HEADERS([pthread.h], [], [enable_parallel=no], []) A68G_AC_PTHREAD(pthread_attr_getstacksize) if test "x$enable_parallel" = "xyes"; then A68G_AC_PTHREAD(pthread_attr_init) A68G_AC_PTHREAD(pthread_attr_setstacksize) A68G_AC_PTHREAD(pthread_create) A68G_AC_PTHREAD(pthread_equal) A68G_AC_PTHREAD(pthread_exit) A68G_AC_PTHREAD(pthread_join) A68G_AC_PTHREAD(pthread_mutex_lock) A68G_AC_PTHREAD(pthread_mutex_unlock) A68G_AC_PTHREAD(pthread_self) fi if test "x$enable_parallel" = "xyes"; then AC_CHECK_LIB([pthread], pthread_attr_getstacksize) AC_DEFINE(HAVE_PARALLEL_CLAUSE, 1, [Define this if a good pthread installation was detected]) fi fi if test "x$enable_postgresql" = "xyes"; then AC_MSG_NOTICE([PostgreSQL...]) AC_CHECK_HEADERS([libpq-fe.h], [], [enable_postgresql=no], []) A68G_AC_POSTGRESQL(PQbackendPID) if test "x$enable_postgresql" = "xyes"; then A68G_AC_POSTGRESQL(PQclear) A68G_AC_POSTGRESQL(PQcmdStatus) A68G_AC_POSTGRESQL(PQcmdTuples) A68G_AC_POSTGRESQL(PQconnectdb) A68G_AC_POSTGRESQL(PQdb) A68G_AC_POSTGRESQL(PQerrorMessage) A68G_AC_POSTGRESQL(PQexec) A68G_AC_POSTGRESQL(PQfformat) A68G_AC_POSTGRESQL(PQfinish) A68G_AC_POSTGRESQL(PQfname) A68G_AC_POSTGRESQL(PQfnumber) A68G_AC_POSTGRESQL(PQgetisnull) A68G_AC_POSTGRESQL(PQgetvalue) A68G_AC_POSTGRESQL(PQhost) A68G_AC_POSTGRESQL(PQnfields) A68G_AC_POSTGRESQL(PQntuples) A68G_AC_POSTGRESQL(PQoptions) A68G_AC_POSTGRESQL(PQparameterStatus) A68G_AC_POSTGRESQL(PQpass) A68G_AC_POSTGRESQL(PQport) A68G_AC_POSTGRESQL(PQprotocolVersion) A68G_AC_POSTGRESQL(PQreset) A68G_AC_POSTGRESQL(PQresultErrorMessage) A68G_AC_POSTGRESQL(PQresultStatus) A68G_AC_POSTGRESQL(PQserverVersion) A68G_AC_POSTGRESQL(PQsocket) A68G_AC_POSTGRESQL(PQstatus) A68G_AC_POSTGRESQL(PQtty) A68G_AC_POSTGRESQL(PQuser) fi if test "x$enable_postgresql" = "xyes"; then AC_CHECK_LIB([pq], [PQbackendPID]) AC_DEFINE(HAVE_POSTGRESQL, 1, [Define this if a good PostgreSQL installation was detected]) fi fi if test "x$enable_compiler" = "xyes"; then AC_MSG_NOTICE([Dynamic loader...]) AC_CHECK_HEADERS([dlfcn.h]) A68G_AC_DL(dlopen) if test "x$enable_compiler" = "xyes"; then A68G_AC_DL(dlsym) A68G_AC_DL(dlerror) A68G_AC_DL(dlclose) fi if test "x$enable_compiler" = "xyes"; then AC_CHECK_LIB([dl], [dlopen]) AC_DEFINE(HAVE_DL, 1, [Define this if a good DL installation was detected]) fi fi # # Generate files. # AC_CONFIG_FILES([Makefile]) AC_OUTPUT AC_MSG_NOTICE([]) AC_MSG_NOTICE([AC_PACKAGE_NAME-AC_PACKAGE_VERSION by Marcel van der Veer ]) if test "x$a68g_exists" = "xyes"; then AC_MSG_NOTICE([AC_PACKAGE_NAME already exists on this system]) fi if test "x$enable_parallel" = "xyes"; then AC_MSG_NOTICE([building with parallel clause]) fi if test "x$enable_plotutils" = "xyes"; then AC_MSG_NOTICE([building with GNU plotutils]) fi if test "x$enable_gsl" = "xyes"; then AC_MSG_NOTICE([building with GNU scientific library]) fi if test "x$enable_postgresql" = "xyes"; then AC_MSG_NOTICE([building with PostgreSQL]) fi if test "x$enable_compiler" = "xyes"; then AC_MSG_NOTICE([building compiler-interpreter]) else AC_MSG_NOTICE([building interpreter-only]) fi AC_MSG_NOTICE([now type 'make' optionally followed by 'make check' or 'make install']) algol68g-2.4.1/compile0000755000175000001440000000717311551405127011445 00000000000000#! /bin/sh # Wrapper for compilers which do not understand `-c -o'. scriptversion=2005-05-14.22 # Copyright (C) 1999, 2000, 2003, 2004, 2005 Free Software Foundation, Inc. # Written by Tom Tromey . # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2, or (at your option) # any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; if not, write to the Free Software # Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. # As a special exception to the GNU General Public License, if you # distribute this file as part of a program that contains a # configuration script generated by Autoconf, you may include it under # the same distribution terms that you use for the rest of that program. # This file is maintained in Automake, please report # bugs to or send patches to # . case $1 in '') echo "$0: No command. Try \`$0 --help' for more information." 1>&2 exit 1; ;; -h | --h*) cat <<\EOF Usage: compile [--help] [--version] PROGRAM [ARGS] Wrapper for compilers which do not understand `-c -o'. Remove `-o dest.o' from ARGS, run PROGRAM with the remaining arguments, and rename the output as expected. If you are trying to build a whole package this is not the right script to run: please start by reading the file `INSTALL'. Report bugs to . EOF exit $? ;; -v | --v*) echo "compile $scriptversion" exit $? ;; esac ofile= cfile= eat= for arg do if test -n "$eat"; then eat= else case $1 in -o) # configure might choose to run compile as `compile cc -o foo foo.c'. # So we strip `-o arg' only if arg is an object. eat=1 case $2 in *.o | *.obj) ofile=$2 ;; *) set x "$@" -o "$2" shift ;; esac ;; *.c) cfile=$1 set x "$@" "$1" shift ;; *) set x "$@" "$1" shift ;; esac fi shift done if test -z "$ofile" || test -z "$cfile"; then # If no `-o' option was seen then we might have been invoked from a # pattern rule where we don't need one. That is ok -- this is a # normal compilation that the losing compiler can handle. If no # `.c' file was seen then we are probably linking. That is also # ok. exec "$@" fi # Name of file we expect compiler to create. cofile=`echo "$cfile" | sed -e 's|^.*/||' -e 's/\.c$/.o/'` # Create the lock directory. # Note: use `[/.-]' here to ensure that we don't use the same name # that we are using for the .o file. Also, base the name on the expected # object file name, since that is what matters with a parallel build. lockdir=`echo "$cofile" | sed -e 's|[/.-]|_|g'`.d while true; do if mkdir "$lockdir" >/dev/null 2>&1; then break fi sleep 1 done # FIXME: race condition here if user kills between mkdir and trap. trap "rmdir '$lockdir'; exit 1" 1 2 15 # Run the compile. "$@" ret=$? if test -f "$cofile"; then mv "$cofile" "$ofile" elif test -f "${cofile}bj"; then mv "${cofile}bj" "$ofile" fi rmdir "$lockdir" exit $ret # Local Variables: # mode: shell-script # sh-indentation: 2 # eval: (add-hook 'write-file-hooks 'time-stamp) # time-stamp-start: "scriptversion=" # time-stamp-format: "%:y-%02m-%02d.%02H" # time-stamp-end: "$" # End: algol68g-2.4.1/source/0000777000175000001440000000000011771660256011455 500000000000000algol68g-2.4.1/source/postgresql.c0000644000175000001440000006021211770153033013726 00000000000000/*! \file postgresql.c \brief interface to libpq */ /* This file is part of Algol68G - an Algol 68 interpreter. Copyright (C) 2001-2012 J. Marcel van der Veer . 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 */ #if defined HAVE_CONFIG_H #include "a68g-config.h" #endif #if defined HAVE_POSTGRESQL #include "a68g.h" #define LIBPQ_STRING "PostgreSQL libq" #define ERROR_NOT_CONNECTED "not connected to a database" #define ERROR_NO_QUERY_RESULT "no query result available" #define NO_PGCONN ((PGconn *) NULL) #define NO_PGRESULT ((PGresult *) NULL) /*! \brief PROC pg connect db (REF FILE, STRING, REF STRING) INT \param p position in tree **/ void genie_pq_connectdb (NODE_T * p) { A68_REF ref_string, ref_file, ref_z, conninfo; A68_FILE *file; POP_REF (p, &ref_string); CHECK_REF (p, ref_string, MODE (REF_STRING)); POP_REF (p, &conninfo); POP_REF (p, &ref_file); CHECK_REF (p, ref_file, MODE (REF_FILE)); if (IS_IN_HEAP (&ref_file) && !IS_IN_HEAP (&ref_string)) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_SCOPE_DYNAMIC_1, MODE (REF_STRING)); exit_genie (p, A68_RUNTIME_ERROR); } else if (IS_IN_FRAME (&ref_file) && IS_IN_FRAME (&ref_string)) { if (REF_SCOPE (&ref_string) > REF_SCOPE (&ref_file)) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_SCOPE_DYNAMIC_1, MODE (REF_STRING)); exit_genie (p, A68_RUNTIME_ERROR); } } /* Initialise the file */ file = FILE_DEREF (&ref_file); if (OPENED (file)) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FILE_ALREADY_OPEN); exit_genie (p, A68_RUNTIME_ERROR); } STATUS (file) = INIT_MASK; CHANNEL (file) = associate_channel; OPENED (file) = A68_TRUE; OPEN_EXCLUSIVE (file) = A68_FALSE; READ_MOOD (file) = A68_FALSE; WRITE_MOOD (file) = A68_FALSE; CHAR_MOOD (file) = A68_FALSE; DRAW_MOOD (file) = A68_FALSE; TMP_FILE (file) = A68_FALSE; if (INITIALISED (&(IDENTIFICATION (file))) && !IS_NIL (IDENTIFICATION (file))) { UNBLOCK_GC_HANDLE (&(IDENTIFICATION (file))); } IDENTIFICATION (file) = nil_ref; TERMINATOR (file) = nil_ref; FORMAT (file) = nil_format; FD (file) = -1; if (INITIALISED (&(STRING (file))) && !IS_NIL (STRING (file))) { UNBLOCK_GC_HANDLE (&(STRING (file))); } STRING (file) = ref_string; BLOCK_GC_HANDLE (&(STRING (file))); STRPOS (file) = 1; STREAM (&DEVICE (file)) = NULL; set_default_event_procedures (file); /* Establish a connection */ ref_z = heap_generator (p, MODE (C_STRING), 1 + a68_string_size (p, conninfo)); CONNECTION (file) = PQconnectdb (a_to_c_string (p, DEREF (char, &ref_z), conninfo)); RESULT (file) = NO_PGRESULT; if (CONNECTION (file) == NO_PGCONN) { PUSH_PRIMAL (p, -3, INT); } (void) PQsetErrorVerbosity (CONNECTION (file), PQERRORS_DEFAULT); if (PQstatus (CONNECTION (file)) != CONNECTION_OK) { PUSH_PRIMAL (p, -1, INT); } else { PUSH_PRIMAL (p, 0, INT); } } /*! \brief PROC pq finish (REF FILE) VOID \param p position in tree **/ void genie_pq_finish (NODE_T * p) { A68_REF ref_file; A68_FILE *file; POP_REF (p, &ref_file); CHECK_REF (p, ref_file, MODE (REF_FILE)); file = FILE_DEREF (&ref_file); CHECK_INIT (p, INITIALISED (file), MODE (FILE)); if (CONNECTION (file) == NO_PGCONN) { PUSH_PRIMAL (p, -1, INT); return; } if (RESULT (file) != NO_PGRESULT) { PQclear (RESULT (file)); } PQfinish (CONNECTION (file)); CONNECTION (file) = NO_PGCONN; RESULT (file) = NO_PGRESULT; PUSH_PRIMAL (p, 0, INT); } /*! \brief PROC pq reset (REF FILE) VOID \param p position in tree **/ void genie_pq_reset (NODE_T * p) { A68_REF ref_file; A68_FILE *file; POP_REF (p, &ref_file); CHECK_REF (p, ref_file, MODE (REF_FILE)); file = FILE_DEREF (&ref_file); CHECK_INIT (p, INITIALISED (file), MODE (FILE)); if (CONNECTION (file) == NO_PGCONN) { PUSH_PRIMAL (p, -1, INT); return; } if (RESULT (file) != NO_PGRESULT) { PQclear (RESULT (file)); } PQreset (CONNECTION (file)); PUSH_PRIMAL (p, 0, INT); } /*! \brief PROC pq exec = (REF FILE, STRING) INT \param p position in tree **/ void genie_pq_exec (NODE_T * p) { A68_REF ref_z, query; A68_REF ref_file; A68_FILE *file; POP_REF (p, &query); POP_REF (p, &ref_file); CHECK_REF (p, ref_file, MODE (REF_FILE)); file = FILE_DEREF (&ref_file); CHECK_INIT (p, INITIALISED (file), MODE (FILE)); if (CONNECTION (file) == NO_PGCONN) { PUSH_PRIMAL (p, -1, INT); return; } if (RESULT (file) != NO_PGRESULT) { PQclear (RESULT (file)); } ref_z = heap_generator (p, MODE (C_STRING), 1 + a68_string_size (p, query)); RESULT (file) = PQexec (CONNECTION (file), a_to_c_string (p, DEREF (char, &ref_z), query)); if ((PQresultStatus (RESULT (file)) != PGRES_TUPLES_OK) && (PQresultStatus (RESULT (file)) != PGRES_COMMAND_OK)) { PUSH_PRIMAL (p, -3, INT); } else { PUSH_PRIMAL (p, 0, INT); } } /*! \brief PROC pq parameterstatus (REF FILE) INT \param p position in tree **/ void genie_pq_parameterstatus (NODE_T * p) { A68_REF ref_z, parameter; A68_REF ref_file; A68_FILE *file; POP_REF (p, ¶meter); POP_REF (p, &ref_file); CHECK_REF (p, ref_file, MODE (REF_FILE)); file = FILE_DEREF (&ref_file); CHECK_INIT (p, INITIALISED (file), MODE (FILE)); if (CONNECTION (file) == NO_PGCONN) { PUSH_PRIMAL (p, -1, INT); return; } ref_z = heap_generator (p, MODE (C_STRING), 1 + a68_string_size (p, parameter)); if (!IS_NIL (STRING (file))) { * DEREF (A68_REF, &STRING (file)) = c_to_a_string (p, (char *) PQparameterStatus (CONNECTION (file), a_to_c_string (p, DEREF (char, &ref_z), parameter)), DEFAULT_WIDTH); PUSH_PRIMAL (p, 0, INT); } else { PUSH_PRIMAL (p, -3, INT); } } /*! \brief PROC pq cmdstatus (REF FILE) INT \param p position in tree **/ void genie_pq_cmdstatus (NODE_T * p) { A68_REF ref_file; A68_FILE *file; POP_REF (p, &ref_file); CHECK_REF (p, ref_file, MODE (REF_FILE)); file = FILE_DEREF (&ref_file); CHECK_INIT (p, INITIALISED (file), MODE (FILE)); if (CONNECTION (file) == NO_PGCONN) { PUSH_PRIMAL (p, -1, INT); return; } if (RESULT (file) == NO_PGRESULT) { PUSH_PRIMAL (p, -1, INT); return; } if (!IS_NIL (STRING (file))) { * DEREF (A68_REF, &STRING (file)) = c_to_a_string (p, PQcmdStatus (RESULT (file)), DEFAULT_WIDTH); STRPOS (file) = 1; PUSH_PRIMAL (p, 0, INT); } else { PUSH_PRIMAL (p, -3, INT); } } /*! \brief PROC pq cmdtuples (REF FILE) INT \param p position in tree **/ void genie_pq_cmdtuples (NODE_T * p) { A68_REF ref_file; A68_FILE *file; POP_REF (p, &ref_file); CHECK_REF (p, ref_file, MODE (REF_FILE)); file = FILE_DEREF (&ref_file); CHECK_INIT (p, INITIALISED (file), MODE (FILE)); if (CONNECTION (file) == NO_PGCONN) { PUSH_PRIMAL (p, -1, INT); return; } if (RESULT (file) == NO_PGRESULT) { PUSH_PRIMAL (p, -1, INT); return; } if (!IS_NIL (STRING (file))) { * DEREF (A68_REF, &STRING (file)) = c_to_a_string (p, PQcmdTuples (RESULT (file)), DEFAULT_WIDTH); STRPOS (file) = 1; PUSH_PRIMAL (p, 0, INT); } else { PUSH_PRIMAL (p, -3, INT); } } /*! \brief PROC pq ntuples (REF FILE) INT \param p position in tree **/ void genie_pq_ntuples (NODE_T * p) { A68_REF ref_file; A68_FILE *file; POP_REF (p, &ref_file); CHECK_REF (p, ref_file, MODE (REF_FILE)); file = FILE_DEREF (&ref_file); CHECK_INIT (p, INITIALISED (file), MODE (FILE)); if (CONNECTION (file) == NO_PGCONN) { PUSH_PRIMAL (p, -1, INT); return; } if (RESULT (file) == NO_PGRESULT) { PUSH_PRIMAL (p, -2, INT); return; } PUSH_PRIMAL (p, (PQresultStatus (RESULT (file))) == PGRES_TUPLES_OK ? PQntuples (RESULT (file)) : -3, INT); } /*! \brief PROC pq nfields (REF FILE) INT \param p position in tree **/ void genie_pq_nfields (NODE_T * p) { A68_REF ref_file; A68_FILE *file; POP_REF (p, &ref_file); CHECK_REF (p, ref_file, MODE (REF_FILE)); file = FILE_DEREF (&ref_file); CHECK_INIT (p, INITIALISED (file), MODE (FILE)); if (CONNECTION (file) == NO_PGCONN) { PUSH_PRIMAL (p, -1, INT); return; } if (RESULT (file) == NO_PGRESULT) { PUSH_PRIMAL (p, -2, INT); return; } PUSH_PRIMAL (p, (PQresultStatus (RESULT (file))) == PGRES_TUPLES_OK ? PQnfields (RESULT (file)) : -3, INT); } /*! \brief PROC pq fname (REF FILE, INT) INT \param p position in tree **/ void genie_pq_fname (NODE_T * p) { A68_INT a68g_index; int upb; A68_REF ref_file; A68_FILE *file; POP_OBJECT (p, &a68g_index, A68_INT); CHECK_INIT (p, INITIALISED (&a68g_index), MODE (INT)); POP_REF (p, &ref_file); CHECK_REF (p, ref_file, MODE (REF_FILE)); file = FILE_DEREF (&ref_file); CHECK_INIT (p, INITIALISED (file), MODE (FILE)); if (CONNECTION (file) == NO_PGCONN) { PUSH_PRIMAL (p, -1, INT); return; } if (RESULT (file) == NO_PGRESULT) { PUSH_PRIMAL (p, -2, INT); return; } upb = (PQresultStatus (RESULT (file)) == PGRES_TUPLES_OK ? PQnfields (RESULT (file)) : 0); if (VALUE (&a68g_index) < 1 || VALUE (&a68g_index) > upb) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_INDEX_OUT_OF_BOUNDS); exit_genie (p, A68_RUNTIME_ERROR); } if (!IS_NIL (STRING (file))) { * DEREF (A68_REF, &STRING (file)) = c_to_a_string (p, PQfname (RESULT (file), VALUE (&a68g_index) - 1), DEFAULT_WIDTH); STRPOS (file) = 1; } PUSH_PRIMAL (p, 0, INT); } /*! \brief PROC pq fnumber = (REF FILE, STRING) INT \param p position in tree **/ void genie_pq_fnumber (NODE_T * p) { A68_REF ref_z, name; A68_REF ref_file; A68_FILE *file; int k; POP_REF (p, &name); POP_REF (p, &ref_file); CHECK_REF (p, ref_file, MODE (REF_FILE)); file = FILE_DEREF (&ref_file); CHECK_INIT (p, INITIALISED (file), MODE (FILE)); if (CONNECTION (file) == NO_PGCONN) { PUSH_PRIMAL (p, -1, INT); return; } if (RESULT (file) == NO_PGRESULT) { PUSH_PRIMAL (p, -2, INT); return; } ref_z = heap_generator (p, MODE (C_STRING), 1 + a68_string_size (p, name)); k = PQfnumber (RESULT (file), a_to_c_string (p, DEREF (char, &ref_z), name)); if (k == -1) { PUSH_PRIMAL (p, -3, INT); } else { PUSH_PRIMAL (p, k + 1, INT); } } /*! \brief PROC pq fformat (REF FILE, INT) INT \param p position in tree **/ void genie_pq_fformat (NODE_T * p) { A68_INT a68g_index; int upb; A68_REF ref_file; A68_FILE *file; POP_OBJECT (p, &a68g_index, A68_INT); CHECK_INIT (p, INITIALISED (&a68g_index), MODE (INT)); POP_REF (p, &ref_file); CHECK_REF (p, ref_file, MODE (REF_FILE)); file = FILE_DEREF (&ref_file); CHECK_INIT (p, INITIALISED (file), MODE (FILE)); if (CONNECTION (file) == NO_PGCONN) { PUSH_PRIMAL (p, -1, INT); return; } if (RESULT (file) == NO_PGRESULT) { PUSH_PRIMAL (p, -2, INT); return; } upb = (PQresultStatus (RESULT (file)) == PGRES_TUPLES_OK ? PQnfields (RESULT (file)) : 0); if (VALUE (&a68g_index) < 1 || VALUE (&a68g_index) > upb) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_INDEX_OUT_OF_BOUNDS); exit_genie (p, A68_RUNTIME_ERROR); } PUSH_PRIMAL (p, PQfformat (RESULT (file), VALUE (&a68g_index) - 1), INT); } /*! \brief PROC pq getvalue (REF FILE, INT, INT) INT \param p position in tree **/ void genie_pq_getvalue (NODE_T * p) { A68_INT row, column; char *str; int upb; A68_REF ref_file; A68_FILE *file; POP_OBJECT (p, &column, A68_INT); CHECK_INIT (p, INITIALISED (&column), MODE (INT)); POP_OBJECT (p, &row, A68_INT); CHECK_INIT (p, INITIALISED (&row), MODE (INT)); POP_REF (p, &ref_file); CHECK_REF (p, ref_file, MODE (REF_FILE)); file = FILE_DEREF (&ref_file); CHECK_INIT (p, INITIALISED (file), MODE (FILE)); if (CONNECTION (file) == NO_PGCONN) { PUSH_PRIMAL (p, -1, INT); return; } if (RESULT (file) == NO_PGRESULT) { PUSH_PRIMAL (p, -2, INT); return; } upb = (PQresultStatus (RESULT (file)) == PGRES_TUPLES_OK ? PQnfields (RESULT (file)) : 0); if (VALUE (&column) < 1 || VALUE (&column) > upb) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_INDEX_OUT_OF_BOUNDS); exit_genie (p, A68_RUNTIME_ERROR); } upb = (PQresultStatus (RESULT (file)) == PGRES_TUPLES_OK ? PQntuples (RESULT (file)) : 0); if (VALUE (&row) < 1 || VALUE (&row) > upb) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_INDEX_OUT_OF_BOUNDS); exit_genie (p, A68_RUNTIME_ERROR); } str = PQgetvalue (RESULT (file), VALUE (&row) - 1, VALUE (&column) - 1); if (str == NULL) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_NO_QUERY_RESULT); exit_genie (p, A68_RUNTIME_ERROR); } if (!IS_NIL (STRING (file))) { * DEREF (A68_REF, &STRING (file)) = c_to_a_string (p, str, DEFAULT_WIDTH); STRPOS (file) = 1; PUSH_PRIMAL (p, 0, INT); } else { PUSH_PRIMAL (p, -3, INT); } } /*! \brief PROC pq getisnull (REF FILE, INT, INT) INT \param p position in tree **/ void genie_pq_getisnull (NODE_T * p) { A68_INT row, column; int upb; A68_REF ref_file; A68_FILE *file; POP_OBJECT (p, &column, A68_INT); CHECK_INIT (p, INITIALISED (&column), MODE (INT)); POP_OBJECT (p, &row, A68_INT); CHECK_INIT (p, INITIALISED (&row), MODE (INT)); POP_REF (p, &ref_file); CHECK_REF (p, ref_file, MODE (REF_FILE)); file = FILE_DEREF (&ref_file); CHECK_INIT (p, INITIALISED (file), MODE (FILE)); if (CONNECTION (file) == NO_PGCONN) { PUSH_PRIMAL (p, -1, INT); return; } if (RESULT (file) == NO_PGRESULT) { PUSH_PRIMAL (p, -2, INT); return; } upb = (PQresultStatus (RESULT (file)) == PGRES_TUPLES_OK ? PQnfields (RESULT (file)) : 0); if (VALUE (&column) < 1 || VALUE (&column) > upb) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_INDEX_OUT_OF_BOUNDS); exit_genie (p, A68_RUNTIME_ERROR); } upb = (PQresultStatus (RESULT (file)) == PGRES_TUPLES_OK ? PQntuples (RESULT (file)) : 0); if (VALUE (&row) < 1 || VALUE (&row) > upb) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_INDEX_OUT_OF_BOUNDS); exit_genie (p, A68_RUNTIME_ERROR); } PUSH_PRIMAL (p, PQgetisnull (RESULT (file), VALUE (&row) - 1, VALUE (&column) - 1), INT); } /*! \brief edit error message sting from libpq \param p position in tree **/ static char *pq_edit (char *str) { if (str == NULL) { return (""); } else { static char edt[BUFFER_SIZE]; char *q; int newlines = 0, len = (int) strlen (str); BOOL_T suppress_blank = A68_FALSE; q = edt; while (len > 0 && str[len - 1] == NEWLINE_CHAR) { str[len - 1] = NULL_CHAR; len = (int) strlen (str); } while (str[0] != NULL_CHAR) { if (str[0] == CR_CHAR) { str++; } else if (str[0] == NEWLINE_CHAR) { if (newlines++ == 0) { *(q++) = POINT_CHAR; *(q++) = BLANK_CHAR; *(q++) = '('; } else { *(q++) = BLANK_CHAR; } suppress_blank = A68_TRUE; str++; } else if (IS_SPACE (str[0])) { if (suppress_blank) { str++; } else { if (str[1] != NEWLINE_CHAR) { *(q++) = BLANK_CHAR; } str++; suppress_blank = A68_TRUE; } } else { *(q++) = *(str++); suppress_blank = A68_FALSE; } } if (newlines > 0) { *(q++) = ')'; } q[0] = NULL_CHAR; return (edt); } } /*! \brief PROC pq errormessage (REF FILE) INT \param p position in tree **/ void genie_pq_errormessage (NODE_T * p) { A68_REF ref_file; A68_FILE *file; POP_REF (p, &ref_file); CHECK_REF (p, ref_file, MODE (REF_FILE)); file = FILE_DEREF (&ref_file); CHECK_INIT (p, INITIALISED (file), MODE (FILE)); if (CONNECTION (file) == NO_PGCONN) { PUSH_PRIMAL (p, -1, INT); return; } if (!IS_NIL (STRING (file))) { char str[BUFFER_SIZE]; int upb; if (PQerrorMessage (CONNECTION (file)) != NULL) { bufcpy (str, pq_edit (PQerrorMessage (CONNECTION (file))), BUFFER_SIZE); upb = (int) strlen (str); if (upb > 0 && str[upb - 1] == NEWLINE_CHAR) { str[upb - 1] = NULL_CHAR; } } else { bufcpy (str, "no error message available", BUFFER_SIZE); } * DEREF (A68_REF, &STRING (file)) = c_to_a_string (p, str, DEFAULT_WIDTH); STRPOS (file) = 1; PUSH_PRIMAL (p, 0, INT); } else { PUSH_PRIMAL (p, -3, INT); } } /*! \brief PROC pq resulterrormessage (REF FILE) INT \param p position in tree **/ void genie_pq_resulterrormessage (NODE_T * p) { A68_REF ref_file; A68_FILE *file; POP_REF (p, &ref_file); CHECK_REF (p, ref_file, MODE (REF_FILE)); file = FILE_DEREF (&ref_file); CHECK_INIT (p, INITIALISED (file), MODE (FILE)); if (CONNECTION (file) == NO_PGCONN) { PUSH_PRIMAL (p, -1, INT); return; } if (RESULT (file) == NO_PGRESULT) { PUSH_PRIMAL (p, -2, INT); return; } if (!IS_NIL (STRING (file))) { char str[BUFFER_SIZE]; int upb; if (PQresultErrorMessage (RESULT (file)) != NULL) { bufcpy (str, pq_edit (PQresultErrorMessage (RESULT (file))), BUFFER_SIZE); upb = (int) strlen (str); if (upb > 0 && str[upb - 1] == NEWLINE_CHAR) { str[upb - 1] = NULL_CHAR; } } else { bufcpy (str, "no error message available", BUFFER_SIZE); } * DEREF (A68_REF, &STRING (file)) = c_to_a_string (p, str, DEFAULT_WIDTH); STRPOS (file) = 1; PUSH_PRIMAL (p, 0, INT); } else { PUSH_PRIMAL (p, -3, INT); } } /*! \brief PROC pq db (REF FILE) INT \param p position in tree **/ void genie_pq_db (NODE_T * p) { A68_REF ref_file; A68_FILE *file; POP_REF (p, &ref_file); CHECK_REF (p, ref_file, MODE (REF_FILE)); file = FILE_DEREF (&ref_file); CHECK_INIT (p, INITIALISED (file), MODE (FILE)); if (CONNECTION (file) == NO_PGCONN) { PUSH_PRIMAL (p, -1, INT); return; } if (!IS_NIL (STRING (file))) { * DEREF (A68_REF, &STRING (file)) = c_to_a_string (p, PQdb (CONNECTION (file)), DEFAULT_WIDTH); STRPOS (file) = 1; PUSH_PRIMAL (p, 0, INT); } else { PUSH_PRIMAL (p, -3, INT); } } /*! \brief PROC pq user (REF FILE) INT \param p position in tree **/ void genie_pq_user (NODE_T * p) { A68_REF ref_file; A68_FILE *file; POP_REF (p, &ref_file); CHECK_REF (p, ref_file, MODE (REF_FILE)); file = FILE_DEREF (&ref_file); CHECK_INIT (p, INITIALISED (file), MODE (FILE)); if (CONNECTION (file) == NO_PGCONN) { PUSH_PRIMAL (p, -1, INT); return; } if (!IS_NIL (STRING (file))) { * DEREF (A68_REF, &STRING (file)) = c_to_a_string (p, PQuser (CONNECTION (file)), DEFAULT_WIDTH); STRPOS (file) = 1; PUSH_PRIMAL (p, 0, INT); } else { PUSH_PRIMAL (p, -3, INT); } } /*! \brief PROC pq pass (REF FILE) INT \param p position in tree **/ void genie_pq_pass (NODE_T * p) { A68_REF ref_file; A68_FILE *file; POP_REF (p, &ref_file); CHECK_REF (p, ref_file, MODE (REF_FILE)); file = FILE_DEREF (&ref_file); CHECK_INIT (p, INITIALISED (file), MODE (FILE)); if (CONNECTION (file) == NO_PGCONN) { PUSH_PRIMAL (p, -1, INT); return; } if (!IS_NIL (STRING (file))) { * DEREF (A68_REF, &STRING (file)) = c_to_a_string (p, PQpass (CONNECTION (file)), DEFAULT_WIDTH); STRPOS (file) = 1; PUSH_PRIMAL (p, 0, INT); } else { PUSH_PRIMAL (p, -3, INT); } } /*! \brief PROC pq host (REF FILE) INT \param p position in tree **/ void genie_pq_host (NODE_T * p) { A68_REF ref_file; A68_FILE *file; POP_REF (p, &ref_file); CHECK_REF (p, ref_file, MODE (REF_FILE)); file = FILE_DEREF (&ref_file); CHECK_INIT (p, INITIALISED (file), MODE (FILE)); if (CONNECTION (file) == NO_PGCONN) { PUSH_PRIMAL (p, -1, INT); return; } if (!IS_NIL (STRING (file))) { * DEREF (A68_REF, &STRING (file)) = c_to_a_string (p, PQhost (CONNECTION (file)), DEFAULT_WIDTH); STRPOS (file) = 1; PUSH_PRIMAL (p, 0, INT); } else { PUSH_PRIMAL (p, -3, INT); } } /*! \brief PROC pq port (REF FILE) INT \param p position in tree **/ void genie_pq_port (NODE_T * p) { A68_REF ref_file; A68_FILE *file; POP_REF (p, &ref_file); CHECK_REF (p, ref_file, MODE (REF_FILE)); file = FILE_DEREF (&ref_file); CHECK_INIT (p, INITIALISED (file), MODE (FILE)); if (CONNECTION (file) == NO_PGCONN) { PUSH_PRIMAL (p, -1, INT); return; } if (!IS_NIL (STRING (file))) { * DEREF (A68_REF, &STRING (file)) = c_to_a_string (p, PQport (CONNECTION (file)), DEFAULT_WIDTH); STRPOS (file) = 1; PUSH_PRIMAL (p, 0, INT); } else { PUSH_PRIMAL (p, -3, INT); } } /*! \brief PROC pq tty (REF FILE) INT \param p position in tree **/ void genie_pq_tty (NODE_T * p) { A68_REF ref_file; A68_FILE *file; POP_REF (p, &ref_file); CHECK_REF (p, ref_file, MODE (REF_FILE)); file = FILE_DEREF (&ref_file); CHECK_INIT (p, INITIALISED (file), MODE (FILE)); if (CONNECTION (file) == NO_PGCONN) { PUSH_PRIMAL (p, -1, INT); return; } if (!IS_NIL (STRING (file))) { * DEREF (A68_REF, &STRING (file)) = c_to_a_string (p, PQtty (CONNECTION (file)), DEFAULT_WIDTH); STRPOS (file) = 1; PUSH_PRIMAL (p, 0, INT); } else { PUSH_PRIMAL (p, -3, INT); } } /*! \brief PROC pq options (REF FILE) INT \param p position in tree **/ void genie_pq_options (NODE_T * p) { A68_REF ref_file; A68_FILE *file; POP_REF (p, &ref_file); CHECK_REF (p, ref_file, MODE (REF_FILE)); file = FILE_DEREF (&ref_file); CHECK_INIT (p, INITIALISED (file), MODE (FILE)); if (CONNECTION (file) == NO_PGCONN) { PUSH_PRIMAL (p, -1, INT); return; } if (!IS_NIL (STRING (file))) { * DEREF (A68_REF, &STRING (file)) = c_to_a_string (p, PQoptions (CONNECTION (file)), DEFAULT_WIDTH); STRPOS (file) = 1; PUSH_PRIMAL (p, 0, INT); } else { PUSH_PRIMAL (p, -3, INT); } } /*! \brief PROC pq protocol version (REF FILE) INT \param p position in tree **/ void genie_pq_protocolversion (NODE_T * p) { A68_REF ref_file; A68_FILE *file; POP_REF (p, &ref_file); CHECK_REF (p, ref_file, MODE (REF_FILE)); file = FILE_DEREF (&ref_file); CHECK_INIT (p, INITIALISED (file), MODE (FILE)); if (CONNECTION (file) == NO_PGCONN) { PUSH_PRIMAL (p, -1, INT); return; } if (!IS_NIL (STRING (file))) { PUSH_PRIMAL (p, PQprotocolVersion (CONNECTION (file)), INT); } else { PUSH_PRIMAL (p, -3, INT); } } /*! \brief PROC pq server version (REF FILE) INT \param p position in tree **/ void genie_pq_serverversion (NODE_T * p) { A68_REF ref_file; A68_FILE *file; POP_REF (p, &ref_file); CHECK_REF (p, ref_file, MODE (REF_FILE)); file = FILE_DEREF (&ref_file); CHECK_INIT (p, INITIALISED (file), MODE (FILE)); if (CONNECTION (file) == NO_PGCONN) { PUSH_PRIMAL (p, -1, INT); return; } if (!IS_NIL (STRING (file))) { PUSH_PRIMAL (p, PQserverVersion (CONNECTION (file)), INT); } else { PUSH_PRIMAL (p, -3, INT); } } /*! \brief PROC pq socket (REF FILE) INT \param p position in tree **/ void genie_pq_socket (NODE_T * p) { A68_REF ref_file; A68_FILE *file; POP_REF (p, &ref_file); CHECK_REF (p, ref_file, MODE (REF_FILE)); file = FILE_DEREF (&ref_file); CHECK_INIT (p, INITIALISED (file), MODE (FILE)); if (CONNECTION (file) == NO_PGCONN) { PUSH_PRIMAL (p, -1, INT); return; } if (!IS_NIL (STRING (file))) { PUSH_PRIMAL (p, PQsocket (CONNECTION (file)), INT); } else { PUSH_PRIMAL (p, -3, INT); } } /*! \brief PROC pq backend pid (REF FILE) INT \param p position in tree **/ void genie_pq_backendpid (NODE_T * p) { A68_REF ref_file; A68_FILE *file; POP_REF (p, &ref_file); CHECK_REF (p, ref_file, MODE (REF_FILE)); file = FILE_DEREF (&ref_file); CHECK_INIT (p, INITIALISED (file), MODE (FILE)); if (CONNECTION (file) == NO_PGCONN) { PUSH_PRIMAL (p, -1, INT); return; } if (!IS_NIL (STRING (file))) { PUSH_PRIMAL (p, PQbackendPID (CONNECTION (file)), INT); } else { PUSH_PRIMAL (p, -3, INT); } } #endif /* HAVE_POSTGRESQL */ algol68g-2.4.1/source/a68g-config.h.in0000644000175000001440000002307711771657234014172 00000000000000/* source/a68g-config.h.in. Generated from configure.ac by autoheader. */ /* Define to 1 if `TIOCGWINSZ' requires . */ #undef GWINSZ_IN_SYS_IOCTL /* Define to 1 if you have the header file. */ #undef HAVE_ASSERT_H /* Define to 1 if you have the header file. */ #undef HAVE_CTYPE_H /* Define this if curses was detected */ #undef HAVE_CURSES /* Define to 1 if you have the header file. */ #undef HAVE_CURSES_H /* Define to 1 if you have the header file, and it defines `DIR'. */ #undef HAVE_DIRENT_H /* Define this if a good DL installation was detected */ #undef HAVE_DL /* Define to 1 if you have the header file. */ #undef HAVE_DLFCN_H /* Define to 1 if you have the header file. */ #undef HAVE_ERRNO_H /* Define to 1 if you have the `exit' function. */ #undef HAVE_EXIT /* Define this if EXPORT_DYNAMIC is recognised */ #undef HAVE_EXPORT_DYNAMIC /* Define to 1 if you have the header file. */ #undef HAVE_FCNTL_H /* Define to 1 if you have the header file. */ #undef HAVE_FLOAT_H /* Define to 1 if you have the `fprintf' function. */ #undef HAVE_FPRINTF /* Define to 1 if you have the `free' function. */ #undef HAVE_FREE /* Define this if FreeBSD was detected */ #undef HAVE_FREEBSD /* Define this if GCC was detected */ #undef HAVE_GCC /* Define this if a good GNU GSL installation was detected */ #undef HAVE_GNU_GSL /* Define this if a good GNU plotutils installation was detected */ #undef HAVE_GNU_PLOTUTILS /* Define to 1 if you have the header file. */ #undef HAVE_GSL_GSL_BLAS_H /* Define to 1 if you have the header file. */ #undef HAVE_GSL_GSL_COMPLEX_H /* Define to 1 if you have the header file. */ #undef HAVE_GSL_GSL_COMPLEX_MATH_H /* Define to 1 if you have the header file. */ #undef HAVE_GSL_GSL_ERRNO_H /* Define to 1 if you have the header file. */ #undef HAVE_GSL_GSL_FFT_COMPLEX_H /* Define to 1 if you have the header file. */ #undef HAVE_GSL_GSL_INTEGRATION_H /* Define to 1 if you have the header file. */ #undef HAVE_GSL_GSL_LINALG_H /* Define to 1 if you have the header file. */ #undef HAVE_GSL_GSL_MATH_H /* Define to 1 if you have the header file. */ #undef HAVE_GSL_GSL_MATRIX_H /* Define to 1 if you have the header file. */ #undef HAVE_GSL_GSL_PERMUTATION_H /* Define to 1 if you have the header file. */ #undef HAVE_GSL_GSL_SF_H /* Define to 1 if you have the header file. */ #undef HAVE_GSL_GSL_VECTOR_H /* Define this if IEEE_754 compliant */ #undef HAVE_IEEE_754 /* Define to 1 if you have the header file. */ #undef HAVE_INTTYPES_H /* Define to 1 if you have the `dl' library (-ldl). */ #undef HAVE_LIBDL /* Define to 1 if you have the `gsl' library (-lgsl). */ #undef HAVE_LIBGSL /* Define to 1 if you have the `gslcblas' library (-lgslcblas). */ #undef HAVE_LIBGSLCBLAS /* Define to 1 if you have the `m' library (-lm). */ #undef HAVE_LIBM /* Define to 1 if you have the `ncurses' library (-lncurses). */ #undef HAVE_LIBNCURSES /* Define to 1 if you have the `plot' library (-lplot). */ #undef HAVE_LIBPLOT /* Define to 1 if you have the `pq' library (-lpq). */ #undef HAVE_LIBPQ /* Define to 1 if you have the header file. */ #undef HAVE_LIBPQ_FE_H /* Define to 1 if you have the `pthread' library (-lpthread). */ #undef HAVE_LIBPTHREAD /* Define to 1 if you have the `readline' library (-lreadline). */ #undef HAVE_LIBREADLINE /* Define to 1 if you have the header file. */ #undef HAVE_LIMITS_H /* Define this if LINUX was detected */ #undef HAVE_LINUX /* Define to 1 if you have the `longjmp' function. */ #undef HAVE_LONGJMP /* Define this if DARWIN was detected */ #undef HAVE_MAC_OS_X /* Define to 1 if you have the `malloc' function. */ #undef HAVE_MALLOC /* Define to 1 if you have the header file. */ #undef HAVE_MATH_H /* Define to 1 if you have the `memcpy' function. */ #undef HAVE_MEMCPY /* Define to 1 if you have the `memmove' function. */ #undef HAVE_MEMMOVE /* Define to 1 if you have the header file. */ #undef HAVE_MEMORY_H /* Define to 1 if you have the `memset' function. */ #undef HAVE_MEMSET /* Define to 1 if you have the header file. */ #undef HAVE_NCURSES_CURSES_H /* Define to 1 if you have the header file, and it defines `DIR'. */ #undef HAVE_NDIR_H /* Define this if NetBSD was detected */ #undef HAVE_NETBSD /* Define to 1 if you have the header file. */ #undef HAVE_NETDB_H /* Define to 1 if you have the header file. */ #undef HAVE_NETINET_IN_H /* Define this if OpenBSD was detected */ #undef HAVE_OPENBSD /* Define this if /opt/local/pgsql/include was detected */ #undef HAVE_OPT_LOCAL_PGSQL_INCLUDE /* Define this if a good pthread installation was detected */ #undef HAVE_PARALLEL_CLAUSE /* Define this as PIC option */ #undef HAVE_PIC /* Define to 1 if you have the header file. */ #undef HAVE_PLOT_H /* Define this if a good PostgreSQL installation was detected */ #undef HAVE_POSTGRESQL /* Define to 1 if you have the `printf' function. */ #undef HAVE_PRINTF /* Define to 1 if you have the header file. */ #undef HAVE_PTHREAD_H /* Define this if readline was detected */ #undef HAVE_READLINE /* Define to 1 if you have the header file. */ #undef HAVE_READLINE_HISTORY_H /* Define to 1 if you have the header file. */ #undef HAVE_READLINE_READLINE_H /* Define to 1 if you have the header file. */ #undef HAVE_REGEX_H /* Define to 1 if you have the `setjmp' function. */ #undef HAVE_SETJMP /* Define to 1 if you have the header file. */ #undef HAVE_SETJMP_H /* Define to 1 if you have the `signal' function. */ #undef HAVE_SIGNAL /* Define to 1 if you have the header file. */ #undef HAVE_SIGNAL_H /* Define to 1 if you have the `snprintf' function. */ #undef HAVE_SNPRINTF /* Define to 1 if you have the header file. */ #undef HAVE_STDARG_H /* Define to 1 if you have the header file. */ #undef HAVE_STDDEF_H /* Define to 1 if you have the header file. */ #undef HAVE_STDINT_H /* Define to 1 if you have the header file. */ #undef HAVE_STDIO_H /* Define to 1 if you have the header file. */ #undef HAVE_STDLIB_H /* Define to 1 if you have the `strcmp' function. */ #undef HAVE_STRCMP /* Define to 1 if you have the header file. */ #undef HAVE_STRINGS_H /* Define to 1 if you have the header file. */ #undef HAVE_STRING_H /* Define to 1 if you have the `strncmp' function. */ #undef HAVE_STRNCMP /* Define to 1 if you have the `strncpy' function. */ #undef HAVE_STRNCPY /* Define to 1 if you have the header file, and it defines `DIR'. */ #undef HAVE_SYS_DIR_H /* Define to 1 if you have the header file. */ #undef HAVE_SYS_IOCTL_H /* Define to 1 if you have the header file, and it defines `DIR'. */ #undef HAVE_SYS_NDIR_H /* Define to 1 if you have the header file. */ #undef HAVE_SYS_RESOURCE_H /* Define to 1 if you have the header file. */ #undef HAVE_SYS_SOCKET_H /* Define to 1 if you have the header file. */ #undef HAVE_SYS_STAT_H /* Define to 1 if you have the header file. */ #undef HAVE_SYS_TIME_H /* Define to 1 if you have the header file. */ #undef HAVE_SYS_TYPES_H /* Define to 1 if you have that is POSIX.1 compatible. */ #undef HAVE_SYS_WAIT_H /* Define to 1 if you have the header file. */ #undef HAVE_TERMIOS_H /* Define to 1 if you have the header file. */ #undef HAVE_TIME_H /* Define this if user wants to tune for a specific CPU */ #undef HAVE_TUNING /* Define to 1 if you have the header file. */ #undef HAVE_UNISTD_H /* Define this if untested OS was detected */ #undef HAVE_UNTESTED /* Define this if /usr/local/pgsql/include was detected */ #undef HAVE_USR_LOCAL_PGSQL_INCLUDE /* Define this if /usr/pkg/pgsql/include was detected */ #undef HAVE_USR_PKG_PGSQL_INCLUDE /* Define to 1 if assertions should be disabled. */ #undef NDEBUG /* Define to 1 if your C compiler doesn't accept -c and -o together. */ #undef NO_MINUS_C_MINUS_O /* Name of package */ #undef PACKAGE /* Define to the address where bug reports for this package should be sent. */ #undef PACKAGE_BUGREPORT /* Define to the full name of this package. */ #undef PACKAGE_NAME /* Define to the full name and version of this package. */ #undef PACKAGE_STRING /* Define to the one symbol short name of this package. */ #undef PACKAGE_TARNAME /* Define to the version of this package. */ #undef PACKAGE_VERSION /* Define to 1 if you have the ANSI C header files. */ #undef STDC_HEADERS /* Version number of package */ #undef VERSION /* Define to 1 if type `char' is unsigned and you are not using gcc. */ #ifndef __CHAR_UNSIGNED__ # undef __CHAR_UNSIGNED__ #endif /* Define this if we have no __mode_t */ #undef __mode_t /* Define this if we have no __off_t */ #undef __off_t /* Define this if we have no __pid_t */ #undef __pid_t /* Define to `int' if does not define. */ #undef mode_t /* Define to `unsigned int' if does not define. */ #undef size_t /* Define to `int' if does not define. */ #undef ssize_t /* Define to the type of an unsigned integer type of width exactly 16 bits if such a type exists and the standard includes do not define it. */ #undef uint16_t algol68g-2.4.1/source/plotutils.c0000644000175000001440000015522311767464642013612 00000000000000/*! \file plotutils.c \brief interface to libplot */ /* This file is part of Algol68G - an Algol 68 interpreter. Copyright (C) 2001-2012 J. Marcel van der Veer . This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 3 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see . */ #include "a68g.h" #if defined HAVE_GNU_PLOTUTILS /* 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". */ #define MAXIMUM(x, y) ((x) > (y) ? (x) : (y)) /* This part contains names for 24-bit colours recognised by libplot. The table below is based on the "rgb.txt" file distributed with X11R6. */ struct COLOUR_INFO { char *name; int red, green, blue; }; typedef struct COLOUR_INFO colour_info; #define COLOUR_MAX 65535 #define COLOUR_NAMES 668 const colour_info A68_COLOURS[COLOUR_NAMES + 1] = { {"aliceblue", 0xf0, 0xf8, 0xff}, {"aluminium", 0xaa, 0xac, 0xb7}, {"aluminum", 0xaa, 0xac, 0xb7}, {"antiquewhite", 0xfa, 0xeb, 0xd7}, {"antiquewhite1", 0xff, 0xef, 0xdb}, {"antiquewhite2", 0xee, 0xdf, 0xcc}, {"antiquewhite3", 0xcd, 0xc0, 0xb0}, {"antiquewhite4", 0x8b, 0x83, 0x78}, {"aquamarine", 0x7f, 0xff, 0xd4}, {"aquamarine1", 0x7f, 0xff, 0xd4}, {"aquamarine2", 0x76, 0xee, 0xc6}, {"aquamarine3", 0x66, 0xcd, 0xaa}, {"aquamarine4", 0x45, 0x8b, 0x74}, {"azure", 0xf0, 0xff, 0xff}, {"azure1", 0xf0, 0xff, 0xff}, {"azure2", 0xe0, 0xee, 0xee}, {"azure3", 0xc1, 0xcd, 0xcd}, {"azure4", 0x83, 0x8b, 0x8b}, {"beige", 0xf5, 0xf5, 0xdc}, {"bisque", 0xff, 0xe4, 0xc4}, {"bisque1", 0xff, 0xe4, 0xc4}, {"bisque2", 0xee, 0xd5, 0xb7}, {"bisque3", 0xcd, 0xb7, 0x9e}, {"bisque4", 0x8b, 0x7d, 0x6b}, {"black", 0x00, 0x00, 0x00}, {"blanchedalmond", 0xff, 0xeb, 0xcd}, {"blue", 0x00, 0x00, 0xff}, {"blue1", 0x00, 0x00, 0xff}, {"blue2", 0x00, 0x00, 0xee}, {"blue3", 0x00, 0x00, 0xcd}, {"blue4", 0x00, 0x00, 0x8b}, {"blueviolet", 0x8a, 0x2b, 0xe2}, {"bondi1", 0x02, 0x48, 0x8f}, {"brown", 0xa5, 0x2a, 0x2a}, {"brown1", 0xff, 0x40, 0x40}, {"brown2", 0xee, 0x3b, 0x3b}, {"brown3", 0xcd, 0x33, 0x33}, {"brown4", 0x8b, 0x23, 0x23}, {"burlywood", 0xde, 0xb8, 0x87}, {"burlywood1", 0xff, 0xd3, 0x9b}, {"burlywood2", 0xee, 0xc5, 0x91}, {"burlywood3", 0xcd, 0xaa, 0x7d}, {"burlywood4", 0x8b, 0x73, 0x55}, {"cadetblue", 0x5f, 0x9e, 0xa0}, {"cadetblue1", 0x98, 0xf5, 0xff}, {"cadetblue2", 0x8e, 0xe5, 0xee}, {"cadetblue3", 0x7a, 0xc5, 0xcd}, {"cadetblue4", 0x53, 0x86, 0x8b}, {"chartreuse", 0x7f, 0xff, 0x00}, {"chartreuse1", 0x7f, 0xff, 0x00}, {"chartreuse2", 0x76, 0xee, 0x00}, {"chartreuse3", 0x66, 0xcd, 0x00}, {"chartreuse4", 0x45, 0x8b, 0x00}, {"chocolate", 0xd2, 0x69, 0x1e}, {"chocolate1", 0xff, 0x7f, 0x24}, {"chocolate2", 0xee, 0x76, 0x21}, {"chocolate3", 0xcd, 0x66, 0x1d}, {"chocolate4", 0x8b, 0x45, 0x13}, {"coral", 0xff, 0x7f, 0x50}, {"coral1", 0xff, 0x72, 0x56}, {"coral2", 0xee, 0x6a, 0x50}, {"coral3", 0xcd, 0x5b, 0x45}, {"coral4", 0x8b, 0x3e, 0x2f}, {"cornflowerblue", 0x64, 0x95, 0xed}, {"cornsilk", 0xff, 0xf8, 0xdc}, {"cornsilk1", 0xff, 0xf8, 0xdc}, {"cornsilk2", 0xee, 0xe8, 0xcd}, {"cornsilk3", 0xcd, 0xc8, 0xb1}, {"cornsilk4", 0x8b, 0x88, 0x78}, {"cyan", 0x00, 0xff, 0xff}, {"cyan1", 0x00, 0xff, 0xff}, {"cyan2", 0x00, 0xee, 0xee}, {"cyan3", 0x00, 0xcd, 0xcd}, {"cyan4", 0x00, 0x8b, 0x8b}, {"darkblue", 0x00, 0x00, 0x8b}, {"darkcyan", 0x00, 0x8b, 0x8b}, {"darkgoldenrod", 0xb8, 0x86, 0x0b}, {"darkgoldenrod1", 0xff, 0xb9, 0x0f}, {"darkgoldenrod2", 0xee, 0xad, 0x0e}, {"darkgoldenrod3", 0xcd, 0x95, 0x0c}, {"darkgoldenrod4", 0x8b, 0x65, 0x08}, {"darkgray", 0xa9, 0xa9, 0xa9}, {"darkgreen", 0x00, 0x64, 0x00}, {"darkgrey", 0xa9, 0xa9, 0xa9}, {"darkkhaki", 0xbd, 0xb7, 0x6b}, {"darkmagenta", 0x8b, 0x00, 0x8b}, {"darkolivegreen", 0x55, 0x6b, 0x2f}, {"darkolivegreen1", 0xca, 0xff, 0x70}, {"darkolivegreen2", 0xbc, 0xee, 0x68}, {"darkolivegreen3", 0xa2, 0xcd, 0x5a}, {"darkolivegreen4", 0x6e, 0x8b, 0x3d}, {"darkorange", 0xff, 0x8c, 0x00}, {"darkorange1", 0xff, 0x7f, 0x00}, {"darkorange2", 0xee, 0x76, 0x00}, {"darkorange3", 0xcd, 0x66, 0x00}, {"darkorange4", 0x8b, 0x45, 0x00}, {"darkorchid", 0x99, 0x32, 0xcc}, {"darkorchid1", 0xbf, 0x3e, 0xff}, {"darkorchid2", 0xb2, 0x3a, 0xee}, {"darkorchid3", 0x9a, 0x32, 0xcd}, {"darkorchid4", 0x68, 0x22, 0x8b}, {"darkred", 0x8b, 0x00, 0x00}, {"darksalmon", 0xe9, 0x96, 0x7a}, {"darkseagreen", 0x8f, 0xbc, 0x8f}, {"darkseagreen1", 0xc1, 0xff, 0xc1}, {"darkseagreen2", 0xb4, 0xee, 0xb4}, {"darkseagreen3", 0x9b, 0xcd, 0x9b}, {"darkseagreen4", 0x69, 0x8b, 0x69}, {"darkslateblue", 0x48, 0x3d, 0x8b}, {"darkslategray", 0x2f, 0x4f, 0x4f}, {"darkslategray1", 0x97, 0xff, 0xff}, {"darkslategray2", 0x8d, 0xee, 0xee}, {"darkslategray3", 0x79, 0xcd, 0xcd}, {"darkslategray4", 0x52, 0x8b, 0x8b}, {"darkslategrey", 0x2f, 0x4f, 0x4f}, {"darkslategrey1", 0x97, 0xff, 0xff}, {"darkslategrey2", 0x8d, 0xee, 0xee}, {"darkslategrey3", 0x79, 0xcd, 0xcd}, {"darkslategrey4", 0x52, 0x8b, 0x8b}, {"darkturquoise", 0x00, 0xce, 0xd1}, {"darkviolet", 0x94, 0x00, 0xd3}, {"deeppink", 0xff, 0x14, 0x93}, {"deeppink1", 0xff, 0x14, 0x93}, {"deeppink2", 0xee, 0x12, 0x89}, {"deeppink3", 0xcd, 0x10, 0x76}, {"deeppink4", 0x8b, 0x0a, 0x50}, {"deepskyblue", 0x00, 0xbf, 0xff}, {"deepskyblue1", 0x00, 0xbf, 0xff}, {"deepskyblue2", 0x00, 0xb2, 0xee}, {"deepskyblue3", 0x00, 0x9a, 0xcd}, {"deepskyblue4", 0x00, 0x68, 0x8b}, {"dimgray", 0x69, 0x69, 0x69}, {"dimgrey", 0x69, 0x69, 0x69}, {"dodgerblue", 0x1e, 0x90, 0xff}, {"dodgerblue1", 0x1e, 0x90, 0xff}, {"dodgerblue2", 0x1c, 0x86, 0xee}, {"dodgerblue3", 0x18, 0x74, 0xcd}, {"dodgerblue4", 0x10, 0x4e, 0x8b}, {"firebrick", 0xb2, 0x22, 0x22}, {"firebrick1", 0xff, 0x30, 0x30}, {"firebrick2", 0xee, 0x2c, 0x2c}, {"firebrick3", 0xcd, 0x26, 0x26}, {"firebrick4", 0x8b, 0x1a, 0x1a}, {"floralwhite", 0xff, 0xfa, 0xf0}, {"forestgreen", 0x22, 0x8b, 0x22}, {"gainsboro", 0xdc, 0xdc, 0xdc}, {"ghostwhite", 0xf8, 0xf8, 0xff}, {"gold", 0xff, 0xd7, 0x00}, {"gold1", 0xff, 0xd7, 0x00}, {"gold2", 0xee, 0xc9, 0x00}, {"gold3", 0xcd, 0xad, 0x00}, {"gold4", 0x8b, 0x75, 0x00}, {"goldenrod", 0xda, 0xa5, 0x20}, {"goldenrod1", 0xff, 0xc1, 0x25}, {"goldenrod2", 0xee, 0xb4, 0x22}, {"goldenrod3", 0xcd, 0x9b, 0x1d}, {"goldenrod4", 0x8b, 0x69, 0x14}, {"gray", 0xbe, 0xbe, 0xbe}, {"gray0", 0x00, 0x00, 0x00}, {"gray1", 0x03, 0x03, 0x03}, {"gray2", 0x05, 0x05, 0x05}, {"gray3", 0x08, 0x08, 0x08}, {"gray4", 0x0a, 0x0a, 0x0a}, {"gray5", 0x0d, 0x0d, 0x0d}, {"gray6", 0x0f, 0x0f, 0x0f}, {"gray7", 0x12, 0x12, 0x12}, {"gray8", 0x14, 0x14, 0x14}, {"gray9", 0x17, 0x17, 0x17}, {"gray10", 0x1a, 0x1a, 0x1a}, {"gray11", 0x1c, 0x1c, 0x1c}, {"gray12", 0x1f, 0x1f, 0x1f}, {"gray13", 0x21, 0x21, 0x21}, {"gray14", 0x24, 0x24, 0x24}, {"gray15", 0x26, 0x26, 0x26}, {"gray16", 0x29, 0x29, 0x29}, {"gray17", 0x2b, 0x2b, 0x2b}, {"gray18", 0x2e, 0x2e, 0x2e}, {"gray19", 0x30, 0x30, 0x30}, {"gray20", 0x33, 0x33, 0x33}, {"gray21", 0x36, 0x36, 0x36}, {"gray22", 0x38, 0x38, 0x38}, {"gray23", 0x3b, 0x3b, 0x3b}, {"gray24", 0x3d, 0x3d, 0x3d}, {"gray25", 0x40, 0x40, 0x40}, {"gray26", 0x42, 0x42, 0x42}, {"gray27", 0x45, 0x45, 0x45}, {"gray28", 0x47, 0x47, 0x47}, {"gray29", 0x4a, 0x4a, 0x4a}, {"gray30", 0x4d, 0x4d, 0x4d}, {"gray31", 0x4f, 0x4f, 0x4f}, {"gray32", 0x52, 0x52, 0x52}, {"gray33", 0x54, 0x54, 0x54}, {"gray34", 0x57, 0x57, 0x57}, {"gray35", 0x59, 0x59, 0x59}, {"gray36", 0x5c, 0x5c, 0x5c}, {"gray37", 0x5e, 0x5e, 0x5e}, {"gray38", 0x61, 0x61, 0x61}, {"gray39", 0x63, 0x63, 0x63}, {"gray40", 0x66, 0x66, 0x66}, {"gray41", 0x69, 0x69, 0x69}, {"gray42", 0x6b, 0x6b, 0x6b}, {"gray43", 0x6e, 0x6e, 0x6e}, {"gray44", 0x70, 0x70, 0x70}, {"gray45", 0x73, 0x73, 0x73}, {"gray46", 0x75, 0x75, 0x75}, {"gray47", 0x78, 0x78, 0x78}, {"gray48", 0x7a, 0x7a, 0x7a}, {"gray49", 0x7d, 0x7d, 0x7d}, {"gray50", 0x7f, 0x7f, 0x7f}, {"gray51", 0x82, 0x82, 0x82}, {"gray52", 0x85, 0x85, 0x85}, {"gray53", 0x87, 0x87, 0x87}, {"gray54", 0x8a, 0x8a, 0x8a}, {"gray55", 0x8c, 0x8c, 0x8c}, {"gray56", 0x8f, 0x8f, 0x8f}, {"gray57", 0x91, 0x91, 0x91}, {"gray58", 0x94, 0x94, 0x94}, {"gray59", 0x96, 0x96, 0x96}, {"gray60", 0x99, 0x99, 0x99}, {"gray61", 0x9c, 0x9c, 0x9c}, {"gray62", 0x9e, 0x9e, 0x9e}, {"gray63", 0xa1, 0xa1, 0xa1}, {"gray64", 0xa3, 0xa3, 0xa3}, {"gray65", 0xa6, 0xa6, 0xa6}, {"gray66", 0xa8, 0xa8, 0xa8}, {"gray67", 0xab, 0xab, 0xab}, {"gray68", 0xad, 0xad, 0xad}, {"gray69", 0xb0, 0xb0, 0xb0}, {"gray70", 0xb3, 0xb3, 0xb3}, {"gray71", 0xb5, 0xb5, 0xb5}, {"gray72", 0xb8, 0xb8, 0xb8}, {"gray73", 0xba, 0xba, 0xba}, {"gray74", 0xbd, 0xbd, 0xbd}, {"gray75", 0xbf, 0xbf, 0xbf}, {"gray76", 0xc2, 0xc2, 0xc2}, {"gray77", 0xc4, 0xc4, 0xc4}, {"gray78", 0xc7, 0xc7, 0xc7}, {"gray79", 0xc9, 0xc9, 0xc9}, {"gray80", 0xcc, 0xcc, 0xcc}, {"gray81", 0xcf, 0xcf, 0xcf}, {"gray82", 0xd1, 0xd1, 0xd1}, {"gray83", 0xd4, 0xd4, 0xd4}, {"gray84", 0xd6, 0xd6, 0xd6}, {"gray85", 0xd9, 0xd9, 0xd9}, {"gray86", 0xdb, 0xdb, 0xdb}, {"gray87", 0xde, 0xde, 0xde}, {"gray88", 0xe0, 0xe0, 0xe0}, {"gray89", 0xe3, 0xe3, 0xe3}, {"gray90", 0xe5, 0xe5, 0xe5}, {"gray91", 0xe8, 0xe8, 0xe8}, {"gray92", 0xeb, 0xeb, 0xeb}, {"gray93", 0xed, 0xed, 0xed}, {"gray94", 0xf0, 0xf0, 0xf0}, {"gray95", 0xf2, 0xf2, 0xf2}, {"gray96", 0xf5, 0xf5, 0xf5}, {"gray97", 0xf7, 0xf7, 0xf7}, {"gray98", 0xfa, 0xfa, 0xfa}, {"gray99", 0xfc, 0xfc, 0xfc}, {"gray100", 0xff, 0xff, 0xff}, {"green", 0x00, 0xff, 0x00}, {"green1", 0x00, 0xff, 0x00}, {"green2", 0x00, 0xee, 0x00}, {"green3", 0x00, 0xcd, 0x00}, {"green4", 0x00, 0x8b, 0x00}, {"greenyellow", 0xad, 0xff, 0x2f}, {"grey", 0xbe, 0xbe, 0xbe}, {"grey0", 0x00, 0x00, 0x00}, {"grey1", 0x03, 0x03, 0x03}, {"grey2", 0x05, 0x05, 0x05}, {"grey3", 0x08, 0x08, 0x08}, {"grey4", 0x0a, 0x0a, 0x0a}, {"grey5", 0x0d, 0x0d, 0x0d}, {"grey6", 0x0f, 0x0f, 0x0f}, {"grey7", 0x12, 0x12, 0x12}, {"grey8", 0x14, 0x14, 0x14}, {"grey9", 0x17, 0x17, 0x17}, {"grey10", 0x1a, 0x1a, 0x1a}, {"grey11", 0x1c, 0x1c, 0x1c}, {"grey12", 0x1f, 0x1f, 0x1f}, {"grey13", 0x21, 0x21, 0x21}, {"grey14", 0x24, 0x24, 0x24}, {"grey15", 0x26, 0x26, 0x26}, {"grey16", 0x29, 0x29, 0x29}, {"grey17", 0x2b, 0x2b, 0x2b}, {"grey18", 0x2e, 0x2e, 0x2e}, {"grey19", 0x30, 0x30, 0x30}, {"grey20", 0x33, 0x33, 0x33}, {"grey21", 0x36, 0x36, 0x36}, {"grey22", 0x38, 0x38, 0x38}, {"grey23", 0x3b, 0x3b, 0x3b}, {"grey24", 0x3d, 0x3d, 0x3d}, {"grey25", 0x40, 0x40, 0x40}, {"grey26", 0x42, 0x42, 0x42}, {"grey27", 0x45, 0x45, 0x45}, {"grey28", 0x47, 0x47, 0x47}, {"grey29", 0x4a, 0x4a, 0x4a}, {"grey30", 0x4d, 0x4d, 0x4d}, {"grey31", 0x4f, 0x4f, 0x4f}, {"grey32", 0x52, 0x52, 0x52}, {"grey33", 0x54, 0x54, 0x54}, {"grey34", 0x57, 0x57, 0x57}, {"grey35", 0x59, 0x59, 0x59}, {"grey36", 0x5c, 0x5c, 0x5c}, {"grey37", 0x5e, 0x5e, 0x5e}, {"grey38", 0x61, 0x61, 0x61}, {"grey39", 0x63, 0x63, 0x63}, {"grey40", 0x66, 0x66, 0x66}, {"grey41", 0x69, 0x69, 0x69}, {"grey42", 0x6b, 0x6b, 0x6b}, {"grey43", 0x6e, 0x6e, 0x6e}, {"grey44", 0x70, 0x70, 0x70}, {"grey45", 0x73, 0x73, 0x73}, {"grey46", 0x75, 0x75, 0x75}, {"grey47", 0x78, 0x78, 0x78}, {"grey48", 0x7a, 0x7a, 0x7a}, {"grey49", 0x7d, 0x7d, 0x7d}, {"grey50", 0x7f, 0x7f, 0x7f}, {"grey51", 0x82, 0x82, 0x82}, {"grey52", 0x85, 0x85, 0x85}, {"grey53", 0x87, 0x87, 0x87}, {"grey54", 0x8a, 0x8a, 0x8a}, {"grey55", 0x8c, 0x8c, 0x8c}, {"grey56", 0x8f, 0x8f, 0x8f}, {"grey57", 0x91, 0x91, 0x91}, {"grey58", 0x94, 0x94, 0x94}, {"grey59", 0x96, 0x96, 0x96}, {"grey60", 0x99, 0x99, 0x99}, {"grey61", 0x9c, 0x9c, 0x9c}, {"grey62", 0x9e, 0x9e, 0x9e}, {"grey63", 0xa1, 0xa1, 0xa1}, {"grey64", 0xa3, 0xa3, 0xa3}, {"grey65", 0xa6, 0xa6, 0xa6}, {"grey66", 0xa8, 0xa8, 0xa8}, {"grey67", 0xab, 0xab, 0xab}, {"grey68", 0xad, 0xad, 0xad}, {"grey69", 0xb0, 0xb0, 0xb0}, {"grey70", 0xb3, 0xb3, 0xb3}, {"grey71", 0xb5, 0xb5, 0xb5}, {"grey72", 0xb8, 0xb8, 0xb8}, {"grey73", 0xba, 0xba, 0xba}, {"grey74", 0xbd, 0xbd, 0xbd}, {"grey75", 0xbf, 0xbf, 0xbf}, {"grey76", 0xc2, 0xc2, 0xc2}, {"grey77", 0xc4, 0xc4, 0xc4}, {"grey78", 0xc7, 0xc7, 0xc7}, {"grey79", 0xc9, 0xc9, 0xc9}, {"grey80", 0xcc, 0xcc, 0xcc}, {"grey81", 0xcf, 0xcf, 0xcf}, {"grey82", 0xd1, 0xd1, 0xd1}, {"grey83", 0xd4, 0xd4, 0xd4}, {"grey84", 0xd6, 0xd6, 0xd6}, {"grey85", 0xd9, 0xd9, 0xd9}, {"grey86", 0xdb, 0xdb, 0xdb}, {"grey87", 0xde, 0xde, 0xde}, {"grey88", 0xe0, 0xe0, 0xe0}, {"grey89", 0xe3, 0xe3, 0xe3}, {"grey90", 0xe5, 0xe5, 0xe5}, {"grey91", 0xe8, 0xe8, 0xe8}, {"grey92", 0xeb, 0xeb, 0xeb}, {"grey93", 0xed, 0xed, 0xed}, {"grey94", 0xf0, 0xf0, 0xf0}, {"grey95", 0xf2, 0xf2, 0xf2}, {"grey96", 0xf5, 0xf5, 0xf5}, {"grey97", 0xf7, 0xf7, 0xf7}, {"grey98", 0xfa, 0xfa, 0xfa}, {"grey99", 0xfc, 0xfc, 0xfc}, {"grey100", 0xff, 0xff, 0xff}, {"honeydew", 0xf0, 0xff, 0xf0}, {"honeydew1", 0xf0, 0xff, 0xf0}, {"honeydew2", 0xe0, 0xee, 0xe0}, {"honeydew3", 0xc1, 0xcd, 0xc1}, {"honeydew4", 0x83, 0x8b, 0x83}, {"hotpink", 0xff, 0x69, 0xb4}, {"hotpink1", 0xff, 0x6e, 0xb4}, {"hotpink2", 0xee, 0x6a, 0xa7}, {"hotpink3", 0xcd, 0x60, 0x90}, {"hotpink4", 0x8b, 0x3a, 0x62}, {"indianred", 0xcd, 0x5c, 0x5c}, {"indianred1", 0xff, 0x6a, 0x6a}, {"indianred2", 0xee, 0x63, 0x63}, {"indianred3", 0xcd, 0x55, 0x55}, {"indianred4", 0x8b, 0x3a, 0x3a}, {"ivory", 0xff, 0xff, 0xf0}, {"ivory1", 0xff, 0xff, 0xf0}, {"ivory2", 0xee, 0xee, 0xe0}, {"ivory3", 0xcd, 0xcd, 0xc1}, {"ivory4", 0x8b, 0x8b, 0x83}, {"khaki", 0xf0, 0xe6, 0x8c}, {"khaki1", 0xff, 0xf6, 0x8f}, {"khaki2", 0xee, 0xe6, 0x85}, {"khaki3", 0xcd, 0xc6, 0x73}, {"khaki4", 0x8b, 0x86, 0x4e}, {"lavender", 0xe6, 0xe6, 0xfa}, {"lavenderblush", 0xff, 0xf0, 0xf5}, {"lavenderblush1", 0xff, 0xf0, 0xf5}, {"lavenderblush2", 0xee, 0xe0, 0xe5}, {"lavenderblush3", 0xcd, 0xc1, 0xc5}, {"lavenderblush4", 0x8b, 0x83, 0x86}, {"lawngreen", 0x7c, 0xfc, 0x00}, {"lemonchiffon", 0xff, 0xfa, 0xcd}, {"lemonchiffon1", 0xff, 0xfa, 0xcd}, {"lemonchiffon2", 0xee, 0xe9, 0xbf}, {"lemonchiffon3", 0xcd, 0xc9, 0xa5}, {"lemonchiffon4", 0x8b, 0x89, 0x70}, {"lightblue", 0xad, 0xd8, 0xe6}, {"lightblue1", 0xbf, 0xef, 0xff}, {"lightblue2", 0xb2, 0xdf, 0xee}, {"lightblue3", 0x9a, 0xc0, 0xcd}, {"lightblue4", 0x68, 0x83, 0x8b}, {"lightcoral", 0xf0, 0x80, 0x80}, {"lightcyan", 0xe0, 0xff, 0xff}, {"lightcyan1", 0xe0, 0xff, 0xff}, {"lightcyan2", 0xd1, 0xee, 0xee}, {"lightcyan3", 0xb4, 0xcd, 0xcd}, {"lightcyan4", 0x7a, 0x8b, 0x8b}, {"lightgoldenrod", 0xee, 0xdd, 0x82}, {"lightgoldenrod1", 0xff, 0xec, 0x8b}, {"lightgoldenrod2", 0xee, 0xdc, 0x82}, {"lightgoldenrod3", 0xcd, 0xbe, 0x70}, {"lightgoldenrod4", 0x8b, 0x81, 0x4c}, {"lightgoldenrodyellow", 0xfa, 0xfa, 0xd2}, {"lightgray", 0xd3, 0xd3, 0xd3}, {"lightgreen", 0x90, 0xee, 0x90}, {"lightgrey", 0xd3, 0xd3, 0xd3}, {"lightpink", 0xff, 0xb6, 0xc1}, {"lightpink1", 0xff, 0xae, 0xb9}, {"lightpink2", 0xee, 0xa2, 0xad}, {"lightpink3", 0xcd, 0x8c, 0x95}, {"lightpink4", 0x8b, 0x5f, 0x65}, {"lightsalmon", 0xff, 0xa0, 0x7a}, {"lightsalmon1", 0xff, 0xa0, 0x7a}, {"lightsalmon2", 0xee, 0x95, 0x72}, {"lightsalmon3", 0xcd, 0x81, 0x62}, {"lightsalmon4", 0x8b, 0x57, 0x42}, {"lightseagreen", 0x20, 0xb2, 0xaa}, {"lightskyblue", 0x87, 0xce, 0xfa}, {"lightskyblue1", 0xb0, 0xe2, 0xff}, {"lightskyblue2", 0xa4, 0xd3, 0xee}, {"lightskyblue3", 0x8d, 0xb6, 0xcd}, {"lightskyblue4", 0x60, 0x7b, 0x8b}, {"lightslateblue", 0x84, 0x70, 0xff}, {"lightslategray", 0x77, 0x88, 0x99}, {"lightslategrey", 0x77, 0x88, 0x99}, {"lightsteelblue", 0xb0, 0xc4, 0xde}, {"lightsteelblue1", 0xca, 0xe1, 0xff}, {"lightsteelblue2", 0xbc, 0xd2, 0xee}, {"lightsteelblue3", 0xa2, 0xb5, 0xcd}, {"lightsteelblue4", 0x6e, 0x7b, 0x8b}, {"lightyellow", 0xff, 0xff, 0xe0}, {"lightyellow1", 0xff, 0xff, 0xe0}, {"lightyellow2", 0xee, 0xee, 0xd1}, {"lightyellow3", 0xcd, 0xcd, 0xb4}, {"lightyellow4", 0x8b, 0x8b, 0x7a}, {"limegreen", 0x32, 0xcd, 0x32}, {"linen", 0xfa, 0xf0, 0xe6}, {"magenta", 0xff, 0x00, 0xff}, {"magenta1", 0xff, 0x00, 0xff}, {"magenta2", 0xee, 0x00, 0xee}, {"magenta3", 0xcd, 0x00, 0xcd}, {"magenta4", 0x8b, 0x00, 0x8b}, {"maroon", 0xb0, 0x30, 0x60}, {"maroon1", 0xff, 0x34, 0xb3}, {"maroon2", 0xee, 0x30, 0xa7}, {"maroon3", 0xcd, 0x29, 0x90}, {"maroon4", 0x8b, 0x1c, 0x62}, {"mediumaquamarine", 0x66, 0xcd, 0xaa}, {"mediumblue", 0x00, 0x00, 0xcd}, {"mediumorchid", 0xba, 0x55, 0xd3}, {"mediumorchid1", 0xe0, 0x66, 0xff}, {"mediumorchid2", 0xd1, 0x5f, 0xee}, {"mediumorchid3", 0xb4, 0x52, 0xcd}, {"mediumorchid4", 0x7a, 0x37, 0x8b}, {"mediumpurple", 0x93, 0x70, 0xdb}, {"mediumpurple1", 0xab, 0x82, 0xff}, {"mediumpurple2", 0x9f, 0x79, 0xee}, {"mediumpurple3", 0x89, 0x68, 0xcd}, {"mediumpurple4", 0x5d, 0x47, 0x8b}, {"mediumseagreen", 0x3c, 0xb3, 0x71}, {"mediumslateblue", 0x7b, 0x68, 0xee}, {"mediumspringgreen", 0x00, 0xfa, 0x9a}, {"mediumturquoise", 0x48, 0xd1, 0xcc}, {"mediumvioletred", 0xc7, 0x15, 0x85}, {"midnightblue", 0x19, 0x19, 0x70}, {"mintcream", 0xf5, 0xff, 0xfa}, {"mistyrose", 0xff, 0xe4, 0xe1}, {"mistyrose1", 0xff, 0xe4, 0xe1}, {"mistyrose2", 0xee, 0xd5, 0xd2}, {"mistyrose3", 0xcd, 0xb7, 0xb5}, {"mistyrose4", 0x8b, 0x7d, 0x7b}, {"moccasin", 0xff, 0xe4, 0xb5}, {"navajowhite", 0xff, 0xde, 0xad}, {"navajowhite1", 0xff, 0xde, 0xad}, {"navajowhite2", 0xee, 0xcf, 0xa1}, {"navajowhite3", 0xcd, 0xb3, 0x8b}, {"navajowhite4", 0x8b, 0x79, 0x5e}, {"navy", 0x00, 0x00, 0x80}, {"navyblue", 0x00, 0x00, 0x80}, {"oldlace", 0xfd, 0xf5, 0xe6}, {"olivedrab", 0x6b, 0x8e, 0x23}, {"olivedrab1", 0xc0, 0xff, 0x3e}, {"olivedrab2", 0xb3, 0xee, 0x3a}, {"olivedrab3", 0x9a, 0xcd, 0x32}, {"olivedrab4", 0x69, 0x8b, 0x22}, {"orange", 0xff, 0xa5, 0x00}, {"orange1", 0xff, 0xa5, 0x00}, {"orange2", 0xee, 0x9a, 0x00}, {"orange3", 0xcd, 0x85, 0x00}, {"orange4", 0x8b, 0x5a, 0x00}, {"orangered", 0xff, 0x45, 0x00}, {"orangered1", 0xff, 0x45, 0x00}, {"orangered2", 0xee, 0x40, 0x00}, {"orangered3", 0xcd, 0x37, 0x00}, {"orangered4", 0x8b, 0x25, 0x00}, {"orchid", 0xda, 0x70, 0xd6}, {"orchid1", 0xff, 0x83, 0xfa}, {"orchid2", 0xee, 0x7a, 0xe9}, {"orchid3", 0xcd, 0x69, 0xc9}, {"orchid4", 0x8b, 0x47, 0x89}, {"palegoldenrod", 0xee, 0xe8, 0xaa}, {"palegreen", 0x98, 0xfb, 0x98}, {"palegreen1", 0x9a, 0xff, 0x9a}, {"palegreen2", 0x90, 0xee, 0x90}, {"palegreen3", 0x7c, 0xcd, 0x7c}, {"palegreen4", 0x54, 0x8b, 0x54}, {"paleturquoise", 0xaf, 0xee, 0xee}, {"paleturquoise1", 0xbb, 0xff, 0xff}, {"paleturquoise2", 0xae, 0xee, 0xee}, {"paleturquoise3", 0x96, 0xcd, 0xcd}, {"paleturquoise4", 0x66, 0x8b, 0x8b}, {"palevioletred", 0xdb, 0x70, 0x93}, {"palevioletred1", 0xff, 0x82, 0xab}, {"palevioletred2", 0xee, 0x79, 0x9f}, {"palevioletred3", 0xcd, 0x68, 0x89}, {"palevioletred4", 0x8b, 0x47, 0x5d}, {"papayawhip", 0xff, 0xef, 0xd5}, {"peachpuff", 0xff, 0xda, 0xb9}, {"peachpuff1", 0xff, 0xda, 0xb9}, {"peachpuff2", 0xee, 0xcb, 0xad}, {"peachpuff3", 0xcd, 0xaf, 0x95}, {"peachpuff4", 0x8b, 0x77, 0x65}, {"peru", 0xcd, 0x85, 0x3f}, {"pink", 0xff, 0xc0, 0xcb}, {"pink1", 0xff, 0xb5, 0xc5}, {"pink2", 0xee, 0xa9, 0xb8}, {"pink3", 0xcd, 0x91, 0x9e}, {"pink4", 0x8b, 0x63, 0x6c}, {"plum", 0xdd, 0xa0, 0xdd}, {"plum1", 0xff, 0xbb, 0xff}, {"plum2", 0xee, 0xae, 0xee}, {"plum3", 0xcd, 0x96, 0xcd}, {"plum4", 0x8b, 0x66, 0x8b}, {"powderblue", 0xb0, 0xe0, 0xe6}, {"purple", 0xa0, 0x20, 0xf0}, {"purple1", 0x9b, 0x30, 0xff}, {"purple2", 0x91, 0x2c, 0xee}, {"purple3", 0x7d, 0x26, 0xcd}, {"purple4", 0x55, 0x1a, 0x8b}, {"red", 0xff, 0x00, 0x00}, {"red1", 0xff, 0x00, 0x00}, {"red2", 0xee, 0x00, 0x00}, {"red3", 0xcd, 0x00, 0x00}, {"red4", 0x8b, 0x00, 0x00}, {"rosybrown", 0xbc, 0x8f, 0x8f}, {"rosybrown1", 0xff, 0xc1, 0xc1}, {"rosybrown2", 0xee, 0xb4, 0xb4}, {"rosybrown3", 0xcd, 0x9b, 0x9b}, {"rosybrown4", 0x8b, 0x69, 0x69}, {"royalblue", 0x41, 0x69, 0xe1}, {"royalblue1", 0x48, 0x76, 0xff}, {"royalblue2", 0x43, 0x6e, 0xee}, {"royalblue3", 0x3a, 0x5f, 0xcd}, {"royalblue4", 0x27, 0x40, 0x8b}, {"saddlebrown", 0x8b, 0x45, 0x13}, {"salmon", 0xfa, 0x80, 0x72}, {"salmon1", 0xff, 0x8c, 0x69}, {"salmon2", 0xee, 0x82, 0x62}, {"salmon3", 0xcd, 0x70, 0x54}, {"salmon4", 0x8b, 0x4c, 0x39}, {"sandybrown", 0xf4, 0xa4, 0x60}, {"seagreen", 0x2e, 0x8b, 0x57}, {"seagreen1", 0x54, 0xff, 0x9f}, {"seagreen2", 0x4e, 0xee, 0x94}, {"seagreen3", 0x43, 0xcd, 0x80}, {"seagreen4", 0x2e, 0x8b, 0x57}, {"seashell", 0xff, 0xf5, 0xee}, {"seashell1", 0xff, 0xf5, 0xee}, {"seashell2", 0xee, 0xe5, 0xde}, {"seashell3", 0xcd, 0xc5, 0xbf}, {"seashell4", 0x8b, 0x86, 0x82}, {"sienna", 0xa0, 0x52, 0x2d}, {"sienna1", 0xff, 0x82, 0x47}, {"sienna2", 0xee, 0x79, 0x42}, {"sienna3", 0xcd, 0x68, 0x39}, {"sienna4", 0x8b, 0x47, 0x26}, {"skyblue", 0x87, 0xce, 0xeb}, {"skyblue1", 0x87, 0xce, 0xff}, {"skyblue2", 0x7e, 0xc0, 0xee}, {"skyblue3", 0x6c, 0xa6, 0xcd}, {"skyblue4", 0x4a, 0x70, 0x8b}, {"slateblue", 0x6a, 0x5a, 0xcd}, {"slateblue1", 0x83, 0x6f, 0xff}, {"slateblue2", 0x7a, 0x67, 0xee}, {"slateblue3", 0x69, 0x59, 0xcd}, {"slateblue4", 0x47, 0x3c, 0x8b}, {"slategray", 0x70, 0x80, 0x90}, {"slategray1", 0xc6, 0xe2, 0xff}, {"slategray2", 0xb9, 0xd3, 0xee}, {"slategray3", 0x9f, 0xb6, 0xcd}, {"slategray4", 0x6c, 0x7b, 0x8b}, {"slategrey", 0x70, 0x80, 0x90}, {"slategrey1", 0xc6, 0xe2, 0xff}, {"slategrey2", 0xb9, 0xd3, 0xee}, {"slategrey3", 0x9f, 0xb6, 0xcd}, {"slategrey4", 0x6c, 0x7b, 0x8b}, {"snow", 0xff, 0xfa, 0xfa}, {"snow1", 0xff, 0xfa, 0xfa}, {"snow2", 0xee, 0xe9, 0xe9}, {"snow3", 0xcd, 0xc9, 0xc9}, {"snow4", 0x8b, 0x89, 0x89}, {"springgreen", 0x00, 0xff, 0x7f}, {"springgreen1", 0x00, 0xff, 0x7f}, {"springgreen2", 0x00, 0xee, 0x76}, {"springgreen3", 0x00, 0xcd, 0x66}, {"springgreen4", 0x00, 0x8b, 0x45}, {"steelblue", 0x46, 0x82, 0xb4}, {"steelblue1", 0x63, 0xb8, 0xff}, {"steelblue2", 0x5c, 0xac, 0xee}, {"steelblue3", 0x4f, 0x94, 0xcd}, {"steelblue4", 0x36, 0x64, 0x8b}, {"tan", 0xd2, 0xb4, 0x8c}, {"tan1", 0xff, 0xa5, 0x4f}, {"tan2", 0xee, 0x9a, 0x49}, {"tan3", 0xcd, 0x85, 0x3f}, {"tan4", 0x8b, 0x5a, 0x2b}, {"thistle", 0xd8, 0xbf, 0xd8}, {"thistle1", 0xff, 0xe1, 0xff}, {"thistle2", 0xee, 0xd2, 0xee}, {"thistle3", 0xcd, 0xb5, 0xcd}, {"thistle4", 0x8b, 0x7b, 0x8b}, {"tomato", 0xff, 0x63, 0x47}, {"tomato1", 0xff, 0x63, 0x47}, {"tomato2", 0xee, 0x5c, 0x42}, {"tomato3", 0xcd, 0x4f, 0x39}, {"tomato4", 0x8b, 0x36, 0x26}, {"turquoise", 0x40, 0xe0, 0xd0}, {"turquoise1", 0x00, 0xf5, 0xff}, {"turquoise2", 0x00, 0xe5, 0xee}, {"turquoise3", 0x00, 0xc5, 0xcd}, {"turquoise4", 0x00, 0x86, 0x8b}, {"violet", 0xee, 0x82, 0xee}, {"violetred", 0xd0, 0x20, 0x90}, {"violetred1", 0xff, 0x3e, 0x96}, {"violetred2", 0xee, 0x3a, 0x8c}, {"violetred3", 0xcd, 0x32, 0x78}, {"violetred4", 0x8b, 0x22, 0x52}, {"wheat", 0xf5, 0xde, 0xb3}, {"wheat1", 0xff, 0xe7, 0xba}, {"wheat2", 0xee, 0xd8, 0xae}, {"wheat3", 0xcd, 0xba, 0x96}, {"wheat4", 0x8b, 0x7e, 0x66}, {"white", 0xff, 0xff, 0xff}, {"whitesmoke", 0xf5, 0xf5, 0xf5}, {"yellow", 0xff, 0xff, 0x00}, {"yellow1", 0xff, 0xff, 0x00}, {"yellow2", 0xee, 0xee, 0x00}, {"yellow3", 0xcd, 0xcd, 0x00}, {"yellow4", 0x8b, 0x8b, 0x00}, {"yellowgreen", 0x9a, 0xcd, 0x32}, {NO_TEXT, 0, 0, 0} }; /*! \brief searches colour in the list \param p position in tree \param name colour name \param iindex set to iindex in table \return whether colour name is found **/ static BOOL_T string_to_colour (NODE_T * p, char *name, int *iindex) { A68_REF z_ref = heap_generator (p, MODE (C_STRING), (int) (1 + strlen (name))); char *z = DEREF (char, &z_ref); int i, j; BOOL_T k; /* First remove formatting from name: spaces and capitals are irrelevant */ j = 0; for (i = 0; name[i] != NULL_CHAR; i++) { if (name[i] != BLANK_CHAR) { z[j++] = (char) TO_LOWER (name[i]); } z[j] = 0; } /* Now search with the famous British Library Method */ k = A68_FALSE; for (i = 0; i < COLOUR_NAMES && !k; i++) { if (!strcmp (NAME (&A68_COLOURS[i]), z)) { k = A68_TRUE; *iindex = i; } } return (k); } /*! \brief scans string for an integer \param z text buffer \param k set to int value \return whether conversion is successful **/ static BOOL_T scan_int (char **z, int *k) { char *y = *z; while (y[0] != NULL_CHAR && !IS_DIGIT (y[0])) { y++; } if (y[0] != NULL_CHAR) { (*k) = strtol (y, z, 10); return ((BOOL_T) (errno == 0)); } else { return (A68_FALSE); } } /*! \brief PROC (REF FILE, STRING, STRING) make device \param p position in tree **/ void genie_make_device (NODE_T * p) { int size; A68_REF ref_device, ref_page, ref_file; A68_FILE *file; /* Pop arguments */ POP_REF (p, &ref_page); POP_REF (p, &ref_device); POP_REF (p, &ref_file); CHECK_REF (p, ref_file, MODE (REF_FILE)); file = FILE_DEREF (&ref_file); if (DEVICE_MADE (&DEVICE (file))) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_DEVICE_ALREADY_SET); exit_genie (p, A68_RUNTIME_ERROR); } /* Fill in page_size */ size = a68_string_size (p, ref_page); if (INITIALISED (&(A68_PAGE_SIZE (&DEVICE (file)))) && !IS_NIL (A68_PAGE_SIZE (&DEVICE (file)))) { UNBLOCK_GC_HANDLE (&A68_PAGE_SIZE (&DEVICE (file))); } A68_PAGE_SIZE (&DEVICE (file)) = heap_generator (p, MODE (STRING), 1 + size); BLOCK_GC_HANDLE (&A68_PAGE_SIZE (&DEVICE (file))); ASSERT (a_to_c_string (p, DEREF (char, &A68_PAGE_SIZE (&DEVICE (file))), ref_page) != NO_TEXT); /* Fill in device */ size = a68_string_size (p, ref_device); if (INITIALISED (&(DEVICE (&DEVICE (file)))) && !IS_NIL (DEVICE (&DEVICE (file)))) { UNBLOCK_GC_HANDLE (&DEVICE (&DEVICE (file))); } DEVICE (&DEVICE (file)) = heap_generator (p, MODE (STRING), 1 + size); BLOCK_GC_HANDLE (&DEVICE (&DEVICE (file))); ASSERT (a_to_c_string (p, DEREF (char, &DEVICE (&DEVICE (file))), ref_device) != NO_TEXT); DEVICE_MADE (&DEVICE (file)) = A68_TRUE; PUSH_PRIMITIVE (p, A68_TRUE, A68_BOOL); } /*! \brief closes the plotter \param p position in tree \param f pointer to file \return TRUE or exits **/ BOOL_T close_device (NODE_T * p, A68_FILE * f) { CHECK_INIT (p, INITIALISED (f), MODE (FILE)); if (!OPENED (f)) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FILE_NOT_OPEN); exit_genie (p, A68_RUNTIME_ERROR); } if (!(DEVICE_OPENED (&DEVICE (f)))) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_DEVICE_NOT_OPEN); exit_genie (p, A68_RUNTIME_ERROR); } if (DEVICE_MADE (&DEVICE (f))) { if (!IS_NIL (DEVICE (&DEVICE (f)))) { UNBLOCK_GC_HANDLE (&(DEVICE (&DEVICE (f)))); } if (!IS_NIL (A68_PAGE_SIZE (&DEVICE (f)))) { UNBLOCK_GC_HANDLE (&(A68_PAGE_SIZE (&DEVICE (f)))); } } if (pl_closepl_r (PLOTTER (&DEVICE (f))) < 0) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_CLOSING_DEVICE); exit_genie (p, A68_RUNTIME_ERROR); } if (pl_deletepl_r (PLOTTER (&DEVICE (f))) < 0) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_CLOSING_DEVICE); exit_genie (p, A68_RUNTIME_ERROR); } if (STREAM (&DEVICE (f)) != NO_STREAM && fclose (STREAM (&DEVICE (f))) != 0) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_CLOSING_FILE); exit_genie (p, A68_RUNTIME_ERROR); } DEVICE_OPENED (&DEVICE (f)) = A68_FALSE; return (A68_TRUE); } /*! \brief sets up the plotter prior to using it \param p position in tree \param f pointer to file \return plotter of file **/ static plPlotter *set_up_device (NODE_T * p, A68_FILE * f) { A68_REF ref_filename; char *filename, *device_type; /* First set up the general device, then plotter-specific things */ CHECK_INIT (p, INITIALISED (f), MODE (FILE)); ref_filename = IDENTIFICATION (f); /* This one in front as to quickly select the plotter */ if (DEVICE_OPENED (&DEVICE (f))) { if (DEVICE_HANDLE (&DEVICE (f)) < 0) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_DEVICE_CANNOT_OPEN); exit_genie (p, A68_RUNTIME_ERROR); } return (PLOTTER (&DEVICE (f))); } /* Device not set up yet */ if (!OPENED (f)) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FILE_NOT_OPEN); exit_genie (p, A68_RUNTIME_ERROR); } if (READ_MOOD (f)) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "read"); exit_genie (p, A68_RUNTIME_ERROR); } if (WRITE_MOOD (f)) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "write"); exit_genie (p, A68_RUNTIME_ERROR); } if (!DRAW (&CHANNEL (f))) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_CHANNEL_DOES_NOT_ALLOW, "drawing"); exit_genie (p, A68_RUNTIME_ERROR); } if (!DEVICE_MADE (&DEVICE (f))) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_DEVICE_NOT_SET); exit_genie (p, A68_RUNTIME_ERROR); } device_type = DEREF (char, &DEVICE (&DEVICE (f))); if (!strcmp (device_type, "X")) { #if defined X_DISPLAY_MISSING diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_INVALID_PARAMETER, "X plotter missing", ""); exit_genie (p, A68_RUNTIME_ERROR); #else /*-----------------------------------------+ | Supported plotter type - X Window System | +-----------------------------------------*/ char *z = DEREF (char, &A68_PAGE_SIZE (&DEVICE (f))), size[BUFFER_SIZE]; /* Establish page size */ if (!scan_int (&z, &(WINDOW_X_SIZE (&DEVICE (f))))) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_PAGE_SIZE); exit_genie (p, A68_RUNTIME_ERROR); } if (!scan_int (&z, &(WINDOW_Y_SIZE (&DEVICE (f))))) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_PAGE_SIZE); exit_genie (p, A68_RUNTIME_ERROR); } if (z[0] != NULL_CHAR) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_PAGE_SIZE); exit_genie (p, A68_RUNTIME_ERROR); } /* Make the X window */ FD (f) = -1; PLOTTER_PARAMS (&DEVICE (f)) = pl_newplparams (); if (PLOTTER_PARAMS (&DEVICE (f)) == NULL) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_DEVICE_CANNOT_ALLOCATE); exit_genie (p, A68_RUNTIME_ERROR); } ASSERT (snprintf (size, SNPRINTF_SIZE, "%dx%d", WINDOW_X_SIZE (&DEVICE (f)), WINDOW_Y_SIZE (&DEVICE (f))) >= 0); (void) pl_setplparam (PLOTTER_PARAMS (&DEVICE (f)), "BITMAPSIZE", size); (void) pl_setplparam (PLOTTER_PARAMS (&DEVICE (f)), "BG_COLOR", (void *) "black"); (void) pl_setplparam (PLOTTER_PARAMS (&DEVICE (f)), "VANISH_ON_DELETE", (void *) "no"); (void) pl_setplparam (PLOTTER_PARAMS (&DEVICE (f)), "X_AUTO_FLUSH", (void *) "yes"); (void) pl_setplparam (PLOTTER_PARAMS (&DEVICE (f)), "USE_DOUBLE_BUFFERING", (void *) "no"); PLOTTER (&DEVICE (f)) = pl_newpl_r ("X", NULL, NULL, stderr, PLOTTER_PARAMS (&DEVICE (f))); if (PLOTTER (&DEVICE (f)) == NULL) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_DEVICE_CANNOT_OPEN); exit_genie (p, A68_RUNTIME_ERROR); } if (pl_openpl_r (PLOTTER (&DEVICE (f))) < 0) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_DEVICE_CANNOT_OPEN); exit_genie (p, A68_RUNTIME_ERROR); } (void) pl_space_r (PLOTTER (&DEVICE (f)), 0, 0, WINDOW_X_SIZE (&DEVICE (f)), WINDOW_Y_SIZE (&DEVICE (f))); (void) pl_bgcolorname_r (PLOTTER (&DEVICE (f)), "black"); (void) pl_colorname_r (PLOTTER (&DEVICE (f)), "white"); (void) pl_pencolorname_r (PLOTTER (&DEVICE (f)), "white"); (void) pl_fillcolorname_r (PLOTTER (&DEVICE (f)), "white"); (void) pl_filltype_r (PLOTTER (&DEVICE (f)), 0); DRAW_MOOD (f) = A68_TRUE; DEVICE_OPENED (&DEVICE (f)) = A68_TRUE; X_COORD (&DEVICE (f)) = 0; Y_COORD (&DEVICE (f)) = 0; return (PLOTTER (&DEVICE (f))); #endif } else if (!strcmp (device_type, "pnm")) { /*-----------------------------------------+ | Supported plotter type - Portable aNyMap | +-----------------------------------------*/ char *z = DEREF (char, &A68_PAGE_SIZE (&DEVICE (f))), size[BUFFER_SIZE]; /* Establish page size */ if (!scan_int (&z, &(WINDOW_X_SIZE (&DEVICE (f))))) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_PAGE_SIZE); exit_genie (p, A68_RUNTIME_ERROR); } if (!scan_int (&z, &(WINDOW_Y_SIZE (&DEVICE (f))))) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_PAGE_SIZE); exit_genie (p, A68_RUNTIME_ERROR); } if (z[0] != NULL_CHAR) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_PAGE_SIZE); exit_genie (p, A68_RUNTIME_ERROR); } /* Open the output file for drawing */ CHECK_REF (p, ref_filename, MODE (ROWS)); filename = DEREF (char, &ref_filename); RESET_ERRNO; if ((STREAM (&DEVICE (f)) = fopen (filename, "wb")) == NO_STREAM) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_CANNOT_OPEN_NAME, filename); exit_genie (p, A68_RUNTIME_ERROR); } else { READ_MOOD (f) = A68_FALSE; WRITE_MOOD (f) = A68_FALSE; CHAR_MOOD (f) = A68_FALSE; DRAW_MOOD (f) = A68_TRUE; } /* Set up plotter */ ASSERT (snprintf (size, SNPRINTF_SIZE, "%dx%d", WINDOW_X_SIZE (&DEVICE (f)), WINDOW_Y_SIZE (&DEVICE (f))) >= 0); PLOTTER_PARAMS (&DEVICE (f)) = pl_newplparams (); if (PLOTTER_PARAMS (&DEVICE (f)) == NULL) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_DEVICE_CANNOT_ALLOCATE); exit_genie (p, A68_RUNTIME_ERROR); } (void) pl_setplparam (PLOTTER_PARAMS (&DEVICE (f)), "BITMAPSIZE", size); (void) pl_setplparam (PLOTTER_PARAMS (&DEVICE (f)), "BG_COLOR", (void *) "black"); (void) pl_setplparam (PLOTTER_PARAMS (&DEVICE (f)), "PNM_PORTABLE", (void *) "no"); PLOTTER (&DEVICE (f)) = pl_newpl_r ("pnm", NULL, STREAM (&DEVICE (f)), stderr, PLOTTER_PARAMS (&DEVICE (f))); if (PLOTTER (&DEVICE (f)) == NULL) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_DEVICE_CANNOT_OPEN); exit_genie (p, A68_RUNTIME_ERROR); } if (pl_openpl_r (PLOTTER (&DEVICE (f))) < 0) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_DEVICE_CANNOT_OPEN); exit_genie (p, A68_RUNTIME_ERROR); } (void) pl_space_r (PLOTTER (&DEVICE (f)), 0, 0, WINDOW_X_SIZE (&DEVICE (f)), WINDOW_Y_SIZE (&DEVICE (f))); (void) pl_bgcolorname_r (PLOTTER (&DEVICE (f)), "black"); (void) pl_colorname_r (PLOTTER (&DEVICE (f)), "white"); (void) pl_pencolorname_r (PLOTTER (&DEVICE (f)), "white"); (void) pl_fillcolorname_r (PLOTTER (&DEVICE (f)), "white"); (void) pl_filltype_r (PLOTTER (&DEVICE (f)), 0); DRAW_MOOD (f) = A68_TRUE; DEVICE_OPENED (&DEVICE (f)) = A68_TRUE; X_COORD (&DEVICE (f)) = 0; Y_COORD (&DEVICE (f)) = 0; return (PLOTTER (&DEVICE (f))); } else if (!strcmp (device_type, "gif")) { /*------------------------------------+ | Supported plotter type - pseudo GIF | +------------------------------------*/ char *z = DEREF (char, &A68_PAGE_SIZE (&DEVICE (f))), size[BUFFER_SIZE]; /* Establish page size */ if (!scan_int (&z, &(WINDOW_X_SIZE (&DEVICE (f))))) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_PAGE_SIZE); exit_genie (p, A68_RUNTIME_ERROR); } if (!scan_int (&z, &(WINDOW_Y_SIZE (&DEVICE (f))))) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_PAGE_SIZE); exit_genie (p, A68_RUNTIME_ERROR); } if (z[0] != NULL_CHAR) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_PAGE_SIZE); exit_genie (p, A68_RUNTIME_ERROR); } /* Open the output file for drawing */ CHECK_REF (p, ref_filename, MODE (ROWS)); filename = DEREF (char, &ref_filename); RESET_ERRNO; if ((STREAM (&DEVICE (f)) = fopen (filename, "wb")) == NO_STREAM) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_CANNOT_OPEN_NAME, filename); exit_genie (p, A68_RUNTIME_ERROR); } else { READ_MOOD (f) = A68_FALSE; WRITE_MOOD (f) = A68_FALSE; CHAR_MOOD (f) = A68_FALSE; DRAW_MOOD (f) = A68_TRUE; } /* Set up plotter */ PLOTTER_PARAMS (&DEVICE (f)) = pl_newplparams (); if (PLOTTER_PARAMS (&DEVICE (f)) == NULL) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_DEVICE_CANNOT_ALLOCATE); exit_genie (p, A68_RUNTIME_ERROR); } ASSERT (snprintf (size, SNPRINTF_SIZE, "%dx%d", WINDOW_X_SIZE (&DEVICE (f)), WINDOW_Y_SIZE (&DEVICE (f))) >= 0); (void) pl_setplparam (PLOTTER_PARAMS (&DEVICE (f)), "BITMAPSIZE", size); (void) pl_setplparam (PLOTTER_PARAMS (&DEVICE (f)), "BG_COLOR", (void *) "black"); (void) pl_setplparam (PLOTTER_PARAMS (&DEVICE (f)), "GIF_ANIMATION", (void *) "no"); PLOTTER (&DEVICE (f)) = pl_newpl_r ("gif", NULL, STREAM (&DEVICE (f)), stderr, PLOTTER_PARAMS (&DEVICE (f))); if (PLOTTER (&DEVICE (f)) == NULL) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_DEVICE_CANNOT_OPEN); exit_genie (p, A68_RUNTIME_ERROR); } if (pl_openpl_r (PLOTTER (&DEVICE (f))) < 0) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_DEVICE_CANNOT_OPEN); exit_genie (p, A68_RUNTIME_ERROR); } (void) pl_space_r (PLOTTER (&DEVICE (f)), 0, 0, WINDOW_X_SIZE (&DEVICE (f)), WINDOW_Y_SIZE (&DEVICE (f))); (void) pl_bgcolorname_r (PLOTTER (&DEVICE (f)), "black"); (void) pl_colorname_r (PLOTTER (&DEVICE (f)), "white"); (void) pl_pencolorname_r (PLOTTER (&DEVICE (f)), "white"); (void) pl_fillcolorname_r (PLOTTER (&DEVICE (f)), "white"); (void) pl_filltype_r (PLOTTER (&DEVICE (f)), 0); DRAW_MOOD (f) = A68_TRUE; DEVICE_OPENED (&DEVICE (f)) = A68_TRUE; X_COORD (&DEVICE (f)) = 0; Y_COORD (&DEVICE (f)) = 0; return (PLOTTER (&DEVICE (f))); } else if (!strcmp (device_type, "ps")) { #if defined POSTSCRIPT_MISSING diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_INVALID_PARAMETER, "postscript plotter missing", ""); exit_genie (p, A68_RUNTIME_ERROR); #else /*------------------------------------+ | Supported plotter type - Postscript | +------------------------------------*/ /* Open the output file for drawing */ CHECK_REF (p, ref_filename, MODE (ROWS)); filename = DEREF (char, &ref_filename); RESET_ERRNO; if ((STREAM (&DEVICE (f)) = fopen (filename, "w")) == NO_STREAM) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_CANNOT_OPEN_NAME, filename); exit_genie (p, A68_RUNTIME_ERROR); } else { READ_MOOD (f) = A68_FALSE; WRITE_MOOD (f) = A68_FALSE; CHAR_MOOD (f) = A68_FALSE; DRAW_MOOD (f) = A68_TRUE; } /* Set up ps plotter */ PLOTTER_PARAMS (&DEVICE (f)) = pl_newplparams (); if (PLOTTER_PARAMS (&DEVICE (f)) == NULL) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_DEVICE_CANNOT_ALLOCATE); exit_genie (p, A68_RUNTIME_ERROR); } (void) pl_setplparam (PLOTTER_PARAMS (&DEVICE (f)), "PAGESIZE", DEREF (char, &A68_PAGE_SIZE (&DEVICE (f)))); PLOTTER (&DEVICE (f)) = pl_newpl_r ("ps", NULL, STREAM (&DEVICE (f)), stderr, PLOTTER_PARAMS (&DEVICE (f))); if (PLOTTER (&DEVICE (f)) == NULL) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_DEVICE_CANNOT_OPEN); exit_genie (p, A68_RUNTIME_ERROR); } if (pl_openpl_r (PLOTTER (&DEVICE (f))) < 0) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_DEVICE_CANNOT_OPEN); exit_genie (p, A68_RUNTIME_ERROR); } WINDOW_X_SIZE (&DEVICE (f)) = 1000; WINDOW_Y_SIZE (&DEVICE (f)) = 1000; (void) pl_space_r (PLOTTER (&DEVICE (f)), 0, 0, WINDOW_X_SIZE (&DEVICE (f)), WINDOW_Y_SIZE (&DEVICE (f))); (void) pl_bgcolorname_r (PLOTTER (&DEVICE (f)), "black"); (void) pl_colorname_r (PLOTTER (&DEVICE (f)), "white"); (void) pl_pencolorname_r (PLOTTER (&DEVICE (f)), "white"); (void) pl_fillcolorname_r (PLOTTER (&DEVICE (f)), "white"); (void) pl_filltype_r (PLOTTER (&DEVICE (f)), 0); DRAW_MOOD (f) = A68_TRUE; DEVICE_OPENED (&DEVICE (f)) = A68_TRUE; X_COORD (&DEVICE (f)) = 0; Y_COORD (&DEVICE (f)) = 0; return (PLOTTER (&DEVICE (f))); #endif } else { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_INVALID_PARAMETER, "unindentified plotter", device_type); exit_genie (p, A68_RUNTIME_ERROR); } return (NULL); } /*! \brief PROC (REF FILE) VOID draw erase \param p position in tree **/ void genie_draw_clear (NODE_T * p) { A68_REF ref_file; A68_FILE *f; plPlotter *plotter; POP_REF (p, &ref_file); CHECK_REF (p, ref_file, MODE (REF_FILE)); f = FILE_DEREF (&ref_file); plotter = set_up_device (p, f); (void) pl_flushpl_r (plotter); (void) pl_erase_r (plotter); } /*! \brief PROC (REF FILE) VOID draw show \param p position in tree **/ void genie_draw_show (NODE_T * p) { A68_REF ref_file; A68_FILE *f; plPlotter *plotter; POP_REF (p, &ref_file); CHECK_REF (p, ref_file, MODE (REF_FILE)); f = FILE_DEREF (&ref_file); plotter = set_up_device (p, f); (void) pl_flushpl_r (plotter); } /*! \brief PROC (REF FILE) REAL draw aspect \param p position in tree **/ void genie_draw_aspect (NODE_T * p) { A68_REF ref_file; A68_FILE *f; plPlotter *plotter; POP_REF (p, &ref_file); CHECK_REF (p, ref_file, MODE (REF_FILE)); f = FILE_DEREF (&ref_file); plotter = set_up_device (p, f); PUSH_PRIMITIVE (p, (double) WINDOW_Y_SIZE (&DEVICE (f)) / (double) WINDOW_X_SIZE (&DEVICE (f)), A68_REAL); } /*! \brief PROC (REF FILE, INT) VOID draw fillstyle \param p position in tree **/ void genie_draw_fillstyle (NODE_T * p) { A68_INT z; A68_REF ref_file; A68_FILE *f; plPlotter *plotter; POP_OBJECT (p, &z, A68_INT); POP_REF (p, &ref_file); CHECK_REF (p, ref_file, MODE (REF_FILE)); f = FILE_DEREF (&ref_file); plotter = set_up_device (p, f); (void) pl_filltype_r (plotter, (int) VALUE (&z)); } /*! \brief PROC (INT) STRING draw get colour name \param p position in tree **/ void genie_draw_get_colour_name (NODE_T * p) { A68_INT z; int j; char *str; POP_OBJECT (p, &z, A68_INT); j = (VALUE (&z) - 1) % COLOUR_NAMES; str = NAME (&A68_COLOURS[j]); PUSH_REF (p, c_to_a_string (p, str, DEFAULT_WIDTH)); } /*! \brief PROC (REF FILE, REAL, REAL, REAL) VOID draw colour \param p position in tree **/ void genie_draw_colour (NODE_T * p) { A68_REAL x, y, z; A68_REF ref_file; A68_FILE *f; plPlotter *plotter; POP_OBJECT (p, &z, A68_REAL); POP_OBJECT (p, &y, A68_REAL); POP_OBJECT (p, &x, A68_REAL); POP_REF (p, &ref_file); CHECK_REF (p, ref_file, MODE (REF_FILE)); f = FILE_DEREF (&ref_file); plotter = set_up_device (p, f); RED (&DEVICE (f)) = VALUE (&x); GREEN (&DEVICE (f)) = VALUE (&y); BLUE (&DEVICE (f)) = VALUE (&z); (void) pl_color_r (plotter, (int) (VALUE (&x) * COLOUR_MAX), (int) (VALUE (&y) * COLOUR_MAX), (int) (VALUE (&z) * COLOUR_MAX)); (void) pl_pencolor_r (plotter, (int) (VALUE (&x) * COLOUR_MAX), (int) (VALUE (&y) * COLOUR_MAX), (int) (VALUE (&z) * COLOUR_MAX)); (void) pl_fillcolor_r (plotter, (int) (VALUE (&x) * COLOUR_MAX), (int) (VALUE (&y) * COLOUR_MAX), (int) (VALUE (&z) * COLOUR_MAX)); } /*! \brief PROC (REF FILE, REAL, REAL, REAL) VOID draw background colour \param p position in tree **/ void genie_draw_background_colour (NODE_T * p) { A68_REAL x, y, z; A68_REF ref_file; A68_FILE *f; plPlotter *plotter; POP_OBJECT (p, &z, A68_REAL); POP_OBJECT (p, &y, A68_REAL); POP_OBJECT (p, &x, A68_REAL); POP_REF (p, &ref_file); CHECK_REF (p, ref_file, MODE (REF_FILE)); f = FILE_DEREF (&ref_file); plotter = set_up_device (p, f); (void) pl_bgcolor_r (plotter, (int) (VALUE (&x) * COLOUR_MAX), (int) (VALUE (&y) * COLOUR_MAX), (int) (VALUE (&z) * COLOUR_MAX)); } /*! \brief PROC (REF FILE, STRING) VOID draw colour name \param p position in tree **/ void genie_draw_colour_name (NODE_T * p) { A68_REF ref_c, ref_file; A68_FILE *f; A68_REF name_ref; char *name; int iindex; double x, y, z; plPlotter *plotter; POP_REF (p, &ref_c); POP_REF (p, &ref_file); CHECK_REF (p, ref_file, MODE (REF_FILE)); f = FILE_DEREF (&ref_file); name_ref = heap_generator (p, MODE (C_STRING), 1 + a68_string_size (p, ref_c)); name = DEREF (char, &name_ref); ASSERT (a_to_c_string (p, name, ref_c) != NO_TEXT); if (!string_to_colour (p, name, &iindex)) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_INVALID_PARAMETER, "unidentified colour name", name); exit_genie (p, A68_RUNTIME_ERROR); } x = (double) (RED (&A68_COLOURS[iindex])) / (double) (0xff); y = (double) (GREEN (&A68_COLOURS[iindex])) / (double) (0xff); z = (double) (BLUE (&A68_COLOURS[iindex])) / (double) (0xff); plotter = set_up_device (p, f); RED (&DEVICE (f)) = x; GREEN (&DEVICE (f)) = y; BLUE (&DEVICE (f)) = z; (void) pl_color_r (plotter, (int) (x * COLOUR_MAX), (int) (y * COLOUR_MAX), (int) (z * COLOUR_MAX)); (void) pl_pencolor_r (plotter, (int) (x * COLOUR_MAX), (int) (y * COLOUR_MAX), (int) (z * COLOUR_MAX)); (void) pl_fillcolor_r (plotter, (int) (x * COLOUR_MAX), (int) (y * COLOUR_MAX), (int) (z * COLOUR_MAX)); } /*! \brief PROC (REF FILE, STRING) VOID draw background colour name \param p position in tree **/ void genie_draw_background_colour_name (NODE_T * p) { A68_REF ref_c, ref_file; A68_FILE *f; A68_REF name_ref; char *name; int iindex; double x, y, z; plPlotter *plotter; POP_REF (p, &ref_c); POP_REF (p, &ref_file); CHECK_REF (p, ref_file, MODE (REF_FILE)); f = FILE_DEREF (&ref_file); name_ref = heap_generator (p, MODE (C_STRING), 1 + a68_string_size (p, ref_c)); name = DEREF (char, &name_ref); ASSERT (a_to_c_string (p, name, ref_c) != NO_TEXT); if (!string_to_colour (p, name, &iindex)) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_INVALID_PARAMETER, "unidentified colour name", name); exit_genie (p, A68_RUNTIME_ERROR); } x = (double) (RED (&A68_COLOURS[iindex])) / (double) (0xff); y = (double) (GREEN (&A68_COLOURS[iindex])) / (double) (0xff); z = (double) (BLUE (&A68_COLOURS[iindex])) / (double) (0xff); plotter = set_up_device (p, f); RED (&DEVICE (f)) = x; GREEN (&DEVICE (f)) = y; BLUE (&DEVICE (f)) = z; (void) pl_bgcolor_r (plotter, (int) (x * COLOUR_MAX), (int) (y * COLOUR_MAX), (int) (z * COLOUR_MAX)); } /*! \brief PROC (REF FILE, STRING) VOID draw linestyle \param p position in tree **/ void genie_draw_linestyle (NODE_T * p) { A68_REF txt, ref_file; A68_FILE *f; int size; A68_REF z_ref; char *z; plPlotter *plotter; POP_REF (p, &txt); POP_REF (p, &ref_file); CHECK_REF (p, ref_file, MODE (REF_FILE)); f = FILE_DEREF (&ref_file); plotter = set_up_device (p, f); size = a68_string_size (p, txt); z_ref = heap_generator (p, MODE (C_STRING), 1 + size); z = DEREF (char, &z_ref); ASSERT (a_to_c_string (p, z, txt) != NO_TEXT); (void) pl_linemod_r (plotter, z); } /*! \brief PROC (REF FILE, INT) VOID draw linewidth \param p position in tree **/ void genie_draw_linewidth (NODE_T * p) { A68_REAL width; A68_REF ref_file; A68_FILE *f; plPlotter *plotter; POP_OBJECT (p, &width, A68_REAL); POP_REF (p, &ref_file); CHECK_REF (p, ref_file, MODE (REF_FILE)); f = FILE_DEREF (&ref_file); plotter = set_up_device (p, f); (void) pl_linewidth_r (plotter, (int) (VALUE (&width) * (double) WINDOW_Y_SIZE (&DEVICE (f)))); } /*! \brief PROC (REF FILE, REAL, REAL) VOID draw move \param p position in tree **/ void genie_draw_move (NODE_T * p) { A68_REAL x, y; A68_REF ref_file; A68_FILE *f; plPlotter *plotter; POP_OBJECT (p, &y, A68_REAL); POP_OBJECT (p, &x, A68_REAL); POP_REF (p, &ref_file); CHECK_REF (p, ref_file, MODE (REF_FILE)); f = FILE_DEREF (&ref_file); plotter = set_up_device (p, f); (void) pl_fmove_r (plotter, VALUE (&x) * WINDOW_X_SIZE (&DEVICE (f)), VALUE (&y) * WINDOW_Y_SIZE (&DEVICE (f))); X_COORD (&DEVICE (f)) = VALUE (&x); Y_COORD (&DEVICE (f)) = VALUE (&y); } /*! \brief PROC (REF FILE, REAL, REAL) VOID draw line \param p position in tree **/ void genie_draw_line (NODE_T * p) { A68_REAL x, y; A68_REF ref_file; A68_FILE *f; plPlotter *plotter; POP_OBJECT (p, &y, A68_REAL); POP_OBJECT (p, &x, A68_REAL); POP_REF (p, &ref_file); CHECK_REF (p, ref_file, MODE (REF_FILE)); f = FILE_DEREF (&ref_file); plotter = set_up_device (p, f); (void) pl_fline_r (plotter, X_COORD (&DEVICE (f)) * WINDOW_X_SIZE (&DEVICE (f)), Y_COORD (&DEVICE (f)) * WINDOW_Y_SIZE (&DEVICE (f)), VALUE (&x) * WINDOW_X_SIZE (&DEVICE (f)), VALUE (&y) * WINDOW_Y_SIZE (&DEVICE (f))); X_COORD (&DEVICE (f)) = VALUE (&x); Y_COORD (&DEVICE (f)) = VALUE (&y); } /*! \brief PROC (REF FILE, REAL, REAL) VOID draw point \param p position in tree **/ void genie_draw_point (NODE_T * p) { A68_REAL x, y; A68_REF ref_file; A68_FILE *f; plPlotter *plotter; POP_OBJECT (p, &y, A68_REAL); POP_OBJECT (p, &x, A68_REAL); POP_REF (p, &ref_file); CHECK_REF (p, ref_file, MODE (REF_FILE)); f = FILE_DEREF (&ref_file); plotter = set_up_device (p, f); (void) pl_fpoint_r (plotter, VALUE (&x) * WINDOW_X_SIZE (&DEVICE (f)), VALUE (&y) * WINDOW_Y_SIZE (&DEVICE (f))); X_COORD (&DEVICE (f)) = VALUE (&x); Y_COORD (&DEVICE (f)) = VALUE (&y); } /*! \brief PROC (REF FILE, REAL, REAL) VOID draw rect \param p position in tree **/ void genie_draw_rect (NODE_T * p) { A68_REAL x, y; A68_REF ref_file; A68_FILE *f; plPlotter *plotter; POP_OBJECT (p, &y, A68_REAL); POP_OBJECT (p, &x, A68_REAL); POP_REF (p, &ref_file); CHECK_REF (p, ref_file, MODE (REF_FILE)); f = FILE_DEREF (&ref_file); plotter = set_up_device (p, f); (void) pl_fbox_r (plotter, X_COORD (&DEVICE (f)) * WINDOW_X_SIZE (&DEVICE (f)), Y_COORD (&DEVICE (f)) * WINDOW_Y_SIZE (&DEVICE (f)), VALUE (&x) * WINDOW_X_SIZE (&DEVICE (f)), VALUE (&y) * WINDOW_Y_SIZE (&DEVICE (f))); X_COORD (&DEVICE (f)) = VALUE (&x); Y_COORD (&DEVICE (f)) = VALUE (&y); } /*! \brief PROC (REF FILE, REAL, REAL, REAL) VOID draw circle \param p position in tree **/ void genie_draw_circle (NODE_T * p) { A68_REAL x, y, r; A68_REF ref_file; A68_FILE *f; plPlotter *plotter; POP_OBJECT (p, &r, A68_REAL); POP_OBJECT (p, &y, A68_REAL); POP_OBJECT (p, &x, A68_REAL); POP_REF (p, &ref_file); CHECK_REF (p, ref_file, MODE (REF_FILE)); f = FILE_DEREF (&ref_file); plotter = set_up_device (p, f); (void) pl_fcircle_r (plotter, VALUE (&x) * WINDOW_X_SIZE (&DEVICE (f)), VALUE (&y) * WINDOW_Y_SIZE (&DEVICE (f)), VALUE (&r) * MAXIMUM (WINDOW_X_SIZE (&DEVICE (f)), WINDOW_Y_SIZE (&DEVICE (f)))); X_COORD (&DEVICE (f)) = VALUE (&x); Y_COORD (&DEVICE (f)) = VALUE (&y); } /*! \brief PROC (REF FILE, REAL, REAL, REAL) VOID draw atom \param p position in tree **/ void genie_draw_atom (NODE_T * p) { A68_REAL x, y, r; double frac; int j, k; A68_REF ref_file; A68_FILE *f; plPlotter *plotter; POP_OBJECT (p, &r, A68_REAL); POP_OBJECT (p, &y, A68_REAL); POP_OBJECT (p, &x, A68_REAL); POP_REF (p, &ref_file); CHECK_REF (p, ref_file, MODE (REF_FILE)); f = FILE_DEREF (&ref_file); plotter = set_up_device (p, f); k = (int) (VALUE (&r) * MAXIMUM (WINDOW_X_SIZE (&DEVICE (f)), WINDOW_Y_SIZE (&DEVICE (f)))); (void) pl_filltype_r (plotter, 1); for (j = k - 1; j >= 0; j--) { frac = (double) j / (double) (k - 1); frac = 0.6 + 0.3 * sqrt (1.0 - frac * frac); (void) pl_color_r (plotter, (int) (frac * RED (&DEVICE (f)) * COLOUR_MAX), (int) (frac * GREEN (&DEVICE (f)) * COLOUR_MAX), (int) (frac * BLUE (&DEVICE (f)) * COLOUR_MAX)); (void) pl_fcircle_r (plotter, VALUE (&x) * WINDOW_X_SIZE (&DEVICE (f)), VALUE (&y) * WINDOW_Y_SIZE (&DEVICE (f)), (double) j); } (void) pl_filltype_r (plotter, 0); X_COORD (&DEVICE (f)) = VALUE (&x); Y_COORD (&DEVICE (f)) = VALUE (&y); } /*! \brief PROC (REF FILE, REAL, REAL, REAL) VOID draw atom \param p position in tree **/ void genie_draw_star (NODE_T * p) { A68_REAL x, y, r; double z, frac; int j, k; A68_REF ref_file; A68_FILE *f; plPlotter *plotter; POP_OBJECT (p, &r, A68_REAL); POP_OBJECT (p, &y, A68_REAL); POP_OBJECT (p, &x, A68_REAL); POP_REF (p, &ref_file); CHECK_REF (p, ref_file, MODE (REF_FILE)); f = FILE_DEREF (&ref_file); plotter = set_up_device (p, f); k = (int) (VALUE (&r) * MAXIMUM (WINDOW_X_SIZE (&DEVICE (f)), WINDOW_Y_SIZE (&DEVICE (f)))); for (j = k; j >= 0; j--) { z = (double) j / (double) k; if (z < 0.2) { z = z / 0.2; frac = 0.5 * (1 + (cos (A68_PI / 2 * z))); } else { z = (z - 0.2) / 0.8; frac = (1 - z) * 0.3; } (void) pl_color_r (plotter, (int) (frac * RED (&DEVICE (f)) * COLOUR_MAX), (int) (frac * GREEN (&DEVICE (f)) * COLOUR_MAX), (int) (frac * BLUE (&DEVICE (f)) * COLOUR_MAX)); (void) pl_fcircle_r (plotter, VALUE (&x) * WINDOW_X_SIZE (&DEVICE (f)), VALUE (&y) * WINDOW_Y_SIZE (&DEVICE (f)), (double) j); } (void) pl_color_r (plotter, (int) (RED (&DEVICE (f)) * COLOUR_MAX), (int) (GREEN (&DEVICE (f)) * COLOUR_MAX), (int) (BLUE (&DEVICE (f)) * COLOUR_MAX)); X_COORD (&DEVICE (f)) = VALUE (&x); Y_COORD (&DEVICE (f)) = VALUE (&y); } /*! \brief PROC (REF FILE, CHAR, CHAR, STRING) VOID draw text \param p position in tree **/ void genie_draw_text (NODE_T * p) { A68_CHAR just_v, just_h; A68_REF txt, ref_file; A68_FILE *f; int size; A68_REF z_ref; char *z; plPlotter *plotter; POP_REF (p, &txt); POP_OBJECT (p, &just_v, A68_CHAR); POP_OBJECT (p, &just_h, A68_CHAR); POP_REF (p, &ref_file); CHECK_REF (p, ref_file, MODE (REF_FILE)); f = FILE_DEREF (&ref_file); plotter = set_up_device (p, f); size = a68_string_size (p, txt); z_ref = heap_generator (p, MODE (C_STRING), 1 + size); z = DEREF (char, &z_ref); ASSERT (a_to_c_string (p, z, txt) != NO_TEXT); size = pl_alabel_r (plotter, VALUE (&just_h), VALUE (&just_v), z); } /*! \brief PROC (REF FILE, STRING) VOID draw fontname \param p position in tree **/ void genie_draw_fontname (NODE_T * p) { A68_REF txt, ref_file; A68_FILE *f; int size; A68_REF z_ref; char *z; plPlotter *plotter; POP_REF (p, &txt); POP_REF (p, &ref_file); CHECK_REF (p, ref_file, MODE (REF_FILE)); f = FILE_DEREF (&ref_file); plotter = set_up_device (p, f); size = a68_string_size (p, txt); z_ref = heap_generator (p, MODE (C_STRING), 1 + size); z = DEREF (char, &z_ref); ASSERT (a_to_c_string (p, z, txt) != NO_TEXT); (void) pl_fontname_r (plotter, z); } /*! \brief PROC (REF FILE, INT) VOID draw fontsize \param p position in tree **/ void genie_draw_fontsize (NODE_T * p) { A68_INT size; A68_REF ref_file; A68_FILE *f; plPlotter *plotter; POP_OBJECT (p, &size, A68_INT); POP_REF (p, &ref_file); CHECK_REF (p, ref_file, MODE (REF_FILE)); f = FILE_DEREF (&ref_file); plotter = set_up_device (p, f); (void) pl_fontsize_r (plotter, (int) VALUE (&size)); } /*! \brief PROC (REF FILE, INT) VOID draw textangle \param p position in tree **/ void genie_draw_textangle (NODE_T * p) { A68_INT angle; A68_REF ref_file; A68_FILE *f; plPlotter *plotter; POP_OBJECT (p, &angle, A68_INT); POP_REF (p, &ref_file); CHECK_REF (p, ref_file, MODE (REF_FILE)); f = FILE_DEREF (&ref_file); plotter = set_up_device (p, f); (void) pl_textangle_r (plotter, (int) VALUE (&angle)); } #endif algol68g-2.4.1/source/monitor.c0000644000175000001440000022467611770153013013230 00000000000000/* \file monitor.c \brief low-level monitor for the interpreter */ /* This file is part of Algol68G - an Algol 68 interpreter. Copyright (C) 2001-2012 J. Marcel van der Veer . 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 is a basic monitor for Algol68G. It activates when the interpreter receives SIGINT (CTRL-C, for instance) or when PROC VOID break, debug or evaluate is called, or when a runtime error occurs and --debug is selected. The monitor allows single stepping (unit-wise through serial/enquiry clauses) and has basic means for inspecting call-frame stack and heap. */ #if defined HAVE_CONFIG_H #include "a68g-config.h" #endif #include "a68g.h" #define CANNOT_SHOW " unprintable value or uninitialised value" #define MAX_ROW_ELEMS 24 #define NOT_A_NUM (-1) #define NO_VALUE " uninitialised value" #define STACK_SIZE 32 #define TOP_MODE (_m_stack[_m_sp - 1]) #define LOGOUT_STRING "exit" ADDR_T finish_frame_pointer = 0; BOOL_T in_monitor = A68_FALSE; char *watchpoint_expression = NO_TEXT; int break_proc_level = 0; static BOOL_T check_initialisation (NODE_T *, BYTE_T *, MOID_T *, BOOL_T *); static char symbol[BUFFER_SIZE], error_text[BUFFER_SIZE], expr[BUFFER_SIZE]; static char prompt[BUFFER_SIZE]; static BOOL_T prompt_set = A68_FALSE; static int current_frame = 0; static int max_row_elems = MAX_ROW_ELEMS; static int mon_errors = 0; static int _m_sp; static int pos, attr; static int tabs = 0; static MOID_T *_m_stack[STACK_SIZE]; static void parse (FILE_T, NODE_T *, int); #define SKIP_ONE_SYMBOL(sym) {\ while (!IS_SPACE ((sym)[0]) && (sym)[0] != NULL_CHAR) {\ (sym)++;\ }\ while (IS_SPACE ((sym)[0]) && (sym)[0] != NULL_CHAR) {\ (sym)++;\ }} #define SKIP_SPACE(sym) {\ while (IS_SPACE ((sym)[0]) && (sym)[0] != NULL_CHAR) {\ (sym)++;\ }} #define CHECK_MON_REF(p, z, m)\ if (! INITIALISED (&z)) {\ ASSERT (snprintf(edit_line, SNPRINTF_SIZE, "%s", moid_to_string ((m), MOID_WIDTH, NO_NODE)) >= 0);\ monitor_error (NO_VALUE, edit_line);\ QUIT_ON_ERROR;\ } else if (IS_NIL (z)) {\ ASSERT (snprintf(edit_line, SNPRINTF_SIZE, "%s", moid_to_string ((m), MOID_WIDTH, NO_NODE)) >= 0);\ monitor_error ("accessing NIL name", edit_line);\ QUIT_ON_ERROR;\ } #define QUIT_ON_ERROR\ if (mon_errors > 0) {\ return;\ } #define PARSE_CHECK(f, p, d)\ parse ((f), (p), (d));\ QUIT_ON_ERROR; #define SCAN_CHECK(f, p)\ scan_sym((f), (p));\ QUIT_ON_ERROR; /*! \brief confirm that we really want to quit \return same */ static BOOL_T confirm_exit (void) { char *cmd; int k; ASSERT (snprintf (output_line, SNPRINTF_SIZE, "Terminate %s (yes|no): ", a68g_cmd_name) >= 0); WRITELN (STDOUT_FILENO, output_line); cmd = read_string_from_tty (NULL); if (TO_UCHAR (cmd[0]) == TO_UCHAR (EOF_CHAR)) { return (confirm_exit ()); } for (k = 0; cmd[k] != NULL_CHAR; k++) { cmd[k] = (char) TO_LOWER (cmd[k]); } if (strcmp (cmd, "y") == 0) { return (A68_TRUE); } if (strcmp (cmd, "yes") == 0) { return (A68_TRUE); } if (strcmp (cmd, "n") == 0) { return (A68_FALSE); } if (strcmp (cmd, "no") == 0) { return (A68_FALSE); } return (confirm_exit ()); } /*! \brief give a monitor error message \param msg error message \param info extra information */ void monitor_error (char *msg, char *info) { QUIT_ON_ERROR; mon_errors++; bufcpy (error_text, msg, BUFFER_SIZE); WRITELN (STDOUT_FILENO, a68g_cmd_name); WRITE (STDOUT_FILENO, ": monitor error: "); WRITE (STDOUT_FILENO, error_text); if (info != NO_TEXT) { WRITE (STDOUT_FILENO, " ("); WRITE (STDOUT_FILENO, info); WRITE (STDOUT_FILENO, ")"); } WRITE (STDOUT_FILENO, "."); } /*! \brief scan symbol from input \param f file number \param p position in tree */ static void scan_sym (FILE_T f, NODE_T * p) { int k = 0; (void) f; (void) p; symbol[0] = NULL_CHAR; attr = 0; QUIT_ON_ERROR; while (IS_SPACE (expr[pos])) { pos++; } if (expr[pos] == NULL_CHAR) { attr = 0; symbol[0] = NULL_CHAR; return; } else if (expr[pos] == ':') { if (strncmp (&(expr[pos]), ":=:", 3) == 0) { pos += 3; bufcpy (symbol, ":=:", BUFFER_SIZE); attr = IS_SYMBOL; } else if (strncmp (&(expr[pos]), ":/=:", 4) == 0) { pos += 4; bufcpy (symbol, ":/=:", BUFFER_SIZE); attr = ISNT_SYMBOL; } else if (strncmp (&(expr[pos]), ":=", 2) == 0) { pos += 2; bufcpy (symbol, ":=", BUFFER_SIZE); attr = ASSIGN_SYMBOL; } else { pos++; bufcpy (symbol, ":", BUFFER_SIZE); attr = COLON_SYMBOL; } return; } else if (expr[pos] == QUOTE_CHAR) { BOOL_T cont = A68_TRUE; pos++; while (cont) { while (expr[pos] != QUOTE_CHAR) { symbol[k++] = expr[pos++]; } if (expr[++pos] == QUOTE_CHAR) { symbol[k++] = QUOTE_CHAR; } else { cont = A68_FALSE; } } symbol[k] = NULL_CHAR; attr = ROW_CHAR_DENOTATION; return; } else if (IS_LOWER (expr[pos])) { while (IS_LOWER (expr[pos]) || IS_DIGIT (expr[pos]) || IS_SPACE (expr[pos])) { if (IS_SPACE (expr[pos])) { pos++; } else { symbol[k++] = expr[pos++]; } } symbol[k] = NULL_CHAR; attr = IDENTIFIER; return; } else if (IS_UPPER (expr[pos])) { KEYWORD_T *kw; while (IS_UPPER (expr[pos])) { symbol[k++] = expr[pos++]; } symbol[k] = NULL_CHAR; kw = find_keyword (top_keyword, symbol); if (kw != NO_KEYWORD) { attr = ATTRIBUTE (kw); } else { attr = OPERATOR; } return; } else if (IS_DIGIT (expr[pos])) { while (IS_DIGIT (expr[pos])) { symbol[k++] = expr[pos++]; } if (expr[pos] == 'r') { symbol[k++] = expr[pos++]; while (IS_XDIGIT (expr[pos])) { symbol[k++] = expr[pos++]; } symbol[k] = NULL_CHAR; attr = BITS_DENOTATION; return; } if (expr[pos] != POINT_CHAR && expr[pos] != 'e' && expr[pos] != 'E') { symbol[k] = NULL_CHAR; attr = INT_DENOTATION; return; } if (expr[pos] == POINT_CHAR) { symbol[k++] = expr[pos++]; while (IS_DIGIT (expr[pos])) { symbol[k++] = expr[pos++]; } } if (expr[pos] != 'e' && expr[pos] != 'E') { symbol[k] = NULL_CHAR; attr = REAL_DENOTATION; return; } symbol[k++] = (char) TO_UPPER (expr[pos++]); if (expr[pos] == '+' || expr[pos] == '-') { symbol[k++] = expr[pos++]; } while (IS_DIGIT (expr[pos])) { symbol[k++] = expr[pos++]; } symbol[k] = NULL_CHAR; attr = REAL_DENOTATION; return; } else if (a68g_strchr (MONADS, expr[pos]) != NO_TEXT || a68g_strchr (NOMADS, expr[pos]) != NO_TEXT) { symbol[k++] = expr[pos++]; if (a68g_strchr (NOMADS, expr[pos]) != NO_TEXT) { symbol[k++] = expr[pos++]; } if (expr[pos] == ':') { symbol[k++] = expr[pos++]; if (expr[pos] == '=') { symbol[k++] = expr[pos++]; } else { symbol[k] = NULL_CHAR; monitor_error ("invalid operator symbol", symbol); } } else if (expr[pos] == '=') { symbol[k++] = expr[pos++]; if (expr[pos] == ':') { symbol[k++] = expr[pos++]; } else { symbol[k] = NULL_CHAR; monitor_error ("invalid operator symbol", symbol); } } symbol[k] = NULL_CHAR; attr = OPERATOR; return; } else if (expr[pos] == '(') { pos++; attr = OPEN_SYMBOL; return; } else if (expr[pos] == ')') { pos++; attr = CLOSE_SYMBOL; return; } else if (expr[pos] == '[') { pos++; attr = SUB_SYMBOL; return; } else if (expr[pos] == ']') { pos++; attr = BUS_SYMBOL; return; } else if (expr[pos] == ',') { pos++; attr = COMMA_SYMBOL; return; } else if (expr[pos] == ';') { pos++; attr = SEMI_SYMBOL; return; } } /*! \brief find a tag, searching symbol tables towards the root \param table symbol table \param a attribute \param name name of token \return entry in symbol table **/ static TAG_T *find_tag (TABLE_T * table, int a, char *name) { if (table != NO_TABLE) { TAG_T *s = NO_TAG; if (a == OP_SYMBOL) { s = OPERATORS (table); } else if (a == PRIO_SYMBOL) { s = PRIO (table); } else if (a == IDENTIFIER) { s = IDENTIFIERS (table); } else if (a == INDICANT) { s = INDICANTS (table); } else if (a == LABEL) { s = LABELS (table); } else { ABEND (A68_TRUE, "impossible state in find_tag_global", NO_TEXT); } for (; s != NO_TAG; FORWARD (s)) { if (strcmp (NSYMBOL (NODE (s)), name) == 0) { return (s); } } return (find_tag_global (PREVIOUS (table), a, name)); } else { return (NO_TAG); } } /*! \brief priority for symbol at input \param f file number \param p position in tree \return same */ static int prio (FILE_T f, NODE_T * p) { TAG_T *s = find_tag (a68g_standenv, PRIO_SYMBOL, symbol); (void) p; (void) f; if (s == NO_TAG) { monitor_error ("unknown operator, cannot set priority", symbol); return (0); } return (PRIO (s)); } /*! \brief push a mode on the stack \param f file number \param m mode to push */ static void push_mode (FILE_T f, MOID_T * m) { (void) f; if (_m_sp < STACK_SIZE) { _m_stack[_m_sp++] = m; } else { monitor_error ("expression too complex", NO_TEXT); } } /*! \brief dereference, WEAK or otherwise \param k position in mode stack \param context context \return whether value can be dereferenced further */ static BOOL_T deref_condition (int k, int context) { MOID_T *u = _m_stack[k]; if (context == WEAK && SUB (u) != NO_MOID) { MOID_T *v = SUB (u); BOOL_T stowed = (BOOL_T) (IS (v, FLEX_SYMBOL) || IS (v, ROW_SYMBOL) || IS (v, STRUCT_SYMBOL)); return ((BOOL_T) (IS (u, REF_SYMBOL) && !stowed)); } else { return ((BOOL_T) (IS (u, REF_SYMBOL))); } } /*! \brief weak dereferencing \param p position in tree \param k position in mode stack \int context context */ static void deref (NODE_T * p, int k, int context) { while (deref_condition (k, context)) { A68_REF z; POP_REF (p, &z); CHECK_MON_REF (p, z, _m_stack[k]); _m_stack[k] = SUB (_m_stack[k]); PUSH (p, ADDRESS (&z), MOID_SIZE (_m_stack[k])); } } /*! \brief search moid that matches indicant \param refs whether we look for a REF indicant \param leng sizety of indicant \param indy indicant name \return moiD **/ static MOID_T *search_mode (int refs, int leng, char *indy) { MOID_T *m = NO_MOID, *z = NO_MOID; for (m = TOP_MOID (&program); m != NO_MOID; FORWARD (m)) { if (NODE (m) != NO_NODE) { if (indy == NSYMBOL (NODE (m)) && leng == DIM (m)) { z = m; while (EQUIVALENT (z) != NO_MOID) { z = EQUIVALENT (z); } } } } if (z == NO_MOID) { monitor_error ("unknown indicant", indy); return (NO_MOID); } for (m = TOP_MOID (&program); m != NO_MOID; FORWARD (m)) { int k = 0; while (IS (m, REF_SYMBOL)) { k++; m = SUB (m); } if (k == refs && m == z) { while (EQUIVALENT (z) != NO_MOID) { z = EQUIVALENT (z); } return (z); } } return (NO_MOID); } /*! \brief search operator X SYM Y \param sym operator name \param x lhs mode \param y rhs mode \return entry in symbol table */ static TAG_T *search_operator (char *sym, MOID_T * x, MOID_T * y) { TAG_T *t; for (t = OPERATORS (a68g_standenv); t != NO_TAG; FORWARD (t)) { if (strcmp (NSYMBOL (NODE (t)), sym) == 0) { PACK_T *p = PACK (MOID (t)); if (x == MOID (p)) { FORWARD (p); if (p == NO_PACK && y == NO_MOID) { /* Matched in case of a monad */ return (t); } else if (p != NO_PACK && y != NO_MOID && y == MOID (p)) { /* Matched in case of a nomad */ return (t); } } } } /* Not found yet, try dereferencing */ if (IS (x, REF_SYMBOL)) { return (search_operator (sym, SUB (x), y)); } if (y != NO_MOID && IS (y, REF_SYMBOL)) { return (search_operator (sym, x, SUB (y))); } /* Not found. Grrrr. Give a message */ if (y == NO_MOID) { ASSERT (snprintf (edit_line, SNPRINTF_SIZE, "%s %s", sym, moid_to_string (x, MOID_WIDTH, NO_NODE)) >= 0); } else { ASSERT (snprintf (edit_line, SNPRINTF_SIZE, "%s %s %s", moid_to_string (x, MOID_WIDTH, NO_NODE), sym, moid_to_string (y, MOID_WIDTH, NO_NODE)) >= 0); } monitor_error ("cannot find operator in standard environ", edit_line); return (NO_TAG); } /*! \brief search identifier in frame stack and push value \param f file number \param p position in tree \param a68g_link current frame pointer \param sym identifier name */ static void search_identifier (FILE_T f, NODE_T * p, ADDR_T a68g_link, char *sym) { if (a68g_link > 0) { int dynamic_a68g_link = FRAME_DYNAMIC_LINK (a68g_link); if (current_frame == 0 || (current_frame == FRAME_NUMBER (a68g_link))) { NODE_T *u = FRAME_TREE (a68g_link); if (u != NO_NODE) { TABLE_T *q = TABLE (u); TAG_T *i = IDENTIFIERS (q); for (; i != NO_TAG; FORWARD (i)) { if (strcmp (NSYMBOL (NODE (i)), sym) == 0) { ADDR_T posit = a68g_link + FRAME_INFO_SIZE + OFFSET (i); MOID_T *m = MOID (i); PUSH (p, FRAME_ADDRESS (posit), MOID_SIZE (m)); push_mode (f, m); return; } } } } search_identifier (f, p, dynamic_a68g_link, sym); } else { TABLE_T *q = a68g_standenv; TAG_T *i = IDENTIFIERS (q); for (; i != NO_TAG; FORWARD (i)) { if (strcmp (NSYMBOL (NODE (i)), sym) == 0) { if (IS (MOID (i), PROC_SYMBOL)) { static A68_PROCEDURE z; STATUS (&z) = (STATUS_MASK) (INIT_MASK | STANDENV_PROC_MASK); PROCEDURE (&(BODY (&z))) = PROCEDURE (i); ENVIRON (&z) = 0; LOCALE (&z) = NO_HANDLE; MOID (&z) = MOID (i); PUSH_PROCEDURE (p, z); } else { (*(PROCEDURE (i))) (p); } push_mode (f, MOID (i)); return; } } monitor_error ("cannot find identifier", sym); } } /*! \brief coerce arguments in a call \param f file number \param p position in tree */ static void coerce_arguments (FILE_T f, NODE_T * p, MOID_T * proc, int bot, int top, int top_sp) { int k; PACK_T *u; ADDR_T sp_2 = top_sp; (void) f; if ((top - bot) != DIM (proc)) { monitor_error ("invalid procedure argument count", NO_TEXT); } QUIT_ON_ERROR; for (k = bot, u = PACK (proc); k < top; k++, FORWARD (u)) { if (_m_stack[k] == MOID (u)) { PUSH (p, STACK_ADDRESS (sp_2), MOID_SIZE (MOID (u))); sp_2 += MOID_SIZE (MOID (u)); } else if (IS (_m_stack[k], REF_SYMBOL)) { A68_REF *v = (A68_REF *) STACK_ADDRESS (sp_2); PUSH_REF (p, *v); sp_2 += A68_REF_SIZE; deref (p, k, STRONG); if (_m_stack[k] != MOID (u)) { ASSERT (snprintf (edit_line, SNPRINTF_SIZE, "%s to %s", moid_to_string (_m_stack[k], MOID_WIDTH, NO_NODE), moid_to_string (MOID (u), MOID_WIDTH, NO_NODE)) >= 0); monitor_error ("invalid argument mode", edit_line); } } else { ASSERT (snprintf (edit_line, SNPRINTF_SIZE, "%s to %s", moid_to_string (_m_stack[k], MOID_WIDTH, NO_NODE), moid_to_string (MOID (u), MOID_WIDTH, NO_NODE)) >= 0); monitor_error ("cannot coerce argument", edit_line); } QUIT_ON_ERROR; } MOVE (STACK_ADDRESS (top_sp), STACK_ADDRESS (sp_2), stack_pointer - sp_2); stack_pointer = top_sp + (stack_pointer - sp_2); } /*! \brief perform a selection \param f file number \param p position in tree \param field field name */ static void selection (FILE_T f, NODE_T * p, char *field) { BOOL_T name; MOID_T *moid; PACK_T *u, *v; SCAN_CHECK (f, p); if (attr != IDENTIFIER && attr != OPEN_SYMBOL) { monitor_error ("invalid selection syntax", NO_TEXT); } QUIT_ON_ERROR; PARSE_CHECK (f, p, MAX_PRIORITY + 1); deref (p, _m_sp - 1, WEAK); if (IS (TOP_MODE, REF_SYMBOL)) { name = A68_TRUE; u = PACK (NAME (TOP_MODE)); moid = SUB (_m_stack[--_m_sp]); v = PACK (moid); } else { name = A68_FALSE; moid = _m_stack[--_m_sp]; u = PACK (moid); v = PACK (moid); } if (ISNT (moid, STRUCT_SYMBOL)) { monitor_error ("invalid selection mode", moid_to_string (moid, MOID_WIDTH, NO_NODE)); } QUIT_ON_ERROR; for (; u != NO_PACK; FORWARD (u), FORWARD (v)) { if (strcmp (field, TEXT (u)) == 0) { if (name) { A68_REF *z = (A68_REF *) (STACK_OFFSET (-A68_REF_SIZE)); CHECK_MON_REF (p, *z, moid); OFFSET (z) += OFFSET (v); } else { DECREMENT_STACK_POINTER (p, MOID_SIZE (moid)); MOVE (STACK_TOP, STACK_OFFSET (OFFSET (v)), (unsigned) MOID_SIZE (MOID (u))); INCREMENT_STACK_POINTER (p, MOID_SIZE (MOID (u))); } push_mode (f, MOID (u)); return; } } monitor_error ("invalid field name", field); } /*! \brief perform a call \param f file number \param p position in tree \param depth recursion depth */ static void call (FILE_T f, NODE_T * p, int depth) { A68_PROCEDURE z; NODE_T q; int args, old_m_sp; ADDR_T top_sp; MOID_T *proc; (void) depth; QUIT_ON_ERROR; deref (p, _m_sp - 1, STRONG); proc = _m_stack[--_m_sp]; old_m_sp = _m_sp; if (ISNT (proc, PROC_SYMBOL)) { monitor_error ("invalid procedure mode", moid_to_string (proc, MOID_WIDTH, NO_NODE)); } QUIT_ON_ERROR; POP_PROCEDURE (p, &z); args = _m_sp; top_sp = stack_pointer; if (attr == OPEN_SYMBOL) { do { SCAN_CHECK (f, p); PARSE_CHECK (f, p, 0); } while (attr == COMMA_SYMBOL); if (attr != CLOSE_SYMBOL) { monitor_error ("unmatched parenthesis", NO_TEXT); } SCAN_CHECK (f, p); } coerce_arguments (f, p, proc, args, _m_sp, top_sp); if (STATUS (&z) & STANDENV_PROC_MASK) { MOID (&q) = _m_stack[--_m_sp]; INFO (&q) = INFO (p); NSYMBOL (&q) = NSYMBOL (p); (void) ((*PROCEDURE (&(BODY (&z)))) (&q)); _m_sp = old_m_sp; push_mode (f, SUB_MOID (&z)); } else { monitor_error ("can only call standard environ routines", NO_TEXT); } } /*! \brief perform a slice \param f file number \param p position in tree \param depth recursion depth */ static void slice (FILE_T f, NODE_T * p, int depth) { MOID_T *moid, *res; A68_REF z; A68_ARRAY *arr; A68_TUPLE *tup; ADDR_T address; int dim, k, iindex, args; BOOL_T name; (void) depth; QUIT_ON_ERROR; deref (p, _m_sp - 1, WEAK); if (IS (TOP_MODE, REF_SYMBOL)) { name = A68_TRUE; res = NAME (TOP_MODE); deref (p, _m_sp - 1, STRONG); moid = _m_stack[--_m_sp]; } else { name = A68_FALSE; moid = _m_stack[--_m_sp]; res = SUB (moid); } if (ISNT (moid, ROW_SYMBOL) && ISNT (moid, FLEX_SYMBOL)) { monitor_error ("invalid row mode", moid_to_string (moid, MOID_WIDTH, NO_NODE)); } QUIT_ON_ERROR; /* Get descriptor */ POP_REF (p, &z); CHECK_MON_REF (p, z, moid); GET_DESCRIPTOR (arr, tup, &z); if (IS (moid, FLEX_SYMBOL)) { dim = DIM (SUB (moid)); } else { dim = DIM (moid); } /* Get iindexer */ args = _m_sp; if (attr == SUB_SYMBOL) { do { SCAN_CHECK (f, p); PARSE_CHECK (f, p, 0); } while (attr == COMMA_SYMBOL); if (attr != BUS_SYMBOL) { monitor_error ("unmatched parenthesis", NO_TEXT); } SCAN_CHECK (f, p); } if ((_m_sp - args) != dim) { monitor_error ("invalid slice index count", NO_TEXT); } QUIT_ON_ERROR; for (k = 0, iindex = 0; k < dim; k++, _m_sp--) { A68_TUPLE *t = &(tup[dim - k - 1]); A68_INT i; deref (p, _m_sp - 1, MEEK); if (TOP_MODE != MODE (INT)) { monitor_error ("invalid indexer mode", moid_to_string (TOP_MODE, MOID_WIDTH, NO_NODE)); } QUIT_ON_ERROR; POP_OBJECT (p, &i, A68_INT); if (VALUE (&i) < LOWER_BOUND (t) || VALUE (&i) > UPPER_BOUND (t)) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_INDEX_OUT_OF_BOUNDS); exit_genie (p, A68_RUNTIME_ERROR); } QUIT_ON_ERROR; iindex += SPAN (t) * VALUE (&i) - SHIFT (t); } address = ROW_ELEMENT (arr, iindex); if (name) { z = ARRAY (arr); OFFSET (&z) += address; REF_SCOPE (&z) = PRIMAL_SCOPE; PUSH_REF (p, z); } else { PUSH (p, ADDRESS (&(ARRAY (arr))) + address, MOID_SIZE (res)); } push_mode (f, res); } /*! \brief perform a call or a slice \param f file number \param p position in tree \param depth recursion depth */ static void call_or_slice (FILE_T f, NODE_T * p, int depth) { while (attr == OPEN_SYMBOL || attr == SUB_SYMBOL) { QUIT_ON_ERROR; if (attr == OPEN_SYMBOL) { call (f, p, depth); } else if (attr == SUB_SYMBOL) { slice (f, p, depth); } } } /*! \brief parse expression on input \param f file number \param p position in tree \param depth recursion depth */ static void parse (FILE_T f, NODE_T * p, int depth) { LOW_STACK_ALERT (p); QUIT_ON_ERROR; if (depth <= MAX_PRIORITY) { if (depth == 0) { /* Identity relations */ PARSE_CHECK (f, p, 1); while (attr == IS_SYMBOL || attr == ISNT_SYMBOL) { A68_REF x, y; BOOL_T res; int op = attr; if (TOP_MODE != MODE (HIP) && ISNT (TOP_MODE, REF_SYMBOL)) { monitor_error ("identity relation operand must yield a name", moid_to_string (TOP_MODE, MOID_WIDTH, NO_NODE)); } SCAN_CHECK (f, p); PARSE_CHECK (f, p, 1); if (TOP_MODE != MODE (HIP) && ISNT (TOP_MODE, REF_SYMBOL)) { monitor_error ("identity relation operand must yield a name", moid_to_string (TOP_MODE, MOID_WIDTH, NO_NODE)); } QUIT_ON_ERROR; if (TOP_MODE != MODE (HIP) && _m_stack[_m_sp - 2] != MODE (HIP)) { if (TOP_MODE != _m_stack[_m_sp - 2]) { monitor_error ("invalid identity relation operand mode", NO_TEXT); } } QUIT_ON_ERROR; _m_sp -= 2; POP_REF (p, &y); POP_REF (p, &x); res = (BOOL_T) (ADDRESS (&x) == ADDRESS (&y)); PUSH_PRIMITIVE (p, (BOOL_T) (op == IS_SYMBOL ? res : !res), A68_BOOL); push_mode (f, MODE (BOOL)); } } else { /* Dyadic expressions */ PARSE_CHECK (f, p, depth + 1); while (attr == OPERATOR && prio (f, p) == depth) { int args; ADDR_T top_sp; NODE_T q; TAG_T *opt; char name[BUFFER_SIZE]; bufcpy (name, symbol, BUFFER_SIZE); args = _m_sp - 1; top_sp = stack_pointer - MOID_SIZE (_m_stack[args]); SCAN_CHECK (f, p); PARSE_CHECK (f, p, depth + 1); opt = search_operator (name, _m_stack[_m_sp - 2], TOP_MODE); QUIT_ON_ERROR; coerce_arguments (f, p, MOID (opt), args, _m_sp, top_sp); _m_sp -= 2; MOID (&q) = MOID (opt); INFO (&q) = INFO (p); NSYMBOL (&q) = NSYMBOL (p); (void) ((*(PROCEDURE (opt)))) (&q); push_mode (f, SUB_MOID (opt)); } } } else if (attr == OPERATOR) { int args; ADDR_T top_sp; NODE_T q; TAG_T *opt; char name[BUFFER_SIZE]; bufcpy (name, symbol, BUFFER_SIZE); args = _m_sp; top_sp = stack_pointer; SCAN_CHECK (f, p); PARSE_CHECK (f, p, depth); opt = search_operator (name, TOP_MODE, NO_MOID); QUIT_ON_ERROR; coerce_arguments (f, p, MOID (opt), args, _m_sp, top_sp); _m_sp--; MOID (&q) = MOID (opt); INFO (&q) = INFO (p); NSYMBOL (&q) = NSYMBOL (p); (void) ((*(PROCEDURE (opt))) (&q)); push_mode (f, SUB_MOID (opt)); } else if (attr == REF_SYMBOL) { int refs = 0, length = 0; MOID_T *m = NO_MOID; while (attr == REF_SYMBOL) { refs++; SCAN_CHECK (f, p); } while (attr == LONG_SYMBOL) { length++; SCAN_CHECK (f, p); } m = search_mode (refs, length, symbol); QUIT_ON_ERROR; if (m == NO_MOID) { monitor_error ("unknown reference to mode", NO_TEXT); } SCAN_CHECK (f, p); if (attr != OPEN_SYMBOL) { monitor_error ("cast expects open-symbol", NO_TEXT); } SCAN_CHECK (f, p); PARSE_CHECK (f, p, 0); if (attr != CLOSE_SYMBOL) { monitor_error ("cast expects close-symbol", NO_TEXT); } SCAN_CHECK (f, p); while (IS (TOP_MODE, REF_SYMBOL) && TOP_MODE != m) { MOID_T *sub = SUB (TOP_MODE); A68_REF z; POP_REF (p, &z); CHECK_MON_REF (p, z, TOP_MODE); PUSH (p, ADDRESS (&z), MOID_SIZE (sub)); TOP_MODE = sub; } if (TOP_MODE != m) { monitor_error ("invalid cast mode", moid_to_string (TOP_MODE, MOID_WIDTH, NO_NODE)); } } else if (attr == LONG_SYMBOL) { int length = 0; MOID_T *m; while (attr == LONG_SYMBOL) { length++; SCAN_CHECK (f, p); } /* Cast L INT -> L REAL */ if (attr == REAL_SYMBOL) { MOID_T *i = (length == 1 ? MODE (LONG_INT) : MODE (LONGLONG_INT)); MOID_T *r = (length == 1 ? MODE (LONG_REAL) : MODE (LONGLONG_REAL)); SCAN_CHECK (f, p); if (attr != OPEN_SYMBOL) { monitor_error ("cast expects open-symbol", NO_TEXT); } SCAN_CHECK (f, p); PARSE_CHECK (f, p, 0); if (attr != CLOSE_SYMBOL) { monitor_error ("cast expects close-symbol", NO_TEXT); } SCAN_CHECK (f, p); if (TOP_MODE != i) { monitor_error ("invalid cast argument mode", moid_to_string (TOP_MODE, MOID_WIDTH, NO_NODE)); } QUIT_ON_ERROR; TOP_MODE = r; return; } /* L INT or L REAL denotation */ if (attr == INT_DENOTATION) { m = (length == 1 ? MODE (LONG_INT) : MODE (LONGLONG_INT)); } else if (attr == REAL_DENOTATION) { m = (length == 1 ? MODE (LONG_REAL) : MODE (LONGLONG_REAL)); } else if (attr == BITS_DENOTATION) { m = (length == 1 ? MODE (LONG_BITS) : MODE (LONGLONG_BITS)); } else { m = NO_MOID; } if (m != NO_MOID) { int digits = get_mp_digits (m); MP_T *z; STACK_MP (z, p, digits); if (genie_string_to_value_internal (p, m, symbol, (BYTE_T *) z) == A68_FALSE) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_IN_DENOTATION, m); exit_genie (p, A68_RUNTIME_ERROR); } z[0] = (MP_T) (INIT_MASK | CONSTANT_MASK); push_mode (f, m); SCAN_CHECK (f, p); } else { monitor_error ("invalid mode", NO_TEXT); } } else if (attr == INT_DENOTATION) { A68_INT z; if (genie_string_to_value_internal (p, MODE (INT), symbol, (BYTE_T *) & z) == A68_FALSE) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_IN_DENOTATION, MODE (INT)); exit_genie (p, A68_RUNTIME_ERROR); } PUSH_PRIMITIVE (p, VALUE (&z), A68_INT); push_mode (f, MODE (INT)); SCAN_CHECK (f, p); } else if (attr == REAL_DENOTATION) { A68_REAL z; if (genie_string_to_value_internal (p, MODE (REAL), symbol, (BYTE_T *) & z) == A68_FALSE) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_IN_DENOTATION, MODE (REAL)); exit_genie (p, A68_RUNTIME_ERROR); } PUSH_PRIMITIVE (p, VALUE (&z), A68_REAL); push_mode (f, MODE (REAL)); SCAN_CHECK (f, p); } else if (attr == BITS_DENOTATION) { A68_BITS z; if (genie_string_to_value_internal (p, MODE (BITS), symbol, (BYTE_T *) & z) == A68_FALSE) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_IN_DENOTATION, MODE (BITS)); exit_genie (p, A68_RUNTIME_ERROR); } PUSH_PRIMITIVE (p, VALUE (&z), A68_BITS); push_mode (f, MODE (BITS)); SCAN_CHECK (f, p); } else if (attr == ROW_CHAR_DENOTATION) { if (strlen (symbol) == 1) { PUSH_PRIMITIVE (p, symbol[0], A68_CHAR); push_mode (f, MODE (CHAR)); } else { A68_REF z; A68_ARRAY *arr; A68_TUPLE *tup; z = c_to_a_string (p, symbol, DEFAULT_WIDTH); GET_DESCRIPTOR (arr, tup, &z); BLOCK_GC_HANDLE (&z); BLOCK_GC_HANDLE (&(ARRAY (arr))); PUSH_REF (p, z); push_mode (f, MODE (STRING)); } SCAN_CHECK (f, p); } else if (attr == TRUE_SYMBOL) { PUSH_PRIMITIVE (p, A68_TRUE, A68_BOOL); push_mode (f, MODE (BOOL)); SCAN_CHECK (f, p); } else if (attr == FALSE_SYMBOL) { PUSH_PRIMITIVE (p, A68_FALSE, A68_BOOL); push_mode (f, MODE (BOOL)); SCAN_CHECK (f, p); } else if (attr == NIL_SYMBOL) { PUSH_REF (p, nil_ref); push_mode (f, MODE (HIP)); SCAN_CHECK (f, p); } else if (attr == REAL_SYMBOL) { A68_INT k; SCAN_CHECK (f, p); if (attr != OPEN_SYMBOL) { monitor_error ("cast expects open-symbol", NO_TEXT); } SCAN_CHECK (f, p); PARSE_CHECK (f, p, 0); if (attr != CLOSE_SYMBOL) { monitor_error ("cast expects close-symbol", NO_TEXT); } SCAN_CHECK (f, p); if (TOP_MODE != MODE (INT)) { monitor_error ("invalid cast argument mode", moid_to_string (TOP_MODE, MOID_WIDTH, NO_NODE)); } QUIT_ON_ERROR; POP_OBJECT (p, &k, A68_INT); PUSH_PRIMITIVE (p, (double) VALUE (&k), A68_REAL); TOP_MODE = MODE (REAL); } else if (attr == IDENTIFIER) { ADDR_T old_sp = stack_pointer; BOOL_T init; MOID_T *moid; char name[BUFFER_SIZE]; bufcpy (name, symbol, BUFFER_SIZE); SCAN_CHECK (f, p); if (attr == OF_SYMBOL) { selection (f, p, name); } else { search_identifier (f, p, frame_pointer, name); QUIT_ON_ERROR; call_or_slice (f, p, depth); } moid = TOP_MODE; QUIT_ON_ERROR; if (check_initialisation (p, STACK_ADDRESS (old_sp), moid, &init)) { if (init == A68_FALSE) { monitor_error (NO_VALUE, name); } } else { monitor_error ("cannot process value of mode", moid_to_string (moid, MOID_WIDTH, NO_NODE)); } } else if (attr == OPEN_SYMBOL) { do { SCAN_CHECK (f, p); PARSE_CHECK (f, p, 0); } while (attr == COMMA_SYMBOL); if (attr != CLOSE_SYMBOL) { monitor_error ("unmatched parenthesis", NO_TEXT); } SCAN_CHECK (f, p); call_or_slice (f, p, depth); } else { monitor_error ("invalid expression syntax", NO_TEXT); } } /*! \brief perform assignment \param f file number \param p position in tree */ static void assign (FILE_T f, NODE_T * p) { LOW_STACK_ALERT (p); PARSE_CHECK (f, p, 0); if (attr == ASSIGN_SYMBOL) { MOID_T *m = _m_stack[--_m_sp]; A68_REF z; if (ISNT (m, REF_SYMBOL)) { monitor_error ("invalid destination mode", moid_to_string (m, MOID_WIDTH, NO_NODE)); } QUIT_ON_ERROR; POP_REF (p, &z); CHECK_MON_REF (p, z, m); SCAN_CHECK (f, p); assign (f, p); QUIT_ON_ERROR; while (IS (TOP_MODE, REF_SYMBOL) && TOP_MODE != SUB (m)) { MOID_T *sub = SUB (TOP_MODE); A68_REF y; POP_REF (p, &y); CHECK_MON_REF (p, y, TOP_MODE); PUSH (p, ADDRESS (&y), MOID_SIZE (sub)); TOP_MODE = sub; } if (TOP_MODE != SUB (m) && TOP_MODE != MODE (HIP)) { monitor_error ("invalid source mode", moid_to_string (TOP_MODE, MOID_WIDTH, NO_NODE)); } QUIT_ON_ERROR; POP (p, ADDRESS (&z), MOID_SIZE (TOP_MODE)); PUSH_REF (p, z); TOP_MODE = m; } } /*! \brief evaluate expression on input \param f file number \param p position in tree \param str expression string */ static void evaluate (FILE_T f, NODE_T * p, char *str) { LOW_STACK_ALERT (p); _m_sp = 0; _m_stack[0] = NO_MOID; pos = 0; bufcpy (expr, str, BUFFER_SIZE); SCAN_CHECK (f, p); QUIT_ON_ERROR; assign (f, p); if (attr != 0) { monitor_error ("trailing character in expression", symbol); } } /*! \brief convert string to int \param num number to convert \return int value or NOT_A_NUM if we cannot */ static int get_num_arg (char *num, char **rest) { char *end; int k; if (rest != NO_VAR) { *rest = NO_TEXT; } if (num == NO_TEXT) { return (NOT_A_NUM); } SKIP_ONE_SYMBOL (num); if (IS_DIGIT (num[0])) { RESET_ERRNO; k = (int) a68g_strtoul (num, &end, 10); if (end != num && errno == 0) { if (rest != NO_VAR) { *rest = end; } return (k); } else { monitor_error ("invalid numerical argument", error_specification ()); return (NOT_A_NUM); } } else { if (num[0] != NULL_CHAR) { monitor_error ("invalid numerical argument", num); } return (NOT_A_NUM); } } /*! \brief whether item at "w" of mode "q" is initialised \param p position in tree \param w pointer to object \param q moid of object \param result whether object is initialised \return whether mode of object is recognised **/ static BOOL_T check_initialisation (NODE_T * p, BYTE_T * w, MOID_T * q, BOOL_T * result) { BOOL_T initialised = A68_FALSE, recognised = A68_FALSE; (void) p; switch (SHORT_ID (q)) { case MODE_NO_CHECK: case UNION_SYMBOL: { initialised = A68_TRUE; recognised = A68_TRUE; break; } case REF_SYMBOL: { A68_REF *z = (A68_REF *) w; initialised = INITIALISED (z); recognised = A68_TRUE; break; } case PROC_SYMBOL: { A68_PROCEDURE *z = (A68_PROCEDURE *) w; initialised = INITIALISED (z); recognised = A68_TRUE; break; } case MODE_INT: { A68_INT *z = (A68_INT *) w; initialised = INITIALISED (z); recognised = A68_TRUE; break; } case MODE_REAL: { A68_REAL *z = (A68_REAL *) w; initialised = INITIALISED (z); recognised = A68_TRUE; break; } case MODE_COMPLEX: { A68_REAL *r = (A68_REAL *) w; A68_REAL *i = (A68_REAL *) (w + ALIGNED_SIZE_OF (A68_REAL)); initialised = (BOOL_T) (INITIALISED (r) && INITIALISED (i)); recognised = A68_TRUE; break; } case MODE_LONG_INT: case MODE_LONG_REAL: case MODE_LONG_BITS: { MP_T *z = (MP_T *) w; initialised = (BOOL_T) ((unsigned) z[0] & INIT_MASK); recognised = A68_TRUE; break; } case MODE_LONGLONG_INT: case MODE_LONGLONG_REAL: case MODE_LONGLONG_BITS: { MP_T *z = (MP_T *) w; initialised = (BOOL_T) ((unsigned) z[0] & INIT_MASK); recognised = A68_TRUE; break; } case MODE_LONG_COMPLEX: { MP_T *r = (MP_T *) w; MP_T *i = (MP_T *) (w + size_long_mp ()); initialised = (BOOL_T) (((unsigned) r[0] & INIT_MASK) && ((unsigned) i[0] & INIT_MASK)); recognised = A68_TRUE; break; } case MODE_LONGLONG_COMPLEX: { MP_T *r = (MP_T *) w; MP_T *i = (MP_T *) (w + size_long_mp ()); initialised = (BOOL_T) (((unsigned) r[0] & INIT_MASK) && ((unsigned) i[0] & INIT_MASK)); recognised = A68_TRUE; break; } case MODE_BOOL: { A68_BOOL *z = (A68_BOOL *) w; initialised = INITIALISED (z); recognised = A68_TRUE; break; } case MODE_CHAR: { A68_CHAR *z = (A68_CHAR *) w; initialised = INITIALISED (z); recognised = A68_TRUE; break; } case MODE_BITS: { A68_BITS *z = (A68_BITS *) w; initialised = INITIALISED (z); recognised = A68_TRUE; break; } case MODE_BYTES: { A68_BYTES *z = (A68_BYTES *) w; initialised = INITIALISED (z); recognised = A68_TRUE; break; } case MODE_LONG_BYTES: { A68_LONG_BYTES *z = (A68_LONG_BYTES *) w; initialised = INITIALISED (z); recognised = A68_TRUE; break; } case MODE_FILE: { A68_FILE *z = (A68_FILE *) w; initialised = INITIALISED (z); recognised = A68_TRUE; break; } case MODE_FORMAT: { A68_FORMAT *z = (A68_FORMAT *) w; initialised = INITIALISED (z); recognised = A68_TRUE; break; } case MODE_PIPE: { A68_REF *pipe_read = (A68_REF *) w; A68_REF *pipe_write = (A68_REF *) (w + A68_REF_SIZE); A68_INT *pid = (A68_INT *) (w + 2 * A68_REF_SIZE); initialised = (BOOL_T) (INITIALISED (pipe_read) && INITIALISED (pipe_write) && INITIALISED (pid)); recognised = A68_TRUE; break; } case MODE_SOUND: { A68_SOUND *z = (A68_SOUND *) w; initialised = INITIALISED (z); recognised = A68_TRUE; } } if (result != NO_BOOL) { *result = initialised; } return (recognised); } /*! \brief show value of object \param p position in tree \param f file number \param item pointer to object \param mode mode of object **/ void print_item (NODE_T * p, FILE_T f, BYTE_T * item, MOID_T * mode) { A68_REF nil_file = nil_ref; reset_transput_buffer (UNFORMATTED_BUFFER); genie_write_standard (p, mode, item, nil_file); if (get_transput_buffer_index (UNFORMATTED_BUFFER) > 0) { if (mode == MODE (CHAR) || mode == MODE (ROW_CHAR) || mode == MODE (STRING)) { ASSERT (snprintf (output_line, SNPRINTF_SIZE, " \"%s\"", get_transput_buffer (UNFORMATTED_BUFFER)) >= 0); WRITE (f, output_line); } else { char *str = get_transput_buffer (UNFORMATTED_BUFFER); while (IS_SPACE (str[0])) { str++; } ASSERT (snprintf (output_line, SNPRINTF_SIZE, " %s", str) >= 0); WRITE (f, output_line); } } else { WRITE (f, CANNOT_SHOW); } } /*! \brief indented indent_crlf \param f file number **/ static void indent_crlf (FILE_T f) { int k; io_close_tty_line (); for (k = 0; k < tabs; k++) { WRITE (f, " "); } } /*! \brief show value of object \param p position in tree \param f file number \param item pointer to object \param mode mode of object **/ static void show_item (FILE_T f, NODE_T * p, BYTE_T * item, MOID_T * mode) { if (item == NO_BYTE || mode == NO_MOID) { return; } if (IS (mode, REF_SYMBOL)) { A68_REF *z = (A68_REF *) item; if (IS_NIL (*z)) { if (INITIALISED (z)) { WRITE (STDOUT_FILENO, " = NIL"); } else { WRITE (STDOUT_FILENO, NO_VALUE); } } else { if (INITIALISED (z)) { WRITE (STDOUT_FILENO, " refers to "); if (IS_IN_HEAP (z)) { ASSERT (snprintf (output_line, SNPRINTF_SIZE, "heap(%p)", ADDRESS (z)) >= 0); WRITE (STDOUT_FILENO, output_line); tabs++; show_item (f, p, ADDRESS (z), SUB (mode)); tabs--; } else if (IS_IN_FRAME (z)) { ASSERT (snprintf (output_line, SNPRINTF_SIZE, "frame(%d)", REF_OFFSET (z)) >= 0); WRITE (STDOUT_FILENO, output_line); } else if (IS_IN_STACK (z)) { ASSERT (snprintf (output_line, SNPRINTF_SIZE, "stack(%d)", REF_OFFSET (z)) >= 0); WRITE (STDOUT_FILENO, output_line); } } else { WRITE (STDOUT_FILENO, NO_VALUE); } } } else if (mode == MODE (STRING)) { if (!INITIALISED ((A68_REF *) item)) { WRITE (STDOUT_FILENO, NO_VALUE); } else { print_item (p, f, item, mode); } } else if ((IS (mode, ROW_SYMBOL) || IS (mode, FLEX_SYMBOL)) && mode != MODE (STRING)) { MOID_T *deflexed = DEFLEX (mode); int old_tabs = tabs; tabs += 2; if (!INITIALISED ((A68_REF *) item)) { WRITE (STDOUT_FILENO, NO_VALUE); } else { A68_ARRAY *arr; A68_TUPLE *tup; int count = 0, act_count = 0, elems; GET_DESCRIPTOR (arr, tup, (A68_REF *) item); elems = get_row_size (tup, DIM (arr)); ASSERT (snprintf (output_line, SNPRINTF_SIZE, ", %d element(s)", elems) >= 0); WRITE (f, output_line); if (get_row_size (tup, DIM (arr)) != 0) { BYTE_T *base_addr = ADDRESS (&ARRAY (arr)); BOOL_T done = A68_FALSE; initialise_internal_index (tup, DIM (arr)); while (!done && ++count <= (max_row_elems + 1)) { if (count <= max_row_elems) { ADDR_T row_index = calculate_internal_index (tup, DIM (arr)); ADDR_T elem_addr = ROW_ELEMENT (arr, row_index); BYTE_T *elem = &base_addr[elem_addr]; indent_crlf (f); WRITE (f, "["); print_internal_index (f, tup, DIM (arr)); WRITE (f, "]"); show_item (f, p, elem, SUB (deflexed)); act_count++; done = increment_internal_index (tup, DIM (arr)); } } indent_crlf (f); ASSERT (snprintf (output_line, SNPRINTF_SIZE, " %d element(s) written (%d%%)", act_count, (int) ((100.0 * act_count) / elems)) >= 0); WRITE (f, output_line); } } tabs = old_tabs; } else if (IS (mode, STRUCT_SYMBOL)) { PACK_T *q = PACK (mode); tabs++; for (; q != NO_PACK; FORWARD (q)) { BYTE_T *elem = &item[OFFSET (q)]; indent_crlf (f); ASSERT (snprintf (output_line, SNPRINTF_SIZE, " %s \"%s\"", moid_to_string (MOID (q), MOID_WIDTH, NO_NODE), TEXT (q)) >= 0); WRITE (STDOUT_FILENO, output_line); show_item (f, p, elem, MOID (q)); } tabs--; } else if (IS (mode, UNION_SYMBOL)) { A68_UNION *z = (A68_UNION *) item; ASSERT (snprintf (output_line, SNPRINTF_SIZE, " united-moid %s", moid_to_string ((MOID_T *) (VALUE (z)), MOID_WIDTH, NO_NODE)) >= 0); WRITE (STDOUT_FILENO, output_line); show_item (f, p, &item[ALIGNED_SIZE_OF (A68_UNION)], (MOID_T *) (VALUE (z))); } else if (mode == MODE (SIMPLIN)) { A68_UNION *z = (A68_UNION *) item; ASSERT (snprintf (output_line, SNPRINTF_SIZE, " united-moid %s", moid_to_string ((MOID_T *) (VALUE (z)), MOID_WIDTH, NO_NODE)) >= 0); WRITE (STDOUT_FILENO, output_line); } else if (mode == MODE (SIMPLOUT)) { A68_UNION *z = (A68_UNION *) item; ASSERT (snprintf (output_line, SNPRINTF_SIZE, " united-moid %s", moid_to_string ((MOID_T *) (VALUE (z)), MOID_WIDTH, NO_NODE)) >= 0); WRITE (STDOUT_FILENO, output_line); } else { BOOL_T init; if (check_initialisation (p, item, mode, &init)) { if (init) { if (IS (mode, PROC_SYMBOL)) { A68_PROCEDURE *z = (A68_PROCEDURE *) item; if (z != NO_PROCEDURE && STATUS (z) & STANDENV_PROC_MASK) { char *fname = standard_environ_proc_name (*(PROCEDURE (&BODY (z)))); WRITE (STDOUT_FILENO, " standenv procedure"); if (fname != NO_TEXT) { WRITE (STDOUT_FILENO, " ("); WRITE (STDOUT_FILENO, fname); WRITE (STDOUT_FILENO, ")"); } } else if (z != NO_PROCEDURE && STATUS (z) & SKIP_PROCEDURE_MASK) { WRITE (STDOUT_FILENO, " skip procedure"); } else if (z != NO_PROCEDURE && (PROCEDURE (&BODY (z))) != NO_GPROC) { ASSERT (snprintf (output_line, SNPRINTF_SIZE, " line %d, environ at frame(%d), locale %p", LINE_NUMBER ((NODE_T *) NODE (&BODY (z))), ENVIRON (z), (void *) LOCALE (z)) >= 0); WRITE (STDOUT_FILENO, output_line); } else { WRITE (STDOUT_FILENO, " cannot show value"); } } else if (mode == MODE (FORMAT)) { A68_FORMAT *z = (A68_FORMAT *) item; if (z != NO_FORMAT && BODY (z) != NO_NODE) { ASSERT (snprintf (output_line, SNPRINTF_SIZE, " line %d, environ at frame(%d)", LINE_NUMBER (BODY (z)), ENVIRON (z)) >= 0); WRITE (STDOUT_FILENO, output_line); } else { monitor_error (CANNOT_SHOW, NO_TEXT); } } else if (mode == MODE (SOUND)) { A68_SOUND *z = (A68_SOUND *) item; if (z != NO_SOUND) { ASSERT (snprintf (output_line, SNPRINTF_SIZE, "%u channels, %u bits, %u rate, %u samples", NUM_CHANNELS (z), BITS_PER_SAMPLE (z), SAMPLE_RATE (z), NUM_SAMPLES (z)) >= 0); WRITE (STDOUT_FILENO, output_line); } else { monitor_error (CANNOT_SHOW, NO_TEXT); } } else { print_item (p, f, item, mode); } } else { WRITE (STDOUT_FILENO, NO_VALUE); } } else { ASSERT (snprintf (output_line, SNPRINTF_SIZE, " mode %s, %s", moid_to_string (mode, MOID_WIDTH, NO_NODE), CANNOT_SHOW) >= 0); WRITE (STDOUT_FILENO, output_line); } } } /*! \brief overview of frame item \param f file number \param p position in tree \param a68g_link current frame pointer \param q tag \param modif output modifier **/ static void show_frame_item (FILE_T f, NODE_T * p, ADDR_T a68g_link, TAG_T * q, int modif) { ADDR_T addr = a68g_link + FRAME_INFO_SIZE + OFFSET (q); ADDR_T loc = FRAME_INFO_SIZE + OFFSET (q); (void) p; indent_crlf (STDOUT_FILENO); if (modif != ANONYMOUS) { ASSERT (snprintf (output_line, SNPRINTF_SIZE, " frame(%d=%d+%d) %s \"%s\"", addr, a68g_link, loc, moid_to_string (MOID (q), MOID_WIDTH, NO_NODE), NSYMBOL (NODE (q))) >= 0); WRITE (STDOUT_FILENO, output_line); show_item (f, p, FRAME_ADDRESS (addr), MOID (q)); } else { switch (PRIO (q)) { case GENERATOR: { ASSERT (snprintf (output_line, SNPRINTF_SIZE, " frame(%d=%d+%d) LOC %s", addr, a68g_link, loc, moid_to_string (MOID (q), MOID_WIDTH, NO_NODE)) >= 0); WRITE (STDOUT_FILENO, output_line); break; } default: { ASSERT (snprintf (output_line, SNPRINTF_SIZE, " frame(%d=%d+%d) internal %s", addr, a68g_link, loc, moid_to_string (MOID (q), MOID_WIDTH, NO_NODE)) >= 0); WRITE (STDOUT_FILENO, output_line); break; } } show_item (f, p, FRAME_ADDRESS (addr), MOID (q)); } } /*! \brief overview of frame items \param f file number \param p position in tree \param a68g_link current frame pointer \param q tag \param modif output modifier **/ static void show_frame_items (FILE_T f, NODE_T * p, ADDR_T a68g_link, TAG_T * q, int modif) { (void) p; for (; q != NO_TAG; FORWARD (q)) { show_frame_item (f, p, a68g_link, q, modif); } } /*! \brief introduce stack frame \param f file number \param p position in tree \param a68g_link current frame pointer \param printed printed item counter **/ static void intro_frame (FILE_T f, NODE_T * p, ADDR_T a68g_link, int *printed) { TABLE_T *q = TABLE (p); if (*printed > 0) { WRITELN (f, ""); } (*printed)++; where_in_source (f, p); ASSERT (snprintf (output_line, SNPRINTF_SIZE, "Stack frame %d at frame(%d), level=%d, size=%d bytes", FRAME_NUMBER (a68g_link), a68g_link, LEVEL (q), FRAME_INCREMENT (a68g_link) + FRAME_INFO_SIZE) >= 0); WRITELN (f, output_line); } /*! \brief view contents of stack frame \param f file number \param p position in tree \param a68g_link current frame pointer \param printed printed item counter **/ static void show_stack_frame (FILE_T f, NODE_T * p, ADDR_T a68g_link, int *printed) { /* show the frame starting at frame pointer 'a68g_link', using symbol table from p as a map */ if (p != NO_NODE) { TABLE_T *q = TABLE (p); intro_frame (f, p, a68g_link, printed); ASSERT (snprintf (output_line, SNPRINTF_SIZE, "Dynamic link=frame(%d), static link=frame(%d), parameters=frame(%d)", FRAME_DYNAMIC_LINK (a68g_link), FRAME_STATIC_LINK (a68g_link), FRAME_PARAMETERS (a68g_link)) >= 0); WRITELN (STDOUT_FILENO, output_line); ASSERT (snprintf (output_line, SNPRINTF_SIZE, "Procedure frame=%s", (FRAME_PROC_FRAME (a68g_link) ? "yes" : "no")) >= 0); WRITELN (STDOUT_FILENO, output_line); #if defined HAVE_PARALLEL_CLAUSE if (pthread_equal (FRAME_THREAD_ID (a68g_link), main_thread_id) != 0) { ASSERT (snprintf (output_line, SNPRINTF_SIZE, "In main thread") >= 0); } else { ASSERT (snprintf (output_line, SNPRINTF_SIZE, "Not in main thread") >= 0); } WRITELN (STDOUT_FILENO, output_line); #endif show_frame_items (f, p, a68g_link, IDENTIFIERS (q), IDENTIFIER); show_frame_items (f, p, a68g_link, OPERATORS (q), OPERATOR); show_frame_items (f, p, a68g_link, ANONYMOUS (q), ANONYMOUS); } } /*! \brief shows lines around the line where 'p' is at \param f file number \param p position in tree \param n first line number \param m last line number **/ static void list (FILE_T f, NODE_T * p, int n, int m) { if (p != NO_NODE) { if (m == 0) { LINE_T *r = LINE (INFO (p)); LINE_T *l = TOP_LINE (&program); for (; l != NO_LINE; FORWARD (l)) { if (NUMBER (l) > 0 && abs (NUMBER (r) - NUMBER (l)) <= n) { write_source_line (f, l, NO_NODE, A68_TRUE); } } } else { LINE_T *l = TOP_LINE (&program); for (; l != NO_LINE; FORWARD (l)) { if (NUMBER (l) > 0 && NUMBER (l) >= n && NUMBER (l) <= m) { write_source_line (f, l, NO_NODE, A68_TRUE); } } } } } /*! \brief overview of the heap \param f file number \param p position in tree \param z handle where to start \param top maximum size \param n number of handles to print **/ void show_heap (FILE_T f, NODE_T * p, A68_HANDLE * z, int top, int n) { int k = 0, m = n, sum = 0; (void) p; ASSERT (snprintf (output_line, SNPRINTF_SIZE, "size=%d available=%d garbage collections=%d", heap_size, heap_available (), garbage_collects) >= 0); WRITELN (f, output_line); for (; z != NO_HANDLE; FORWARD (z), k++) { if (n > 0 && sum <= top) { n--; indent_crlf (f); ASSERT (snprintf (output_line, SNPRINTF_SIZE, "heap(%p+%d) %s", POINTER (z), SIZE (z), moid_to_string (MOID (z), MOID_WIDTH, NO_NODE)) >= 0); WRITE (f, output_line); sum += SIZE (z); } } ASSERT (snprintf (output_line, SNPRINTF_SIZE, "printed %d out of %d handles", m, k) >= 0); WRITELN (f, output_line); } /*! \brief search current frame and print it \param f file number \param a68g_link current frame pointer **/ void stack_dump_current (FILE_T f, ADDR_T a68g_link) { if (a68g_link > 0) { int dynamic_a68g_link = FRAME_DYNAMIC_LINK (a68g_link); NODE_T *p = FRAME_TREE (a68g_link); if (p != NO_NODE && LEVEL (TABLE (p)) > 3) { if (FRAME_NUMBER (a68g_link) == current_frame) { int printed = 0; show_stack_frame (f, p, a68g_link, &printed); } else { stack_dump_current (f, dynamic_a68g_link); } } } } /*! \brief overview of the stack \param f file number \param a68g_link current frame pointer \param depth number of frames left to print \param printed counts items printed **/ void stack_a68g_link_dump (FILE_T f, ADDR_T a68g_link, int depth, int *printed) { if (depth > 0 && a68g_link > 0) { NODE_T *p = FRAME_TREE (a68g_link); if (p != NO_NODE && LEVEL (TABLE (p)) > 3) { show_stack_frame (f, p, a68g_link, printed); stack_a68g_link_dump (f, FRAME_STATIC_LINK (a68g_link), depth - 1, printed); } } } /*! \brief overview of the stack \param f file number \param a68g_link current frame pointer \param depth number of frames left to print \param printed counts items printed **/ void stack_dump (FILE_T f, ADDR_T a68g_link, int depth, int *printed) { if (depth > 0 && a68g_link > 0) { NODE_T *p = FRAME_TREE (a68g_link); if (p != NO_NODE && LEVEL (TABLE (p)) > 3) { show_stack_frame (f, p, a68g_link, printed); stack_dump (f, FRAME_DYNAMIC_LINK (a68g_link), depth - 1, printed); } } } /*! \brief overview of the stack \param f file number \param a68g_link current frame pointer \param depth number of frames left to print \param printed counts items printed **/ void stack_trace (FILE_T f, ADDR_T a68g_link, int depth, int *printed) { if (depth > 0 && a68g_link > 0) { int dynamic_a68g_link = FRAME_DYNAMIC_LINK (a68g_link); if (FRAME_PROC_FRAME (a68g_link)) { NODE_T *p = FRAME_TREE (a68g_link); show_stack_frame (f, p, a68g_link, printed); stack_trace (f, dynamic_a68g_link, depth - 1, printed); } else { stack_trace (f, dynamic_a68g_link, depth, printed); } } } /*! \brief examine tags \param f file number \param p position in tree \param a68g_link current frame pointer \param q tag \param sym symbol name **/ void examine_tags (FILE_T f, NODE_T * p, ADDR_T a68g_link, TAG_T * q, char *sym, int *printed) { for (; q != NO_TAG; FORWARD (q)) { if (NODE (q) != NO_NODE && strcmp (NSYMBOL (NODE (q)), sym) == 0) { intro_frame (f, p, a68g_link, printed); show_frame_item (f, p, a68g_link, q, PRIO (q)); } } } /*! \brief search symbol in stack \param f file number \param a68g_link current frame pointer \param sym symbol name **/ void examine_stack (FILE_T f, ADDR_T a68g_link, char *sym, int *printed) { if (a68g_link > 0) { int dynamic_a68g_link = FRAME_DYNAMIC_LINK (a68g_link); NODE_T *p = FRAME_TREE (a68g_link); if (p != NO_NODE) { TABLE_T *q = TABLE (p); examine_tags (f, p, a68g_link, IDENTIFIERS (q), sym, printed); examine_tags (f, p, a68g_link, OPERATORS (q), sym, printed); } examine_stack (f, dynamic_a68g_link, sym, printed); } } /*! \brief set or reset breakpoints \param p position in tree \param set mask indicating what to set \param is_set to check whether breakpoint is already set \param expr expression associated with breakpoint **/ void change_breakpoints (NODE_T * p, unsigned set, int num, BOOL_T * is_set, char *loc_expr) { for (; p != NO_NODE; FORWARD (p)) { change_breakpoints (SUB (p), set, num, is_set, loc_expr); if (set == BREAKPOINT_MASK) { if (LINE_NUMBER (p) == num && (STATUS_TEST (p, INTERRUPTIBLE_MASK)) && num != 0) { STATUS_SET (p, BREAKPOINT_MASK); if (EXPR (INFO (p)) != NO_TEXT) { free (EXPR (INFO (p))); } EXPR (INFO (p)) = loc_expr; *is_set = A68_TRUE; } } else if (set == BREAKPOINT_TEMPORARY_MASK) { if (LINE_NUMBER (p) == num && (STATUS_TEST (p, INTERRUPTIBLE_MASK)) && num != 0) { STATUS_SET (p, BREAKPOINT_TEMPORARY_MASK); if (EXPR (INFO (p)) != NO_TEXT) { free (EXPR (INFO (p))); } EXPR (INFO (p)) = loc_expr; *is_set = A68_TRUE; } } else if (set == NULL_MASK) { if (LINE_NUMBER (p) != num) { STATUS_CLEAR (p, (BREAKPOINT_MASK | BREAKPOINT_TEMPORARY_MASK)); if (EXPR (INFO (p)) == NO_TEXT) { free (EXPR (INFO (p))); } EXPR (INFO (p)) = NO_TEXT; } else if (num == 0) { STATUS_CLEAR (p, (BREAKPOINT_MASK | BREAKPOINT_TEMPORARY_MASK)); if (EXPR (INFO (p)) != NO_TEXT) { free (EXPR (INFO (p))); } EXPR (INFO (p)) = NO_TEXT; } } } } /*! \brief list breakpoints \param p position in tree \param listed counts listed items **/ static void list_breakpoints (NODE_T * p, int *listed) { for (; p != NO_NODE; FORWARD (p)) { list_breakpoints (SUB (p), listed); if (STATUS_TEST (p, BREAKPOINT_MASK)) { (*listed)++; WIS (p); if (EXPR (INFO (p)) != NO_TEXT) { WRITELN (STDOUT_FILENO, "breakpoint condition \""); WRITE (STDOUT_FILENO, EXPR (INFO (p))); WRITE (STDOUT_FILENO, "\""); } } } } /*! \brief execute monitor command \param p position in tree \param cmd command text \return whether execution continues **/ static BOOL_T single_stepper (NODE_T * p, char *cmd) { mon_errors = 0; errno = 0; if (strlen (cmd) == 0) { return (A68_FALSE); } while (IS_SPACE (cmd[strlen (cmd) - 1])) { cmd[strlen (cmd) - 1] = NULL_CHAR; } if (match_string (cmd, "CAlls", BLANK_CHAR)) { int k = get_num_arg (cmd, NO_VAR); int printed = 0; if (k > 0) { stack_trace (STDOUT_FILENO, frame_pointer, k, &printed); } else if (k == 0) { stack_trace (STDOUT_FILENO, frame_pointer, 3, &printed); } return (A68_FALSE); } else if (match_string (cmd, "Continue", NULL_CHAR) || match_string (cmd, "Resume", NULL_CHAR)) { do_confirm_exit = A68_TRUE; return (A68_TRUE); } else if (match_string (cmd, "DO", BLANK_CHAR) || match_string (cmd, "EXEC", BLANK_CHAR)) { char *sym = cmd; SKIP_ONE_SYMBOL (sym); if (sym[0] != NULL_CHAR) { ASSERT (snprintf (output_line, SNPRINTF_SIZE, "return code %d", system (sym)) >= 0); WRITELN (STDOUT_FILENO, output_line); } return (A68_FALSE); } else if (match_string (cmd, "ELems", BLANK_CHAR)) { int k = get_num_arg (cmd, NO_VAR); if (k > 0) { max_row_elems = k; } return (A68_FALSE); } else if (match_string (cmd, "Evaluate", BLANK_CHAR) || match_string (cmd, "X", BLANK_CHAR)) { char *sym = cmd; SKIP_ONE_SYMBOL (sym); if (sym[0] != NULL_CHAR) { ADDR_T old_sp = stack_pointer; evaluate (STDOUT_FILENO, p, sym); if (mon_errors == 0 && _m_sp > 0) { MOID_T *res; BOOL_T cont = A68_TRUE; while (cont) { res = _m_stack[0]; WRITELN (STDOUT_FILENO, "("); WRITE (STDOUT_FILENO, moid_to_string (res, MOID_WIDTH, NO_NODE)); WRITE (STDOUT_FILENO, ")"); show_item (STDOUT_FILENO, p, STACK_ADDRESS (old_sp), res); cont = (BOOL_T) (IS (res, REF_SYMBOL) && !IS_NIL (*(A68_REF *) STACK_ADDRESS (old_sp))); if (cont) { A68_REF z; POP_REF (p, &z); _m_stack[0] = SUB (_m_stack[0]); PUSH (p, ADDRESS (&z), MOID_SIZE (_m_stack[0])); } } } else { monitor_error (CANNOT_SHOW, NO_TEXT); } stack_pointer = old_sp; _m_sp = 0; } return (A68_FALSE); } else if (match_string (cmd, "EXamine", BLANK_CHAR)) { char *sym = cmd; SKIP_ONE_SYMBOL (sym); if (sym[0] != NULL_CHAR && (IS_LOWER (sym[0]) || IS_UPPER (sym[0]))) { int printed = 0; examine_stack (STDOUT_FILENO, frame_pointer, sym, &printed); if (printed == 0) { monitor_error ("tag not found", sym); } } else { monitor_error ("tag expected", NO_TEXT); } return (A68_FALSE); } else if (match_string (cmd, "EXIt", NULL_CHAR) || match_string (cmd, "HX", NULL_CHAR) || match_string (cmd, "Quit", NULL_CHAR) || strcmp (cmd, LOGOUT_STRING) == 0) { if (confirm_exit ()) { exit_genie (p, A68_RUNTIME_ERROR + A68_FORCE_QUIT); } return (A68_FALSE); } else if (match_string (cmd, "Frame", NULL_CHAR)) { if (current_frame == 0) { int printed = 0; stack_dump (STDOUT_FILENO, frame_pointer, 1, &printed); } else { stack_dump_current (STDOUT_FILENO, frame_pointer); } return (A68_FALSE); } else if (match_string (cmd, "Frame", BLANK_CHAR)) { int n = get_num_arg (cmd, NO_VAR); current_frame = (n > 0 ? n : 0); stack_dump_current (STDOUT_FILENO, frame_pointer); return (A68_FALSE); } else if (match_string (cmd, "HEAp", BLANK_CHAR)) { int top = get_num_arg (cmd, NO_VAR); if (top <= 0) { top = heap_size; } show_heap (STDOUT_FILENO, p, busy_handles, top, term_heigth - 4); return (A68_FALSE); } else if (match_string (cmd, "APropos", NULL_CHAR) || match_string (cmd, "Help", NULL_CHAR) || match_string (cmd, "INfo", NULL_CHAR)) { apropos (STDOUT_FILENO, NO_TEXT, "monitor"); return (A68_FALSE); } else if (match_string (cmd, "APropos", BLANK_CHAR) || match_string (cmd, "Help", BLANK_CHAR) || match_string (cmd, "INfo", BLANK_CHAR)) { char *sym = cmd; SKIP_ONE_SYMBOL (sym); apropos (STDOUT_FILENO, NO_TEXT, sym); return (A68_FALSE); } else if (match_string (cmd, "HT", NULL_CHAR)) { halt_typing = A68_TRUE; do_confirm_exit = A68_TRUE; return (A68_TRUE); } else if (match_string (cmd, "RT", NULL_CHAR)) { halt_typing = A68_FALSE; do_confirm_exit = A68_TRUE; return (A68_TRUE); } else if (match_string (cmd, "Breakpoint", BLANK_CHAR)) { char *sym = cmd; SKIP_ONE_SYMBOL (sym); if (sym[0] == NULL_CHAR) { int listed = 0; list_breakpoints (TOP_NODE (&program), &listed); if (listed == 0) { WRITELN (STDOUT_FILENO, "No breakpoints set"); } if (watchpoint_expression != NO_TEXT) { WRITELN (STDOUT_FILENO, "Watchpoint condition \""); WRITE (STDOUT_FILENO, watchpoint_expression); WRITE (STDOUT_FILENO, "\""); } else { WRITELN (STDOUT_FILENO, "No watchpoint expression set"); } } else if (IS_DIGIT (sym[0])) { char *mod; int k = get_num_arg (cmd, &mod); SKIP_SPACE (mod); if (mod[0] == NULL_CHAR) { BOOL_T set = A68_FALSE; change_breakpoints (TOP_NODE (&program), BREAKPOINT_MASK, k, &set, NULL); if (set == A68_FALSE) { monitor_error ("cannot set breakpoint in that line", NO_TEXT); } } else if (match_string (mod, "IF", BLANK_CHAR)) { char *cexpr = mod; BOOL_T set = A68_FALSE; SKIP_ONE_SYMBOL (cexpr); change_breakpoints (TOP_NODE (&program), BREAKPOINT_MASK, k, &set, new_string (cexpr, NO_TEXT)); if (set == A68_FALSE) { monitor_error ("cannot set breakpoint in that line", NO_TEXT); } } else if (match_string (mod, "Clear", NULL_CHAR)) { change_breakpoints (TOP_NODE (&program), NULL_MASK, k, NULL, NULL); } else { monitor_error ("invalid breakpoint command", NO_TEXT); } } else if (match_string (sym, "List", NULL_CHAR)) { int listed = 0; list_breakpoints (TOP_NODE (&program), &listed); if (listed == 0) { WRITELN (STDOUT_FILENO, "No breakpoints set"); } if (watchpoint_expression != NO_TEXT) { WRITELN (STDOUT_FILENO, "Watchpoint condition \""); WRITE (STDOUT_FILENO, watchpoint_expression); WRITE (STDOUT_FILENO, "\""); } else { WRITELN (STDOUT_FILENO, "No watchpoint expression set"); } } else if (match_string (sym, "Watch", BLANK_CHAR)) { char *cexpr = sym; SKIP_ONE_SYMBOL (cexpr); if (watchpoint_expression != NO_TEXT) { free (watchpoint_expression); watchpoint_expression = NO_TEXT; } watchpoint_expression = new_string (cexpr, NO_TEXT); change_masks (TOP_NODE (&program), BREAKPOINT_WATCH_MASK, A68_TRUE); } else if (match_string (sym, "Clear", BLANK_CHAR)) { char *mod = sym; SKIP_ONE_SYMBOL (mod); if (mod[0] == NULL_CHAR) { change_breakpoints (TOP_NODE (&program), NULL_MASK, 0, NULL, NULL); if (watchpoint_expression != NO_TEXT) { free (watchpoint_expression); watchpoint_expression = NO_TEXT; } change_masks (TOP_NODE (&program), BREAKPOINT_WATCH_MASK, A68_FALSE); } else if (match_string (mod, "ALL", NULL_CHAR)) { change_breakpoints (TOP_NODE (&program), NULL_MASK, 0, NULL, NULL); if (watchpoint_expression != NO_TEXT) { free (watchpoint_expression); watchpoint_expression = NO_TEXT; } change_masks (TOP_NODE (&program), BREAKPOINT_WATCH_MASK, A68_FALSE); } else if (match_string (mod, "Breakpoints", NULL_CHAR)) { change_breakpoints (TOP_NODE (&program), NULL_MASK, 0, NULL, NULL); } else if (match_string (mod, "Watchpoint", NULL_CHAR)) { if (watchpoint_expression != NO_TEXT) { free (watchpoint_expression); watchpoint_expression = NO_TEXT; } change_masks (TOP_NODE (&program), BREAKPOINT_WATCH_MASK, A68_FALSE); } else { monitor_error ("invalid breakpoint command", NO_TEXT); } } else { monitor_error ("invalid breakpoint command", NO_TEXT); } return (A68_FALSE); } else if (match_string (cmd, "List", BLANK_CHAR)) { char *cwhere; int n = get_num_arg (cmd, &cwhere); int m = get_num_arg (cwhere, NO_VAR); if (m == NOT_A_NUM) { if (n > 0) { list (STDOUT_FILENO, p, n, 0); } else if (n == NOT_A_NUM) { list (STDOUT_FILENO, p, 10, 0); } } else if (n > 0 && m > 0 && n <= m) { list (STDOUT_FILENO, p, n, m); } return (A68_FALSE); } else if (match_string (cmd, "PROmpt", BLANK_CHAR)) { char *sym = cmd; SKIP_ONE_SYMBOL (sym); if (sym[0] != NULL_CHAR) { if (sym[0] == QUOTE_CHAR) { sym++; } if (sym[strlen (sym) - 1] == QUOTE_CHAR) { sym[strlen (sym) - 1] = NULL_CHAR; } bufcpy (prompt, sym, BUFFER_SIZE); } return (A68_FALSE); } else if (match_string (cmd, "RERun", NULL_CHAR) || match_string (cmd, "REStart", NULL_CHAR)) { if (confirm_exit ()) { exit_genie (p, A68_RERUN); } return (A68_FALSE); } else if (match_string (cmd, "RESET", NULL_CHAR)) { if (confirm_exit ()) { change_breakpoints (TOP_NODE (&program), NULL_MASK, 0, NULL, NULL); if (watchpoint_expression != NO_TEXT) { free (watchpoint_expression); watchpoint_expression = NO_TEXT; } change_masks (TOP_NODE (&program), BREAKPOINT_WATCH_MASK, A68_FALSE); exit_genie (p, A68_RERUN); } return (A68_FALSE); } else if (match_string (cmd, "LINk", BLANK_CHAR)) { int k = get_num_arg (cmd, NO_VAR); int printed = 0; if (k > 0) { stack_a68g_link_dump (STDOUT_FILENO, frame_pointer, k, &printed); } else if (k == NOT_A_NUM) { stack_a68g_link_dump (STDOUT_FILENO, frame_pointer, 3, &printed); } return (A68_FALSE); } else if (match_string (cmd, "STAck", BLANK_CHAR) || match_string (cmd, "BT", BLANK_CHAR)) { int k = get_num_arg (cmd, NO_VAR); int printed = 0; if (k > 0) { stack_dump (STDOUT_FILENO, frame_pointer, k, &printed); } else if (k == NOT_A_NUM) { stack_dump (STDOUT_FILENO, frame_pointer, 3, &printed); } return (A68_FALSE); } else if (match_string (cmd, "Next", NULL_CHAR)) { change_masks (TOP_NODE (&program), BREAKPOINT_TEMPORARY_MASK, A68_TRUE); do_confirm_exit = A68_FALSE; break_proc_level = PROCEDURE_LEVEL (INFO (p)); return (A68_TRUE); } else if (match_string (cmd, "STEp", NULL_CHAR)) { change_masks (TOP_NODE (&program), BREAKPOINT_TEMPORARY_MASK, A68_TRUE); do_confirm_exit = A68_FALSE; return (A68_TRUE); } else if (match_string (cmd, "FINish", NULL_CHAR) || match_string (cmd, "OUT", NULL_CHAR)) { finish_frame_pointer = FRAME_PARAMETERS (frame_pointer); do_confirm_exit = A68_FALSE; return (A68_TRUE); } else if (match_string (cmd, "Until", BLANK_CHAR)) { int k = get_num_arg (cmd, NO_VAR); if (k > 0) { BOOL_T set = A68_FALSE; change_breakpoints (TOP_NODE (&program), BREAKPOINT_TEMPORARY_MASK, k, &set, NULL); if (set == A68_FALSE) { monitor_error ("cannot set breakpoint in that line", NO_TEXT); return (A68_FALSE); } do_confirm_exit = A68_FALSE; return (A68_TRUE); } else { monitor_error ("line number expected", NO_TEXT); return (A68_FALSE); } } else if (match_string (cmd, "Where", NULL_CHAR)) { WIS (p); return (A68_FALSE); } else if (strcmp (cmd, "?") == 0) { apropos (STDOUT_FILENO, prompt, "monitor"); return (A68_FALSE); } else if (match_string (cmd, "Sizes", NULL_CHAR)) { ASSERT (snprintf (output_line, SNPRINTF_SIZE, "Frame stack pointer=%d available=%d", frame_pointer, frame_stack_size - frame_pointer) >= 0); WRITELN (STDOUT_FILENO, output_line); ASSERT (snprintf (output_line, SNPRINTF_SIZE, "Expression stack pointer=%d available=%d", stack_pointer, expr_stack_size - stack_pointer) >= 0); WRITELN (STDOUT_FILENO, output_line); ASSERT (snprintf (output_line, SNPRINTF_SIZE, "Heap size=%d available=%d", heap_size, heap_available ()) >= 0); WRITELN (STDOUT_FILENO, output_line); ASSERT (snprintf (output_line, SNPRINTF_SIZE, "Garbage collections=%d", garbage_collects) >= 0); WRITELN (STDOUT_FILENO, output_line); return (A68_FALSE); } else if (match_string (cmd, "XRef", NULL_CHAR)) { int k = LINE_NUMBER (p); LINE_T *line = TOP_LINE (&program); for (; line != NO_LINE; FORWARD (line)) { if (NUMBER (line) > 0 && NUMBER (line) == k) { list_source_line (STDOUT_FILENO, line, A68_TRUE); } } return (A68_FALSE); } else if (match_string (cmd, "XRef", BLANK_CHAR)) { LINE_T *line = TOP_LINE (&program); int k = get_num_arg (cmd, NO_VAR); if (k == NOT_A_NUM) { monitor_error ("line number expected", NO_TEXT); } else { for (; line != NO_LINE; FORWARD (line)) { if (NUMBER (line) > 0 && NUMBER (line) == k) { list_source_line (STDOUT_FILENO, line, A68_TRUE); } } } return (A68_FALSE); } else if (strlen (cmd) == 0) { return (A68_FALSE); } else { monitor_error ("unrecognised command", NO_TEXT); return (A68_FALSE); } } /*! \brief evaluate conditional breakpoint expression \param p position in tree \return whether expression evaluates to TRUE **/ static BOOL_T evaluate_breakpoint_expression (NODE_T * p) { ADDR_T top_sp = stack_pointer; volatile BOOL_T res = A68_FALSE; mon_errors = 0; if (EXPR (INFO (p)) != NO_TEXT) { evaluate (STDOUT_FILENO, p, EXPR (INFO (p))); if (_m_sp != 1 || mon_errors != 0) { mon_errors = 0; monitor_error ("deleted invalid breakpoint expression", NO_TEXT); if (EXPR (INFO (p)) != NO_TEXT) { free (EXPR (INFO (p))); } EXPR (INFO (p)) = expr; res = A68_TRUE; } else if (TOP_MODE == MODE (BOOL)) { A68_BOOL z; POP_OBJECT (p, &z, A68_BOOL); res = (BOOL_T) (STATUS (&z) == INIT_MASK && VALUE (&z) == A68_TRUE); } else { monitor_error ("deleted invalid breakpoint expression yielding mode", moid_to_string (TOP_MODE, MOID_WIDTH, NO_NODE)); if (EXPR (INFO (p)) != NO_TEXT) { free (EXPR (INFO (p))); } EXPR (INFO (p)) = expr; res = A68_TRUE; } } stack_pointer = top_sp; return (res); } /*! \brief evaluate conditional watchpoint expression \return whether expression evaluates to TRUE **/ static BOOL_T evaluate_watchpoint_expression (NODE_T * p) { ADDR_T top_sp = stack_pointer; volatile BOOL_T res = A68_FALSE; mon_errors = 0; if (watchpoint_expression != NO_TEXT) { evaluate (STDOUT_FILENO, p, watchpoint_expression); if (_m_sp != 1 || mon_errors != 0) { mon_errors = 0; monitor_error ("deleted invalid watchpoint expression", NO_TEXT); if (watchpoint_expression != NO_TEXT) { free (watchpoint_expression); watchpoint_expression = NO_TEXT; } res = A68_TRUE; } if (TOP_MODE == MODE (BOOL)) { A68_BOOL z; POP_OBJECT (p, &z, A68_BOOL); res = (BOOL_T) (STATUS (&z) == INIT_MASK && VALUE (&z) == A68_TRUE); } else { monitor_error ("deleted invalid watchpoint expression yielding mode", moid_to_string (TOP_MODE, MOID_WIDTH, NO_NODE)); if (watchpoint_expression != NO_TEXT) { free (watchpoint_expression); watchpoint_expression = NO_TEXT; } res = A68_TRUE; } } stack_pointer = top_sp; return (res); } /*! \brief execute monitor \param p position in tree **/ void single_step (NODE_T * p, unsigned mask) { volatile BOOL_T do_cmd = A68_TRUE; ADDR_T top_sp = stack_pointer; if (LINE_NUMBER (p) == 0) { return; } #if defined HAVE_CURSES genie_curses_end (NO_NODE); #endif if (mask == (unsigned) BREAKPOINT_ERROR_MASK) { WRITELN (STDOUT_FILENO, "Monitor entered after an error"); WIS ((p)); } else if ((mask & BREAKPOINT_INTERRUPT_MASK) != 0) { WRITELN (STDOUT_FILENO, NEWLINE_STRING); WIS ((p)); if (do_confirm_exit && confirm_exit ()) { exit_genie ((p), A68_RUNTIME_ERROR + A68_FORCE_QUIT); } } else if ((mask & BREAKPOINT_MASK) != 0) { if (EXPR (INFO (p)) != NO_TEXT) { if (!evaluate_breakpoint_expression (p)) { return; } ASSERT (snprintf (output_line, SNPRINTF_SIZE, "Breakpoint (%s)", EXPR (INFO (p))) >= 0); } else { ASSERT (snprintf (output_line, SNPRINTF_SIZE, "Breakpoint") >= 0); } WRITELN (STDOUT_FILENO, output_line); WIS (p); } else if ((mask & BREAKPOINT_TEMPORARY_MASK) != 0) { if (break_proc_level != 0 && PROCEDURE_LEVEL (INFO (p)) > break_proc_level) { return; } change_masks (TOP_NODE (&program), BREAKPOINT_TEMPORARY_MASK, A68_FALSE); WRITELN (STDOUT_FILENO, "Temporary breakpoint (now removed)"); WIS (p); } else if ((mask & BREAKPOINT_WATCH_MASK) != 0) { if (!evaluate_watchpoint_expression (p)) { return; } if (watchpoint_expression != NO_TEXT) { ASSERT (snprintf (output_line, SNPRINTF_SIZE, "Watchpoint (%s)", watchpoint_expression) >= 0); } else { ASSERT (snprintf (output_line, SNPRINTF_SIZE, "Watchpoint (now removed)") >= 0); } WRITELN (STDOUT_FILENO, output_line); WIS (p); } else if ((mask & BREAKPOINT_TRACE_MASK) != 0) { PROP_T *prop = &GPROP (p); WIS ((p)); if (propagator_name (UNIT (prop)) != NO_TEXT) { WRITELN (STDOUT_FILENO, propagator_name (UNIT (prop))); } return; } else { WRITELN (STDOUT_FILENO, "Monitor entered with no valid reason (continuing execution)"); WIS ((p)); return; } #if defined HAVE_PARALLEL_CLAUSE if (is_main_thread ()) { WRITELN (STDOUT_FILENO, "This is the main thread"); } else { WRITELN (STDOUT_FILENO, "This is not the main thread"); } #endif /* Entry into the monitor */ if (prompt_set == A68_FALSE) { bufcpy (prompt, "(a68g) ", BUFFER_SIZE); prompt_set = A68_TRUE; } in_monitor = A68_TRUE; break_proc_level = 0; change_masks (TOP_NODE (&program), BREAKPOINT_INTERRUPT_MASK, A68_FALSE); STATUS_CLEAR (TOP_NODE (&program), BREAKPOINT_INTERRUPT_MASK); while (do_cmd) { char *cmd; stack_pointer = top_sp; io_close_tty_line (); while (strlen (cmd = read_string_from_tty (prompt)) == 0) {; } if (TO_UCHAR (cmd[0]) == TO_UCHAR (EOF_CHAR)) { bufcpy (cmd, LOGOUT_STRING, BUFFER_SIZE); WRITE (STDOUT_FILENO, LOGOUT_STRING); WRITE (STDOUT_FILENO, NEWLINE_STRING); } _m_sp = 0; do_cmd = (BOOL_T) (!single_stepper (p, cmd)); } stack_pointer = top_sp; in_monitor = A68_FALSE; if (mask == (unsigned) BREAKPOINT_ERROR_MASK) { WRITELN (STDOUT_FILENO, "Continuing from an error might corrupt things"); single_step (p, (unsigned) BREAKPOINT_ERROR_MASK); } else { WRITELN (STDOUT_FILENO, "Continuing ..."); WRITELN (STDOUT_FILENO, ""); } } /*! \brief PROC debug = VOID \param p position in tree **/ void genie_debug (NODE_T * p) { single_step (p, BREAKPOINT_INTERRUPT_MASK); } /*! \brief PROC break = VOID \param p position in tree **/ void genie_break (NODE_T * p) { (void) p; change_masks (TOP_NODE (&program), BREAKPOINT_INTERRUPT_MASK, A68_TRUE); } /*! \brief PROC evaluate = (STRING) STRING \param p position in tree */ void genie_evaluate (NODE_T * p) { A68_REF u, v; volatile ADDR_T top_sp; v = empty_string (p); /* Pop argument */ POP_REF (p, (A68_REF *) & u); top_sp = stack_pointer; CHECK_MON_REF (p, u, MODE (STRING)); reset_transput_buffer (UNFORMATTED_BUFFER); add_a_string_transput_buffer (p, UNFORMATTED_BUFFER, (BYTE_T *) & u); v = c_to_a_string (p, get_transput_buffer (UNFORMATTED_BUFFER), DEFAULT_WIDTH); /* Evaluate in the monitor */ in_monitor = A68_TRUE; mon_errors = 0; evaluate (STDOUT_FILENO, p, get_transput_buffer (UNFORMATTED_BUFFER)); in_monitor = A68_FALSE; if (_m_sp != 1) { monitor_error ("invalid expression", NO_TEXT); } if (mon_errors == 0) { MOID_T *res; BOOL_T cont = A68_TRUE; while (cont) { res = TOP_MODE; cont = (BOOL_T) (IS (res, REF_SYMBOL) && !IS_NIL (*(A68_REF *) STACK_ADDRESS (top_sp))); if (cont) { A68_REF w; POP_REF (p, &w); TOP_MODE = SUB (TOP_MODE); PUSH (p, ADDRESS (&w), MOID_SIZE (TOP_MODE)); } } reset_transput_buffer (UNFORMATTED_BUFFER); genie_write_standard (p, TOP_MODE, STACK_ADDRESS (top_sp), nil_ref); v = c_to_a_string (p, get_transput_buffer (UNFORMATTED_BUFFER), DEFAULT_WIDTH); } stack_pointer = top_sp; PUSH_REF (p, v); } algol68g-2.4.1/source/a68g-config.win32.h0000644000175000001440000000366711770216222014514 00000000000000#define HAVE_WIN32 #if defined HAVE_WIN32 #define HAVE_ASSERT_H #define HAVE_CONIO_H #define HAVE_CTYPE_H #define HAVE_CURSES_H #define HAVE_DIRENT_H #define HAVE_FCNTL_H #define HAVE_FLOAT_H #define HAVE_HTTP #define HAVE_LIBGSL #define HAVE_LIBNCURSES #define HAVE_LIBPLOT #define HAVE_LIMITS_H #define HAVE_MATH_H #define HAVE_PLOT_H #define HAVE_REGEX_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 #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_PLOT_H #define HAVE_GNU_GSL #define HAVE_GNU_PLOTUTILS #undef HAVE_COMPILER #undef HAVE_DLFCN_H #undef HAVE_LIBPQ_FE_H #undef HAVE_PARALLEL_CLAUSE #undef HAVE_PTHREAD_H #undef HAVE_TERM_H typedef unsigned __off_t; extern int finite (double); #define S_IRGRP (0x040) #define S_IROTH (0x004) #if (defined __MSVCRT__ && defined _environ) #undef _environ #endif #endif /* defined HAVE_WIN32 */ /* Name of package */ #define PACKAGE "algol68g" /* Define to the address where bug reports for this package should be sent. */ #define PACKAGE_BUGREPORT "Marcel van der Veer " /* Define to the full name of this package. */ #define PACKAGE_NAME "algol68g" /* Define to the full name and version of this package. */ #define PACKAGE_STRING "algol68g 2.4.1" /* Define to the one symbol short name of this package. */ #define PACKAGE_TARNAME "algol68g" /* Define to the version of this package. */ #define PACKAGE_VERSION "2.4.1" /* Version number of package */ #define VERSION "2.4.1" algol68g-2.4.1/source/pretty.c0000644000175000001440000010447011767464642013100 00000000000000/*! \file pretty.c \brief Pretty-printer for Algol 68 programs */ /* This file is part of Algol68G - an Algol 68 interpreter. Copyright (C) 2001-2012 J. Marcel van der Veer . 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" #define ONE_LINER (A68_TRUE) #define KEYWORD (A68_TRUE) #define BLANK {put_str (" ");} #define IS_OPEN_SYMBOL(p) (IS (p, OPEN_SYMBOL) || IS (p, SUB_SYMBOL) || IS (p, ACCO_SYMBOL)) #define IS_CLOSE_SYMBOL(p) (IS (p, CLOSE_SYMBOL) || IS (p, BUS_SYMBOL) || IS (p, OCCA_SYMBOL)) #define IS_IDENTIFIER(p) (IS (p, IDENTIFIER) || IS (p, DEFINING_IDENTIFIER) || IS (p, FIELD_IDENTIFIER)) static char in_line[BUFFER_SIZE]; static FILE_T fd; static int ind, col; static int indentation = 0; static BOOL_T use_folder; static void in_declarer (NODE_T *); static void in_serial (NODE_T *, BOOL_T, NODE_T **); static void in_statement (NODE_T *); static void in_format (NODE_T *); /*! \brief write newline and indent **/ static void put_nl (void) { WRITE (fd, "\n"); for (col = 1; col < ind % 72; col ++) { WRITE (fd, " "); } } /*! \brief write a string \param txt **/ static void put_str (char *txt) { WRITE (fd, txt); col += (int) strlen (txt); } /*! \brief write a character \param ch **/ static void put_ch (char ch) { char str[2]; str[0] = ch; str[1] = NULL_CHAR; put_str (str); } /*! \brief write pragment string \param p position in tree **/ static void put_pragment (NODE_T *p) { char *txt = NPRAGMENT (p); for (; txt != NO_TEXT && txt[0] != NULL_CHAR; txt++) { if (txt[0] == NEWLINE_CHAR) { put_nl (); } else { put_ch (txt[0]); } } } /*! \brief write pragment string \param p position in tree **/ static void pragment (NODE_T *p, BOOL_T keyw) { if (NPRAGMENT (p) != NO_TEXT) { if (NPRAGMENT_TYPE (p) == BOLD_COMMENT_SYMBOL || NPRAGMENT_TYPE (p) == BOLD_PRAGMAT_SYMBOL) { if (! keyw) { put_nl (); } put_pragment (p); put_nl (); put_nl (); } else { if (! keyw && (int) strlen (NPRAGMENT (p)) < 20) { if (col > ind) { BLANK; } put_pragment (p); BLANK; } else { if (col > ind) { put_nl (); } put_pragment (p); put_nl (); } } }} /*! \brief write with typographic display features \param p position in tree \param keyw **/ static void put_sym (NODE_T *p, BOOL_T keyw) { char *txt = NSYMBOL (p); char *sym = NCHAR_IN_LINE (p); int n = 0, size = (int) strlen (txt); pragment (p, keyw); if (txt[0] != sym[0] || (int) strlen (sym) - 1 <= size) { /* Without features. */ put_str (txt); } else { /* With features. Preserves spaces in identifiers etcetera. */ while (n < size) { put_ch (sym[0]); if (TO_LOWER (txt[0]) == TO_LOWER (sym[0])) { txt ++; n ++; } sym ++; } } } /*! \brief count units and separators in a sub-tree \param p position in tree \param units \param seps **/ static void count (NODE_T *p, int *units, int *seps) { for (; p != NO_NODE; FORWARD (p)) { if (IS (p, UNIT)) { (*units) ++; count (SUB (p), units, seps); } else if (IS (p, SEMI_SYMBOL)) { (*seps) ++; } else if (IS (p, COMMA_SYMBOL)) { (*seps) ++; } else { count (SUB (p), units, seps); } } } /*! \brief count units and separators in a sub-tree \param p position in tree \param units \param seps **/ static void count_stowed (NODE_T *p, int *units, int *seps) { for (; p != NO_NODE; FORWARD (p)) { if (IS (p, UNIT)) { MOID_T *v = MOID (p); BOOL_T stowed = (BOOL_T) (IS (v, FLEX_SYMBOL) || IS (v, ROW_SYMBOL) || IS (v, STRUCT_SYMBOL)); if (stowed) { (*units) ++; } } else if (IS (p, SEMI_SYMBOL)) { (*seps) ++; } else if (IS (p, COMMA_SYMBOL)) { (*seps) ++; } else { count_stowed (SUB (p), units, seps); } } } /*! \brief count enclosed_clauses in a sub-tree \param p position in tree \param enclos \param seps **/ static void count_enclos (NODE_T *p, int *enclos, int *seps) { for (; p != NO_NODE; FORWARD (p)) { if (IS (p, ENCLOSED_CLAUSE)) { (*enclos) ++; } else if (IS (p, SEMI_SYMBOL)) { (*seps) ++; } else if (IS (p, COMMA_SYMBOL)) { (*seps) ++; } else { count_enclos (SUB (p), enclos, seps); } } } /*! \brief indent sizety \param p position in tree **/ static void in_sizety (NODE_T * p) { for (; p != NO_NODE; FORWARD (p)) { if (IS (p, LONGETY) || IS (p, SHORTETY)) { in_sizety (SUB (p)); } else if (IS (p, LONG_SYMBOL) || IS (p, SHORT_SYMBOL)) { put_sym (p, !KEYWORD); BLANK; } } } /*! \brief indent generic list \param p position in tree **/ static void in_generic_list (NODE_T * p, NODE_T ** what, BOOL_T one_liner) { for (; p != NULL; FORWARD (p)) { if (IS_OPEN_SYMBOL (p)) { put_sym (p, KEYWORD); ind = col; } else if (IS_CLOSE_SYMBOL (p)) { put_sym (p, KEYWORD); } else if (IS (p, BEGIN_SYMBOL)) { put_sym (p, KEYWORD); BLANK; } else if (IS (p, END_SYMBOL)) { BLANK; put_sym (p, KEYWORD); } else if (IS (p, AT_SYMBOL)) { if (NSYMBOL (p)[0] == '@') { put_sym (p, !KEYWORD); } else { BLANK; put_sym (p, !KEYWORD); BLANK; } } else if (IS (p, COLON_SYMBOL)) { BLANK; put_sym (p, !KEYWORD); BLANK; } else if (IS (p, DOTDOT_SYMBOL)) { BLANK; put_sym (p, !KEYWORD); BLANK; } else if (IS (p, UNIT)) { *what = p; in_statement (SUB (p)); } else if (IS (p, SPECIFIER)) { NODE_T *q = SUB (p); put_sym (q, KEYWORD); FORWARD (q); in_declarer (q); FORWARD (q); if (IS_IDENTIFIER (q)) { BLANK; put_sym (q, !KEYWORD); FORWARD (q); } put_sym (q, !KEYWORD); FORWARD (q); put_sym (NEXT (p), !KEYWORD); /* : */ BLANK; FORWARD (p); } else if (IS (p, COMMA_SYMBOL)) { put_sym (p, !KEYWORD); if (one_liner) { BLANK; } else { put_nl (); } } else { in_generic_list (SUB (p), what, one_liner); } } } /*! \brief indent declarer pack \param p position in tree **/ static void in_pack (NODE_T *p) { for (; p != NO_NODE; FORWARD (p)) { if (IS_OPEN_SYMBOL (p) || IS_CLOSE_SYMBOL (p)) { put_sym (p, KEYWORD); } else if (IS (p, COMMA_SYMBOL)) { put_sym (p, !KEYWORD); BLANK; } else if (IS (p, VOID_SYMBOL)) { put_sym (p, !KEYWORD); } else if (IS (p, DECLARER)) { in_declarer (p); if (NEXT (p) != NO_NODE && IS_IDENTIFIER (NEXT (p))) { BLANK; } } else if (IS_IDENTIFIER (p)) { put_sym (p, !KEYWORD); } else { in_pack (SUB (p)); } } } /*! \brief indent declarer \param p position in tree **/ static void in_declarer (NODE_T *p) { if (IS (p, DECLARER)) { in_declarer (SUB (p)); } else if (IS (p, LONGETY) || IS (p, SHORTETY)) { in_sizety (SUB (p)); in_declarer (NEXT (p)); } else if (IS (p, VOID_SYMBOL)) { put_sym (p, !KEYWORD); } else if (IS (p, REF_SYMBOL)) { put_sym (p, !KEYWORD); BLANK; in_declarer (NEXT (p)); } else if (IS (p, FLEX_SYMBOL)) { put_sym (p, !KEYWORD); BLANK; in_declarer (NEXT (p)); } else if (IS (p, BOUNDS) || IS (p, FORMAL_BOUNDS)) { NODE_T *what = NO_NODE; int pop_ind = ind; in_generic_list (SUB (p), &what, ONE_LINER); ind = pop_ind; BLANK; in_declarer (NEXT (p)); } else if (IS (p, STRUCT_SYMBOL) || IS (p, UNION_SYMBOL)) { NODE_T *pack = NEXT (p); put_sym (p, !KEYWORD); BLANK; in_pack (pack); } else if (IS (p, PROC_SYMBOL)) { NODE_T *q = NEXT (p); put_sym (p, KEYWORD); BLANK; if (IS (q, FORMAL_DECLARERS)) { in_pack (SUB (q)); BLANK; FORWARD (q); } in_declarer (q); return; } else if (IS (p, OP_SYMBOL)) { /* Operator plan */ NODE_T *q = NEXT (p); put_sym (p, KEYWORD); BLANK; if (IS (q, FORMAL_DECLARERS)) { in_pack (SUB (q)); BLANK; FORWARD (q); } in_declarer (q); return; } else if (IS (p, INDICANT)) { put_sym (p, !KEYWORD); } } /*! \brief indent conditional \param p position in tree **/ static void in_conditional (NODE_T *p) { for (; p != NO_NODE; FORWARD (p)) { if (IS (p, IF_PART) || IS (p, ELIF_IF_PART)) { NODE_T *what = NO_NODE; int pop_ind = ind; put_sym (SUB (p), KEYWORD); BLANK; ind = col; in_serial (NEXT_SUB (p), !ONE_LINER, &what); ind = pop_ind; put_nl (); } else if (IS (p, THEN_PART)) { NODE_T *what = NO_NODE; int pop_ind = ind; put_sym (SUB (p), KEYWORD); BLANK; ind = col; in_serial (NEXT_SUB (p), !ONE_LINER, &what); ind = pop_ind; put_nl (); } else if (IS (p, ELSE_PART)) { NODE_T *what = NO_NODE; int pop_ind = ind; put_sym (SUB (p), KEYWORD); BLANK; ind = col; in_serial (NEXT_SUB (p), !ONE_LINER, &what); ind = pop_ind; put_nl (); } else if (IS (p, ELIF_PART)) { in_conditional (SUB (p)); } else if (IS (p, FI_SYMBOL)) { put_sym (p, KEYWORD); } else if (IS (p, OPEN_PART)) { NODE_T *what = NO_NODE; put_sym (SUB (p), KEYWORD); in_serial (NEXT_SUB (p), ONE_LINER, &what); } else if (IS (p, ELSE_OPEN_PART)) { NODE_T *what = NO_NODE; BLANK; put_sym (SUB (p), KEYWORD); BLANK; in_serial (NEXT_SUB (p), ONE_LINER, &what); } else if (IS (p, CHOICE)) { NODE_T *what = NO_NODE; BLANK; put_sym (SUB (p), KEYWORD); BLANK; in_serial (NEXT_SUB (p), ONE_LINER, &what); } else if (IS (p, BRIEF_ELIF_PART)) { in_conditional (SUB (p)); } else if (IS_CLOSE_SYMBOL (p)) { put_sym (p, KEYWORD); } } } /*! \brief indent integer case clause \param p position in tree **/ static void in_case (NODE_T *p) { for (; p != NO_NODE; FORWARD (p)) { if (IS (p, CASE_PART) || IS (p, OUSE_PART)) { NODE_T *what = NO_NODE; int pop_ind = ind; put_sym (SUB (p), KEYWORD); BLANK; ind = col; in_serial (NEXT_SUB (p), !ONE_LINER, &what); ind = pop_ind; put_nl (); } else if (IS (p, CASE_IN_PART)) { NODE_T *what = NO_NODE; int pop_ind = ind; put_sym (SUB (p), KEYWORD); BLANK; ind = col; in_generic_list (NEXT_SUB (p), &what, ONE_LINER); ind = pop_ind; put_nl (); } else if (IS (p, OUT_PART)) { NODE_T *what = NO_NODE; int pop_ind = ind; put_sym (SUB (p), KEYWORD); BLANK; ind = col; in_serial (NEXT_SUB (p), !ONE_LINER, &what); ind = pop_ind; put_nl (); } else if (IS (p, CASE_OUSE_PART)) { in_case (SUB (p)); } else if (IS (p, ESAC_SYMBOL)) { put_sym (p, KEYWORD); } else if (IS (p, OPEN_PART)) { NODE_T *what = NO_NODE; put_sym (SUB (p), KEYWORD); in_serial (NEXT_SUB (p), ONE_LINER, &what); } else if (IS (p, ELSE_OPEN_PART)) { NODE_T *what = NO_NODE; BLANK; put_sym (SUB (p), KEYWORD); BLANK; in_serial (NEXT_SUB (p), ONE_LINER, &what); } else if (IS (p, CASE_CHOICE_CLAUSE)) { NODE_T *what = NO_NODE; BLANK; put_sym (SUB (p), KEYWORD); BLANK; in_generic_list (NEXT_SUB (p), &what, ONE_LINER); } else if (IS (p, CHOICE)) { NODE_T *what = NO_NODE; BLANK; put_sym (SUB (p), KEYWORD); BLANK; in_serial (NEXT_SUB (p), ONE_LINER, &what); } else if (IS (p, BRIEF_OUSE_PART)) { in_case (SUB (p)); } else if (IS_CLOSE_SYMBOL (p)) { put_sym (p, KEYWORD); } } } /*! \brief indent conformity clause \param p position in tree **/ static void in_conformity (NODE_T *p) { for (; p != NO_NODE; FORWARD (p)) { if (IS (p, CASE_PART) || IS (p, OUSE_PART)) { NODE_T *what = NO_NODE; int pop_ind = ind; put_sym (SUB (p), KEYWORD); BLANK; ind = col; in_serial (NEXT_SUB (p), !ONE_LINER, &what); ind = pop_ind; put_nl (); } else if (IS (p, CONFORMITY_IN_PART)) { NODE_T *what = NO_NODE; int pop_ind = ind; put_sym (SUB (p), KEYWORD); BLANK; ind = col; in_generic_list (NEXT_SUB (p), &what, ONE_LINER); ind = pop_ind; put_nl (); } else if (IS (p, OUT_PART)) { NODE_T *what = NO_NODE; int pop_ind = ind; put_sym (SUB (p), KEYWORD); BLANK; ind = col; in_serial (NEXT_SUB (p), !ONE_LINER, &what); ind = pop_ind; put_nl (); } else if (IS (p, CONFORMITY_OUSE_PART)) { in_conformity (SUB (p)); } else if (IS (p, ESAC_SYMBOL)) { put_sym (p, KEYWORD); } else if (IS (p, OPEN_PART)) { NODE_T *what = NO_NODE; put_sym (SUB (p), KEYWORD); in_serial (NEXT_SUB (p), ONE_LINER, &what); } else if (IS (p, ELSE_OPEN_PART)) { NODE_T *what = NO_NODE; BLANK; put_sym (SUB (p), KEYWORD); BLANK; in_serial (NEXT_SUB (p), ONE_LINER, &what); } else if (IS (p, CONFORMITY_CHOICE)) { NODE_T *what = NO_NODE; BLANK; put_sym (SUB (p), KEYWORD); BLANK; in_generic_list (NEXT_SUB (p), &what, ONE_LINER); } else if (IS (p, CHOICE)) { NODE_T *what = NO_NODE; BLANK; put_sym (SUB (p), KEYWORD); BLANK; in_serial (NEXT_SUB (p), ONE_LINER, &what); } else if (IS (p, BRIEF_CONFORMITY_OUSE_PART)) { in_conformity (SUB (p)); } else if (IS_CLOSE_SYMBOL (p)) { put_sym (p, KEYWORD); } } } /*! \brief indent loop \param p position in tree **/ static void in_loop (NODE_T * p) { int parts = 0, pop_ind = col; for (; p != NO_NODE; FORWARD (p)) { if (IS (p, FOR_PART)) { put_sym (SUB (p), KEYWORD); BLANK; put_sym (NEXT_SUB (p), !KEYWORD); BLANK; parts ++; } else if (is_one_of (p, FROM_PART, BY_PART, TO_PART, STOP)) { put_sym (SUB (p), KEYWORD); BLANK; in_statement (NEXT_SUB (p)); BLANK; parts ++; } else if (IS (p, WHILE_PART)) { NODE_T *what = NO_NODE; ind = pop_ind; if (parts > 0) { put_nl (); } put_sym (SUB (p), KEYWORD); BLANK; ind = col; in_serial (NEXT_SUB (p), !ONE_LINER, &what); ind = pop_ind; parts ++; } else if (is_one_of (p, DO_PART, ALT_DO_PART, STOP)) { NODE_T *q = SUB (p); NODE_T *what = NO_NODE; ind = pop_ind; if (parts > 0) { put_nl (); } put_sym (q, KEYWORD); /* DO */ BLANK; ind = col; FORWARD (q); parts = 0; if (IS (q, SERIAL_CLAUSE)) { in_serial (SUB (q), !ONE_LINER, &what); FORWARD (q); parts ++; } if (IS (q, UNTIL_PART)) { int pop_ind2 = ind; if (parts > 0) { put_nl (); } put_sym (SUB (q), KEYWORD); BLANK; ind = col; in_serial (NEXT_SUB (q), !ONE_LINER, &what); ind = pop_ind2; FORWARD (q); } ind = pop_ind; put_nl (); put_sym (q, KEYWORD); /* OD */ parts ++; } } } /*! \brief indent closed clause \param p position in tree **/ static void in_closed (NODE_T *p) { int units = 0, seps = 0; count (SUB_NEXT (p), &units, &seps); if (units == 1 && seps == 0) { put_sym (p, KEYWORD); if (IS (p, BEGIN_SYMBOL)) { NODE_T *what = NO_NODE; BLANK; in_serial (SUB_NEXT (p), ONE_LINER, &what); BLANK; } else { NODE_T *what = NO_NODE; in_serial (SUB_NEXT (p), ONE_LINER, &what); } put_sym (NEXT_NEXT (p), KEYWORD); } else if (units <= 3 && seps == (units - 1) && IS_OPEN_SYMBOL (p)) { NODE_T *what = NO_NODE; put_sym (p, KEYWORD); in_serial (SUB_NEXT (p), ONE_LINER, &what); put_sym (NEXT_NEXT (p), KEYWORD); } else { NODE_T *what = NO_NODE; int pop_ind = ind; put_sym (p, KEYWORD); if (IS (p, BEGIN_SYMBOL)) { BLANK; } ind = col; in_serial (SUB_NEXT (p), !ONE_LINER, &what); ind = pop_ind; if (IS (NEXT_NEXT (p), END_SYMBOL)) { put_nl (); } put_sym (NEXT_NEXT (p), KEYWORD); } } /*! \brief indent collateral clause \param p position in tree **/ static void in_collateral (NODE_T *p) { int units = 0, seps = 0; NODE_T *what = NO_NODE; int pop_ind = ind; count_stowed (p, &units, &seps); if (units <= 3) { in_generic_list (p, &what, ONE_LINER); } else { in_generic_list (p, &what, !ONE_LINER); } ind = pop_ind; } /*! \brief indent enclosed clause \param p position in tree **/ static void in_enclosed (NODE_T *p) { if (IS (p, ENCLOSED_CLAUSE)) { in_enclosed (SUB (p)); } else if (IS (p, CLOSED_CLAUSE)) { in_closed (SUB (p)); } else if (IS (p, COLLATERAL_CLAUSE)) { in_collateral (SUB (p)); } else if (IS (p, PARALLEL_CLAUSE)) { put_sym (SUB (p), KEYWORD); in_enclosed (NEXT_SUB (p)); } else if (IS (p, CONDITIONAL_CLAUSE)) { in_conditional (SUB (p)); } else if (IS (p, CASE_CLAUSE)) { in_case (SUB (p)); } else if (IS (p, CONFORMITY_CLAUSE)) { in_conformity (SUB (p)); } else if (IS (p, LOOP_CLAUSE)) { in_loop (SUB (p)); } } /*! \brief indent a literal \param txt **/ static void in_literal (char *txt) { put_str ("\""); while (txt[0] != NULL_CHAR) { if (txt[0] == '\"') { put_str ("\"\""); } else { put_ch (txt[0]); } txt ++; } put_str ("\""); } /*! \brief indent denotation \param p position in tree **/ static void in_denotation (NODE_T *p) { if (IS (p, ROW_CHAR_DENOTATION)) { in_literal (NSYMBOL (p)); } else if (IS (p, LONGETY) || IS (p, SHORTETY)) { in_sizety (SUB (p)); in_denotation (NEXT (p)); } else { put_sym (p, !KEYWORD); } } /*! \brief indent label \param p position in tree **/ static void in_label (NODE_T *p) { for (; p != NO_NODE; FORWARD (p)) { if (SUB (p) != NULL) { in_label (SUB (p)); } else if (IS (p, DEFINING_IDENTIFIER)) { put_sym (p, !KEYWORD); put_sym (NEXT (p), KEYWORD); } } } /*! \brief indent literal list \param p position in tree **/ static void in_collection (NODE_T *p) { for (; p != NO_NODE; FORWARD (p)) { if (IS (p, FORMAT_OPEN_SYMBOL) || IS (p, FORMAT_CLOSE_SYMBOL)) { put_sym (p, !KEYWORD); } else if (IS (p, COMMA_SYMBOL)) { put_sym (p, !KEYWORD); BLANK; } else { in_format (SUB (p)); } } } /*! \brief indent format text \param p position in tree **/ static void in_format (NODE_T *p) { for (; p != NO_NODE; FORWARD (p)) { if (IS (p, FORMAT_DELIMITER_SYMBOL)) { put_sym (p, !KEYWORD); } else if (IS (p, COLLECTION)) { in_collection (SUB (p)); } else if (IS (p, ENCLOSED_CLAUSE)) { in_enclosed (SUB (p)); } else if (IS (p, LITERAL)) { in_literal (NSYMBOL (p)); } else if (IS (p, STATIC_REPLICATOR)) { in_denotation (p); } else if (IS (p, COMMA_SYMBOL)) { put_sym (p, !KEYWORD); BLANK; } else { if (SUB (p) != NO_NODE) { in_format (SUB (p)); } else { switch (ATTRIBUTE (p)) { case FORMAT_ITEM_A: put_sym (p, !KEYWORD); break; case FORMAT_ITEM_B: put_sym (p, !KEYWORD); break; case FORMAT_ITEM_C: put_sym (p, !KEYWORD); break; case FORMAT_ITEM_D: put_sym (p, !KEYWORD); break; case FORMAT_ITEM_E: put_sym (p, !KEYWORD); break; case FORMAT_ITEM_ESCAPE: put_sym (p, !KEYWORD); break; case FORMAT_ITEM_F: put_sym (p, !KEYWORD); break; case FORMAT_ITEM_G: put_sym (p, !KEYWORD); break; case FORMAT_ITEM_H: put_sym (p, !KEYWORD); break; case FORMAT_ITEM_I: put_sym (p, !KEYWORD); break; case FORMAT_ITEM_J: put_sym (p, !KEYWORD); break; case FORMAT_ITEM_K: put_sym (p, !KEYWORD); break; case FORMAT_ITEM_L: put_sym (p, !KEYWORD); break; case FORMAT_ITEM_M: put_sym (p, !KEYWORD); break; case FORMAT_ITEM_MINUS: put_sym (p, !KEYWORD); break; case FORMAT_ITEM_N: put_sym (p, !KEYWORD); break; case FORMAT_ITEM_O: put_sym (p, !KEYWORD); break; case FORMAT_ITEM_P: put_sym (p, !KEYWORD); break; case FORMAT_ITEM_PLUS: put_sym (p, !KEYWORD); break; case FORMAT_ITEM_POINT: put_sym (p, !KEYWORD); break; case FORMAT_ITEM_Q: put_sym (p, !KEYWORD); break; case FORMAT_ITEM_R: put_sym (p, !KEYWORD); break; case FORMAT_ITEM_S: put_sym (p, !KEYWORD); break; case FORMAT_ITEM_T: put_sym (p, !KEYWORD); break; case FORMAT_ITEM_U: put_sym (p, !KEYWORD); break; case FORMAT_ITEM_V: put_sym (p, !KEYWORD); break; case FORMAT_ITEM_W: put_sym (p, !KEYWORD); break; case FORMAT_ITEM_X: put_sym (p, !KEYWORD); break; case FORMAT_ITEM_Y: put_sym (p, !KEYWORD); break; case FORMAT_ITEM_Z: put_sym (p, !KEYWORD); break; } } } } } /*! \brief constant folder - replace constant statement with value \param p position in tree **/ static BOOL_T in_folder (NODE_T *p) { if (MOID (p) == MODE (INT)) { A68_INT k; stack_pointer = 0; push_unit (p); POP_OBJECT (p, &k, A68_INT); if (ERROR_COUNT (&program) == 0) { ASSERT (snprintf (in_line, SNPRINTF_SIZE, "%d", VALUE (&k)) >= 0); put_str (in_line); return (A68_TRUE); } else { return (A68_FALSE); } } else if (MOID (p) == MODE (REAL)) { A68_REAL x; double conv; stack_pointer = 0; push_unit (p); POP_OBJECT (p, &x, A68_REAL); /* Mind overflowing or underflowing values */ if (ERROR_COUNT (&program) != 0) { return (A68_FALSE); } else if (VALUE (&x) == DBL_MAX) { return (A68_FALSE); } else if (VALUE (&x) == -DBL_MAX) { return (A68_FALSE); } else { ASSERT (snprintf (in_line, SNPRINTF_SIZE, "%.*g", REAL_WIDTH, VALUE (&x)) >= 0); errno = 0; conv = strtod (in_line, NO_VAR); if (errno == ERANGE && conv == 0.0) { put_str ("0.0"); return (A68_TRUE); } else if (errno == ERANGE) { return (A68_FALSE); } else { if (strchr (in_line, '.') == NO_TEXT && strchr (in_line, 'e') == NO_TEXT && strchr (in_line, 'E') == NO_TEXT) { strncat (in_line, ".0", BUFFER_SIZE); } put_str (in_line); return (A68_TRUE); } } } else if (MOID (p) == MODE (BOOL)) { A68_BOOL b; stack_pointer = 0; push_unit (p); POP_OBJECT (p, &b, A68_BOOL); if (ERROR_COUNT (&program) != 0) { return (A68_FALSE); } else { ASSERT (snprintf (in_line, SNPRINTF_SIZE, "%s", (VALUE (&b) ? "TRUE" : "FALSE")) >= 0); put_str (in_line); return (A68_TRUE); } } else if (MOID (p) == MODE (CHAR)) { A68_CHAR c; stack_pointer = 0; push_unit (p); POP_OBJECT (p, &c, A68_CHAR); if (ERROR_COUNT (&program) == 0) { return (A68_FALSE); } else if (VALUE (&c) == '\"') { put_str ("\"\"\"\""); return (A68_TRUE); } else { ASSERT (snprintf (in_line, SNPRINTF_SIZE, "\"%c\"", VALUE (&c)) >= 0); return (A68_TRUE); } } return (A68_FALSE); } /*! \brief indent statement \param p position in tree **/ static void in_statement (NODE_T *p) { if (IS (p, LABEL)) { int enclos = 0, seps = 0; in_label (SUB (p)); FORWARD (p); count_enclos (SUB (p), &enclos, &seps); if (enclos == 0) { BLANK; } else { put_nl (); } } if (use_folder && folder_mode (MOID (p)) && constant_unit (p)) { if (in_folder (p)) { return; }; } if (is_coercion (p)) { in_statement (SUB (p)); } else if (is_one_of (p, PRIMARY, SECONDARY, TERTIARY, UNIT, LABELED_UNIT, STOP)) { in_statement (SUB (p)); } else if (IS (p, ENCLOSED_CLAUSE)) { in_enclosed (SUB (p)); } else if (IS (p, DENOTATION)) { in_denotation (SUB (p)); } else if (IS (p, FORMAT_TEXT)) { in_format (SUB (p)); } else if (IS (p, IDENTIFIER)) { put_sym (p, !KEYWORD); } else if (IS (p, CAST)) { NODE_T *decl = SUB (p); NODE_T *rhs = NEXT (decl); in_declarer (decl); BLANK; in_enclosed (rhs); } else if (IS (p, CALL)) { NODE_T *primary = SUB (p); NODE_T *arguments = NEXT (primary); NODE_T *what = NO_NODE; int pop_ind = ind; in_statement (primary); BLANK; in_generic_list (arguments, &what, ONE_LINER); ind = pop_ind; } else if (IS (p, SLICE)) { NODE_T *primary = SUB (p); NODE_T *indexer = NEXT (primary); NODE_T *what = NO_NODE; int pop_ind = ind; in_statement (primary); in_generic_list (indexer, &what, ONE_LINER); ind = pop_ind; } else if (IS (p, SELECTION)) { NODE_T *selector = SUB (p); NODE_T *secondary = NEXT (selector); in_statement (selector); in_statement (secondary); } else if (IS (p, SELECTOR)) { NODE_T *identifier = SUB (p); put_sym (identifier, !KEYWORD); BLANK; put_sym (NEXT (identifier), !KEYWORD); /* OF */ BLANK; } else if (IS (p, GENERATOR)) { NODE_T *q = SUB (p); put_sym (q, !KEYWORD); BLANK; in_declarer (NEXT (q)); } else if (IS (p, FORMULA)) { NODE_T *lhs = SUB (p); NODE_T *op = NEXT (lhs); in_statement (lhs); if (op != NO_NODE) { NODE_T *rhs = NEXT (op); BLANK; put_sym (op, !KEYWORD); BLANK; in_statement (rhs); } } else if (IS (p, MONADIC_FORMULA)) { NODE_T *op = SUB (p); NODE_T *rhs = NEXT (op); put_sym (op, !KEYWORD); if (a68g_strchr (MONADS, (NSYMBOL (op))[0]) == NO_TEXT) { BLANK; } in_statement (rhs); } else if (IS (p, NIHIL)) { put_sym (p, !KEYWORD); } else if (IS (p, AND_FUNCTION) || IS (p, OR_FUNCTION)) { NODE_T *lhs = SUB (p); NODE_T *op = NEXT (lhs); NODE_T *rhs = NEXT (op); in_statement (lhs); BLANK; put_sym (op, !KEYWORD); BLANK; in_statement (rhs); } else if (IS (p, TRANSPOSE_FUNCTION) || IS (p, DIAGONAL_FUNCTION) || IS (p, ROW_FUNCTION) || IS (p, COLUMN_FUNCTION)) { NODE_T *q = SUB (p); if (IS (p, TERTIARY)) { in_statement (q); BLANK; FORWARD (q); } put_sym (q, !KEYWORD); BLANK; in_statement (NEXT (q)); } else if (IS (p, ASSIGNATION)) { NODE_T *dst = SUB (p); NODE_T *bec = NEXT (dst); NODE_T *src = NEXT (bec); in_statement (dst); BLANK; put_sym (bec, !KEYWORD); BLANK; in_statement (src); } else if (IS (p, ROUTINE_TEXT)) { NODE_T *q = SUB (p); int units, seps; if (IS (q, PARAMETER_PACK)) { in_pack (SUB (q)); BLANK; FORWARD (q); } in_declarer (q); FORWARD (q); put_sym (q, !KEYWORD); /* : */ FORWARD (q); units = 0; seps = 0; count (q, &units, &seps); if (units <= 1 && seps == 0) { BLANK; in_statement (q); } else { put_nl (); in_statement (q); } } else if (IS (p, IDENTITY_RELATION)) { NODE_T *lhs = SUB (p); NODE_T *op = NEXT (lhs); NODE_T *rhs = NEXT (op); in_statement (lhs); BLANK; put_sym (op, !KEYWORD); BLANK; in_statement (rhs); } else if (IS (p, JUMP)) { NODE_T *q = SUB (p); if (IS (q, GOTO_SYMBOL)) { put_sym (q, !KEYWORD); BLANK; FORWARD (q); } put_sym (q, !KEYWORD); } else if (IS (p, SKIP)) { put_sym (p, !KEYWORD); } else if (IS (p, ASSERTION)) { NODE_T *q = SUB (p); put_sym (q, KEYWORD); BLANK; in_enclosed (NEXT (q)); } else if (IS (p, CODE_CLAUSE)) { NODE_T *q = SUB (p); put_sym (q, KEYWORD); BLANK; FORWARD (q); in_collection(SUB (q)); FORWARD (q); put_sym (q, KEYWORD); } } /*! \brief indent identifier declarations \param p position in tree **/ static void in_iddecl (NODE_T *p) { for (; p != NO_NODE; FORWARD (p)) { if (IS (p, IDENTITY_DECLARATION) || IS (p, VARIABLE_DECLARATION)) { in_iddecl (SUB (p)); } else if (IS (p, QUALIFIER)) { put_sym (SUB (p), !KEYWORD); BLANK; } else if (IS (p, DECLARER)) { in_declarer (SUB (p)); BLANK; } else if (IS (p, DEFINING_IDENTIFIER)) { NODE_T *q = p; put_sym (q, !KEYWORD); FORWARD (q); if (q != NO_NODE) { /* := unit */ BLANK; put_sym (q, !KEYWORD); BLANK; FORWARD (q); in_statement (q); } } else if (IS (p, COMMA_SYMBOL)) { put_sym (p, !KEYWORD); BLANK; } } } /*! \brief indent procedure declarations \param p position in tree **/ static void in_procdecl (NODE_T *p) { for (; p != NO_NODE; FORWARD (p)) { if (IS (p, PROCEDURE_DECLARATION) || IS (p, PROCEDURE_VARIABLE_DECLARATION)) { in_procdecl (SUB (p)); } else if (IS (p, PROC_SYMBOL)) { put_sym (p, KEYWORD); BLANK; ind = col; } else if (IS (p, DEFINING_IDENTIFIER)) { NODE_T *q = p; put_sym (q, !KEYWORD); FORWARD (q); BLANK; put_sym (q, !KEYWORD); BLANK; FORWARD (q); in_statement (q); } else if (IS (p, COMMA_SYMBOL)) { put_sym (p, !KEYWORD); put_nl (); BLANK; } } } /*! \brief indent operator declarations \param p position in tree **/ static void in_opdecl (NODE_T *p) { for (; p != NO_NODE; FORWARD (p)) { if (IS (p, OPERATOR_DECLARATION) || IS (p, BRIEF_OPERATOR_DECLARATION)) { in_opdecl (SUB (p)); } else if (IS (p, OP_SYMBOL)) { put_sym (p, KEYWORD); BLANK; ind = col; } else if (IS (p, OPERATOR_PLAN)) { in_declarer (SUB (p)); BLANK; ind = col; } else if (IS (p, DEFINING_OPERATOR)) { NODE_T *q = p; put_sym (q, !KEYWORD); FORWARD (q); BLANK; put_sym (q, !KEYWORD); BLANK; FORWARD (q); in_statement (q); } else if (IS (p, COMMA_SYMBOL)) { put_sym (p, !KEYWORD); put_nl (); BLANK; } } } /*! \brief indent priority declarations \param p position in tree **/ static void in_priodecl (NODE_T *p) { for (; p != NO_NODE; FORWARD (p)) { if (IS (p, PRIORITY_DECLARATION)) { in_priodecl (SUB (p)); } else if (IS (p, PRIO_SYMBOL)) { put_sym (p, KEYWORD); BLANK; } else if (IS (p, DEFINING_OPERATOR)) { NODE_T *q = p; put_sym (q, !KEYWORD); FORWARD (q); BLANK; put_sym (q, !KEYWORD); BLANK; FORWARD (q); put_sym (q, !KEYWORD); } else if (IS (p, COMMA_SYMBOL)) { put_sym (p, !KEYWORD); BLANK; } } } /*! \brief indent mode declarations \param p position in tree **/ static void in_modedecl (NODE_T *p) { for (; p != NO_NODE; FORWARD (p)) { if (IS (p, MODE_DECLARATION)) { in_modedecl (SUB (p)); } else if (IS (p, MODE_SYMBOL)) { put_sym (p, KEYWORD); BLANK; ind = col; } else if (IS (p, DEFINING_INDICANT)) { NODE_T *q = p; put_sym (q, !KEYWORD); FORWARD (q); BLANK; put_sym (q, !KEYWORD); BLANK; FORWARD (q); in_declarer (q); } else if (IS (p, COMMA_SYMBOL)) { put_sym (p, !KEYWORD); put_nl (); BLANK; } } } /*! \brief indent declaration list \param p position in tree **/ static void in_declist (NODE_T *p, BOOL_T one_liner) { for (; p != NO_NODE; FORWARD (p)) { if (IS (p, IDENTITY_DECLARATION) || IS (p, VARIABLE_DECLARATION)) { int pop_ind = ind; in_iddecl (p); ind = pop_ind; } else if (IS (p, PROCEDURE_DECLARATION) || IS (p, PROCEDURE_VARIABLE_DECLARATION)) { int pop_ind = ind; in_procdecl (p); ind = pop_ind; } else if (IS (p, OPERATOR_DECLARATION) || IS (p, BRIEF_OPERATOR_DECLARATION)) { int pop_ind = ind; in_opdecl (p); ind = pop_ind; } else if (IS (p, PRIORITY_DECLARATION)) { int pop_ind = ind; in_priodecl (p); ind = pop_ind; } else if (IS (p, MODE_DECLARATION)) { int pop_ind = ind; in_modedecl (p); ind = pop_ind; } else if (IS (p, COMMA_SYMBOL)) { put_sym (p, !KEYWORD); if (one_liner) { BLANK; } else { put_nl (); } } else { in_declist (SUB (p), one_liner); } } } /*! \brief indent serial clause \param p position in tree **/ static void in_serial (NODE_T *p, BOOL_T one_liner, NODE_T **what) { for (; p != NO_NODE; FORWARD (p)) { if (IS (p, UNIT) || IS (p, LABELED_UNIT)) { int pop_ind = ind; (*what) = p; in_statement (p); ind = pop_ind; } else if (IS (p, DECLARATION_LIST)) { (*what) = p; in_declist (p, one_liner); } else if (IS (p, SEMI_SYMBOL)) { put_sym (p, !KEYWORD); if (!one_liner) { put_nl (); if ((*what) != NO_NODE && IS ((*what), DECLARATION_LIST)) { put_nl (); } } else { BLANK; } } else if (IS (p, EXIT_SYMBOL)) { if (NPRAGMENT (p) == NO_TEXT) { BLANK; } put_sym (p, !KEYWORD); if (!one_liner) { put_nl (); } else { BLANK; } } else { in_serial (SUB (p), one_liner, what); } } } /*! \brief do not pretty-print the environ \param p position in tree **/ static void skip_environ (NODE_T *p) { for (; p != NO_NODE; FORWARD (p)) { if (LINE_NUMBER (p) == 0) { pragment (p, ! KEYWORD); skip_environ (SUB (p)); } else { NODE_T *what = NO_NODE; in_serial (p, !ONE_LINER, &what); } } } /*! \brief indenter driver \param p position in tree **/ void indenter (MODULE_T *q) { ind = 1; col = 1; indentation = OPTION_INDENT (q); use_folder = OPTION_FOLD (q); FILE_PRETTY_FD (q) = open (FILE_PRETTY_NAME (q), O_WRONLY | O_CREAT | O_TRUNC, A68_PROTECTION); ABEND (FILE_PRETTY_FD (q) == -1, "cannot open listing file", NO_TEXT); FILE_PRETTY_OPENED (q) = A68_TRUE; fd = FILE_PRETTY_FD (q); skip_environ (TOP_NODE (q)); ASSERT (close (fd) == 0); FILE_PRETTY_OPENED (q) = A68_FALSE; return; } algol68g-2.4.1/source/edit.c0000644000175000001440000047415611770170352012473 00000000000000/*! \file edit.c \brief full screen editor for Algol 68 Genie **/ /* This file is part of Algol68G - an Algol 68 interpreter. Copyright (C) 2001-2012 J. Marcel van der Veer . 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 is an experimental curses-based UNIX approximation of big-iron editors as the XEDIT/ISPF editors. It is meant for maintaining small to intermediate sized source code. The command set is small, and there is no huge file support: the text is in core which makes for a *fast* editor. It is still undocumented as it is not fully debugged and not feature-complete. I use it for daily editing work and have not lost work for a long time now, but you just *might* still loose your work. Do not say I did not warn you! The editor is modeless. If you are in text, what you type goes into the file. What you type in the prefix, will be a prefix command. What you type on the command line, is a command. No input-modes or command-mode or escapes. The editor supports prefix commands and text folding, like the XEDIT/ISPF editors. Especially folding is a nice feature: you select a group of lines with a common criterion, and edit them as a separate group. */ #if defined HAVE_CONFIG_H #include "a68g-config.h" #endif #include "a68g.h" /* Without CURSES or REGEX, we have no editor, so: */ #if defined HAVE_EDITOR #define BACKSPACE 127 #define BLANK " " #define BLOCK_SIZE 4 #define BOTSTR "* * * End of Data * * *" #define DATE_STRING "%d-%m-%y %H:%M:%S" #define EMPTY_STRING(s) ((s) == NO_TEXT || (s)[0] == NULL_CHAR) #define EDIT_HELP_FILE ".a68g.edit.help" #define FD_READ 0 #define FD_WRITE 1 #define HISTORY 64 #define IS_IN_TEXT(z) ((z) != NO_EDLIN && NUMBER (z) > 0) #define IS_EOF(z) (!NOT_EOF(z)) #define IS_TOF(z) (!NOT_TOF(z)) #define MARGIN 7 #define MAX_PF 64 #define NOT_EOF(z) ((z) != NO_EDLIN && NEXT (z) != NO_EDLIN) #define NOT_TOF(z) ((z) != NO_EDLIN && PREVIOUS (z) != NO_EDLIN) #define PREFIX "====== " #define PROMPT "=====> " #define PROTECTED(s) ASSERT (snprintf (DL0 (scr), SNPRINTF_SIZE, "%s: cursor in protected area", (s)) >= 0) #define SUBST_ERROR -1 #define TAB_STOP 8 #define TEXT_WIDTH (COLS - MARGIN) #define TOPSTR "* * * Top of Data * * *" #define TRAILING(s) ASSERT (snprintf (DL0 (scr), SNPRINTF_SIZE, "%s: trailing text", (s)) >= 0) #define WRONG_TARGET (-1) #define EDIT_TEST(c) {\ if (! (c)) {\ ASSERT (snprintf (DL0 (scr), SNPRINTF_SIZE, "%s: error detected at line %d", __FILE__, __LINE__) >= 0);\ }} #if ! defined true #define true 1 #endif #if defined HAVE_LINUX #define USE_MOUSE #endif #define REDRAW {EDIT_TEST (clearok (stdscr, true) != ERR);} #define NEW_CURR(dd, line) {CURR (dd) = line; REDRAW;} static char pf_bind[MAX_PF][BUFFER_SIZE]; static char history[HISTORY][BUFFER_SIZE]; static int histcurr = -1, histnext = -1, histprev = -1; static int loop_cnt = 0; enum {PAIR_ARROW = 1, PAIR_CMDLINE, PAIR_CONTROL, PAIR_CURLINE, PAIR_FILEAREA, PAIR_IDLINE, PAIR_MATCH, PAIR_MSGLINE, PAIR_PREFIX, PAIR_SCALE, PAIR_TOFEOF}; static int pair_arrow = 0, pair_cmdline = 0, pair_control = 0, pair_curline = 0, pair_filearea = 0, pair_idline = 0, pair_match = 0, pair_msgline = 0, pair_prefix = 0, pair_scale = 0, pair_tofeof = 0; #define KEY_CTRL(n) TO_UCHAR ((int) n - 0x40) #define SAVE_CURSOR(dd, curs) {\ ROW0 (curs) = ROW (curs);\ COL0 (curs) = COL (curs);\ } #define CURSOR_TO_SAVE(dd, curs) {\ ROW (curs) = ROW0 (curs);\ COL (curs) = COL0 (curs);\ } #define CURSOR_TO_CURRENT(dd, curs) {\ SYNC_LINE (curs) = CURR (dd);\ SYNC_INDEX (curs) = 0;\ SYNC (curs) = A68_TRUE;\ } #define CURSOR_TO_COMMAND(dd, curs) {\ ROW (curs) = CMD_ROW (&DISPLAY (dd));\ COL (curs) = MARGIN;\ SYNC (curs) = A68_FALSE;\ } #define CHECK_ERRNO(cmd) {\ if (errno != 0) {\ ASSERT (snprintf (DL0 (scr), SNPRINTF_SIZE, "%s: %s", cmd, error_specification ()) >= 0);\ return;\ }} #define SKIP_WHITE(w) {\ while ((w) != NO_TEXT && (w)[0] != NULL_CHAR && IS_SPACE ((w)[0])) {\ (w)++;\ }} #define NO_ARGS(c, z) {\ if ((z) != NO_TEXT && (z)[0] != NULL_CHAR) {\ ASSERT (snprintf (DL0 (scr), SNPRINTF_SIZE, "%s: unexpected argument", c) >= 0);\ ROW (curs) = CMD_ROW (scr);\ COL (curs) = MARGIN;\ return;\ }} #define ARGS(c, z) {\ if ((z) == NO_TEXT || (z)[0] == NULL_CHAR) {\ ASSERT (snprintf (DL0 (scr), SNPRINTF_SIZE, "%s: missing argument", c) >= 0);\ ROW (curs) = CMD_ROW (scr);\ COL (curs) = MARGIN;\ return;\ }} #define XABEND(p, reason, info) {\ if (p) {\ (void) endwin ();\ abend ((char *) reason, (char *) info, __FILE__, __LINE__);\ }} typedef struct KEY KEY; struct KEY { int code, trans; char *name; }; /* Key substitutions */ KEY trans_tab[] = { {8, 263, "KEY_BACKSPACE"}, {13, 10, "LF Line feed"}, {529, 259, "KEY_UP"}, {530, 260, "KEY_LEFT"}, {531, 261, "KEY_RIGHT"}, {532, 258, "KEY_DOWN"}, {KEY_ENTER, 10, "LF Line feed"}, {-1, -1, NO_TEXT} }; /* Keys defined by curses */ KEY key_tab[] = { {0, 0, "NUL Null character"}, {1, 1, "SOH Start of Header"}, {2, 2, "STX Start of Text"}, {3, 3, "ETX End of Text"}, {4, 4, "EOT End of Transmission"}, {5, 5, "ENQ Enquiry"}, {6, 6, "ACK Acknowledgment"}, {7, 7, "BEL Bell"}, {8, 8, "BS Backspace"}, {9, 9, "HT Horizontal"}, {10, 10, "LF Line feed"}, {11, 11, "VT Vertical Tab"}, {12, 12, "FF Form feed"}, {13, 13, "CR Carriage return"}, {14, 14, "SO Shift Out"}, {15, 15, "SI Shift In"}, {16, 16, "DLE Data Link Escape"}, {17, 17, "DC1 Device Control 1 XON"}, {18, 18, "DC2 Device Control 2"}, {19, 19, "DC3 Device Control 3 XOFF"}, {20, 20, "DC4 Device Control 4"}, {21, 21, "NAK Negative Acknowledgement"}, {22, 22, "SYN Synchronous idle"}, {23, 23, "ETB End of Transmission Block"}, {24, 24, "CAN Cancel"}, {25, 25, "EM End of Medium"}, {26, 26, "SUB Substitute"}, {27, 27, "ESC Escape"}, {28, 28, "FS File Separator"}, {29, 29, "GS Group Separator"}, {30, 30, "RS Record Separator"}, {31, 31, "US Unit Separator"}, {257, 257, "KEY_BREAK"}, {257, 257, "KEY_MIN"}, {258, 258, "KEY_DOWN"}, {259, 259, "KEY_UP"}, {260, 260, "KEY_LEFT"}, {261, 261, "KEY_RIGHT"}, {262, 262, "KEY_HOME"}, {263, 263, "KEY_BACKSPACE"}, {264, 264, "KEY_F0"}, {265, 265, "KEY_F1"}, {266, 266, "KEY_F2"}, {267, 267, "KEY_F3"}, {268, 268, "KEY_F4"}, {269, 269, "KEY_F5"}, {270, 270, "KEY_F6"}, {271, 271, "KEY_F7"}, {272, 272, "KEY_F8"}, {273, 273, "KEY_F9"}, {274, 274, "KEY_F10"}, {275, 275, "KEY_F11"}, {276, 276, "KEY_F12"}, {277, 277, "KEY_F13"}, {278, 278, "KEY_F14"}, {279, 279, "KEY_F15"}, {280, 280, "KEY_F16"}, {281, 281, "KEY_F17"}, {282, 282, "KEY_F18"}, {283, 283, "KEY_F19"}, {284, 284, "KEY_F20"}, {285, 285, "KEY_F21"}, {286, 286, "KEY_F22"}, {287, 287, "KEY_F23"}, {288, 288, "KEY_F24"}, {289, 289, "KEY_F25"}, {290, 290, "KEY_F26"}, {291, 291, "KEY_F27"}, {292, 292, "KEY_F28"}, {293, 293, "KEY_F29"}, {294, 294, "KEY_F30"}, {295, 295, "KEY_F31"}, {296, 296, "KEY_F32"}, {297, 297, "KEY_F33"}, {298, 298, "KEY_F34"}, {299, 299, "KEY_F35"}, {300, 300, "KEY_F36"}, {301, 301, "KEY_F37"}, {302, 302, "KEY_F38"}, {303, 303, "KEY_F39"}, {304, 304, "KEY_F40"}, {305, 305, "KEY_F41"}, {306, 306, "KEY_F42"}, {307, 307, "KEY_F43"}, {308, 308, "KEY_F44"}, {309, 309, "KEY_F45"}, {310, 310, "KEY_F46"}, {311, 311, "KEY_F47"}, {312, 312, "KEY_F48"}, {313, 313, "KEY_F49"}, {314, 314, "KEY_F50"}, {315, 315, "KEY_F51"}, {316, 316, "KEY_F52"}, {317, 317, "KEY_F53"}, {318, 318, "KEY_F54"}, {319, 319, "KEY_F55"}, {320, 320, "KEY_F56"}, {321, 321, "KEY_F57"}, {322, 322, "KEY_F58"}, {323, 323, "KEY_F59"}, {324, 324, "KEY_F60"}, {325, 325, "KEY_F61"}, {326, 326, "KEY_F62"}, {327, 327, "KEY_F63"}, {328, 328, "KEY_DL"}, {329, 329, "KEY_IL"}, {330, 330, "KEY_DC"}, {331, 331, "KEY_IC"}, {332, 332, "KEY_EIC"}, {333, 333, "KEY_CLEAR"}, {334, 334, "KEY_EOS"}, {335, 335, "KEY_EOL"}, {336, 336, "KEY_SF"}, {337, 337, "KEY_SR"}, {338, 338, "KEY_NPAGE"}, {339, 339, "KEY_PPAGE"}, {340, 340, "KEY_STAB"}, {341, 341, "KEY_CTAB"}, {342, 342, "KEY_CATAB"}, {343, 343, "KEY_ENTER"}, {344, 344, "KEY_SRESET"}, {345, 345, "KEY_RESET"}, {346, 346, "KEY_PRINT"}, {347, 347, "KEY_LL"}, {348, 348, "KEY_A1"}, {349, 349, "KEY_A3"}, {350, 350, "KEY_B2"}, {351, 351, "KEY_C1"}, {352, 352, "KEY_C3"}, {353, 353, "KEY_BTAB"}, {354, 354, "KEY_BEG"}, {355, 355, "KEY_CANCEL"}, {356, 356, "KEY_CLOSE"}, {357, 357, "KEY_COMMAND"}, {358, 358, "KEY_COPY"}, {359, 359, "KEY_CREATE"}, {360, 360, "KEY_END"}, {361, 361, "KEY_EXIT"}, {362, 362, "KEY_FIND"}, {363, 363, "KEY_HELP"}, {364, 364, "KEY_MARK"}, {365, 365, "KEY_MESSAGE"}, {366, 366, "KEY_MOVE"}, {367, 367, "KEY_NEXT"}, {368, 368, "KEY_OPEN"}, {369, 369, "KEY_OPTIONS"}, {370, 370, "KEY_PREVIOUS"}, {371, 371, "KEY_REDO"}, {372, 372, "KEY_REFERENCE"}, {373, 373, "KEY_REFRESH"}, {374, 374, "KEY_REPLACE"}, {375, 375, "KEY_RESTART"}, {376, 376, "KEY_RESUME"}, {377, 377, "KEY_SAVE"}, {378, 378, "KEY_SBEG"}, {379, 379, "KEY_SCANCEL"}, {380, 380, "KEY_SCOMMAND"}, {381, 381, "KEY_SCOPY"}, {382, 382, "KEY_SCREATE"}, {383, 383, "KEY_SDC"}, {384, 384, "KEY_SDL"}, {385, 385, "KEY_SELECT"}, {386, 386, "KEY_SEND"}, {387, 387, "KEY_SEOL"}, {388, 388, "KEY_SEXIT"}, {389, 389, "KEY_SFIND"}, {390, 390, "KEY_SHELP"}, {391, 391, "KEY_SHOME"}, {392, 392, "KEY_SIC"}, {393, 393, "KEY_SLEFT"}, {394, 394, "KEY_SMESSAGE"}, {395, 395, "KEY_SMOVE"}, {396, 396, "KEY_SNEXT"}, {397, 397, "KEY_SOPTIONS"}, {398, 398, "KEY_SPREVIOUS"}, {399, 399, "KEY_SPRINT"}, {400, 400, "KEY_SREDO"}, {401, 401, "KEY_SREPLACE"}, {402, 402, "KEY_SRIGHT"}, {403, 403, "KEY_SRSUME"}, {404, 404, "KEY_SSAVE"}, {405, 405, "KEY_SSUSPEND"}, {406, 406, "KEY_SUNDO"}, {407, 407, "KEY_SUSPEND"}, {408, 408, "KEY_UNDO"}, {409, 409, "KEY_MOUSE"}, {410, 410, "KEY_RESIZE"}, {511, 511, "KEY_MAX"}, {-1, -1, NO_TEXT} }; /* VT100 numeric keypad */ struct KEY dec_key[] = { #if ! defined HAVE_WIN32 {KEY_UP, KEY_UP, "\033OA"}, {KEY_DOWN, KEY_DOWN, "\033OB"}, {KEY_RIGHT, KEY_RIGHT, "\033OC"}, {KEY_LEFT, KEY_LEFT, "\033OD"}, {KEY_F0 + 1, KEY_F0 + 1, "\033OP"}, {KEY_F0 + 2, KEY_F0 + 2, "\033OQ"}, {KEY_F0 + 3, KEY_F0 + 3, "\033OR"}, {KEY_F0 + 4, KEY_F0 + 4, "\033OS"}, {KEY_F0 + 13, KEY_F0 + 13, "\033[1;2P"}, {KEY_F0 + 14, KEY_F0 + 14, "\033[1;2Q"}, {KEY_F0 + 15, KEY_F0 + 15, "\033[1;2R"}, {KEY_F0 + 16, KEY_F0 + 16, "\033[1;2S"}, {KEY_ENTER, KEY_ENTER, "\033OM"}, {'*', '*', "\033Oj"}, {'+', '+', "\033Ok"}, {',', ',', "\033Ol"}, {'-', '-', "\033Om"}, {'.', '.', "\033On"}, {'/', '/', "\033Oo"}, {'0', '0', "\033Op"}, {'1', '1', "\033Oq"}, {'2', '2', "\033Or"}, {'3', '3', "\033Os"}, {'4', '4', "\033Ot"}, {'5', '5', "\033Ou"}, {'6', '6', "\033Ov"}, {'7', '7', "\033Ow"}, {'8', '8', "\033Ox"}, {'9', '9', "\033Oy"}, {KEY_B2, KEY_B2, "\033[E"}, {KEY_END, KEY_END, "\033[4~"}, {KEY_HOME, KEY_HOME, "\033[1~"}, #endif {-1, -1, NO_TEXT} }; KEY regexp_tab[] = { {'d', -1, "[+-]?[0-9]+"}, {'f', -1, "[+-]?[0-9]*\\.?[0-9]+([eEdDqQ][+-]?[0-9]+)?"}, {'w', -1, "[A-Za-z_][A-Za-z0-9_]*"}, {-1, -1, NO_TEXT} }; typedef struct EDLIN_T EDLIN_T; struct EDLIN_T { int number, reserved; char precmd[MARGIN + 1]; char *text; EDLIN_T *next, *previous; BOOL_T select, modified; }; typedef struct CURSOR_T CURSOR_T; struct CURSOR_T { int row, col, row0, col0, index; EDLIN_T *line, *last; BOOL_T in_forbidden, in_prefix, in_text, in_cmd; BOOL_T sync; int sync_index; EDLIN_T *sync_line; unsigned long bstate; }; typedef struct DISPLAY_T DISPLAY_T; struct DISPLAY_T { int scale_row, cmd_row, idf_row; EDLIN_T *last_line; char status[BUFFER_SIZE]; char tmp_text[BUFFER_SIZE]; char cmd[BUFFER_SIZE]; char dl0[BUFFER_SIZE]; CURSOR_T curs; BOOL_T ins_mode; }; typedef struct REGEXP_T REGEXP_T; struct REGEXP_T { BOOL_T is_compiled, negate; char pattern[BUFFER_SIZE]; regex_t compiled; regmatch_t *match; size_t num_match; }; typedef struct DATASET_T DATASET_T; struct DATASET_T { mode_t perms; char name[BUFFER_SIZE]; char perm[BUFFER_SIZE]; char date[BUFFER_SIZE]; char undo[BUFFER_SIZE]; int size, alts, tabs, num, undo_line, search, m_so, m_eo; EDLIN_T *tof; /* top-of-file */ BOOL_T new_file; BOOL_T subset; BOOL_T collect; DISPLAY_T display; EDLIN_T *curr; /* Current line, above the scale */ EDLIN_T *match; /* Last line to match a regular expression */ EDLIN_T *bl_start, *bl_end; /* block at last copy or move */ REGEXP_T targ1, targ2, find, repl; char oper; /* regexp operator: & or | */ FILE_T msgs; ADDR_T heap_pointer; jmp_buf edit_exit_label; char *linbuf; int linsiz; }; /* Forward routines */ static void edit_draw (DATASET_T *); static void edit_do_cmd (DATASET_T *); static void edit_do_prefix (DATASET_T *); static void edit_loop (DATASET_T *); static void edit_dataset (DATASET_T *, int, char *, char *); static void edit_garbage_collect (DATASET_T *, char *); static void set_current (DATASET_T *, char *, char *); static void backward_line (EDLIN_T **); static void forward_line (EDLIN_T **); static int int_arg (DATASET_T *, char *, char *, char **, int); static int parse_colour (DATASET_T *, char *, char *, int); /*! \brief initialise curses \param dd current dataset **/ static void edit_init_colours (DATASET_T *dd) { if (has_colors ()) { (void) start_color (); pair_arrow = parse_colour (dd, "edit", "white", PAIR_ARROW); pair_cmdline = parse_colour (dd, "edit", "white", PAIR_CMDLINE); pair_control = parse_colour (dd, "edit", "magenta high", PAIR_CONTROL); pair_curline = parse_colour (dd, "edit", "white", PAIR_CURLINE); pair_filearea = parse_colour (dd, "edit", "green nohigh", PAIR_FILEAREA); pair_idline = parse_colour (dd, "edit", "blue high", PAIR_IDLINE); pair_match = parse_colour (dd, "edit", "red high", PAIR_MATCH); pair_msgline = parse_colour (dd, "edit", "red high", PAIR_MSGLINE); pair_prefix = parse_colour (dd, "edit", "blue nohigh", PAIR_PREFIX); pair_scale = parse_colour (dd, "edit", "blue nohigh", PAIR_SCALE); pair_tofeof = parse_colour (dd, "edit", "white", PAIR_TOFEOF); } } /*! \brief store help \param fn filename to write **/ void write_help_file (char *fn, char *nfn) { FILE *f = a68g_fopen (fn, "w", nfn); int pfk; if (f == NO_FILE) { return; } ASSERT (fprintf (f, "DEFAULT PF KEY BINDINGS\n\n") >= 0); for (pfk = 0; pfk < MAX_PF; pfk++) { if ((int) strlen (pf_bind[pfk]) > 0) { ASSERT (fprintf (f, "PF%02d=%s\n", pfk + 1, pf_bind[pfk]) >= 0); } } ASSERT (fprintf (f, "\nSCREEN LAYOUT\n\n") >= 0); ASSERT (fprintf (f, "+---------------------------------------------------+\n") >= 0); ASSERT (fprintf (f, "|size n line n col n alt n filename |<--Id/Message Line\n") >= 0); ASSERT (fprintf (f, "|=====> |<--Command Line\n") >= 0); ASSERT (fprintf (f, "|====== * * * Top of Data * * * |\n") >= 0); ASSERT (fprintf (f, "|000001 |\n") >= 0); ASSERT (fprintf (f, "|000002 |\n") >= 0); ASSERT (fprintf (f, "|000003 |<--Current Line\n") >= 0); ASSERT (fprintf (f, "| ...+....1....+....2... .... ...6....+....7..|<--Scale\n") >= 0); ASSERT (fprintf (f, "|000004 |\n") >= 0); ASSERT (fprintf (f, "|000005 |\n") >= 0); ASSERT (fprintf (f, "|000006 |\n") >= 0); ASSERT (fprintf (f, "|====== * * * End of Data * * * |\n") >= 0); ASSERT (fprintf (f, "+---------------------------------------------------+\n") >= 0); ASSERT (fprintf (f, " | | | |\n") >= 0); ASSERT (fprintf (f, " +---+ +-------------------------------------------+\n") >= 0); ASSERT (fprintf (f, " | |\n") >= 0); ASSERT (fprintf (f, " Prefix Area File Area\n") >= 0); ASSERT (fprintf (f, "\nCOMMAND OVERVIEW\n\n") >= 0); ASSERT (fprintf (f, "target A target as command, sets the current line\n") >= 0); ASSERT (fprintf (f, "ADD [n] Add n lines\n") >= 0); ASSERT (fprintf (f, "AGAIN Repeat last search\n") >= 0); ASSERT (fprintf (f, "CASE Switch case of character under cursor\n") >= 0); ASSERT (fprintf (f, "CDELETE Delete to end of line\n") >= 0); ASSERT (fprintf (f, "COPY Copy up to 1st target to after 2nd target, [n] copies\n") >= 0); ASSERT (fprintf (f, "DELETE Delete up to [target]\n") >= 0); ASSERT (fprintf (f, "INDENT Indent text to a column\n") >= 0); ASSERT (fprintf (f, "FILE Save file [to target filename] and quit\n") >= 0); ASSERT (fprintf (f, "FOLD [[TO] target] Folds lines either up TO target,\n") >= 0); ASSERT (fprintf (f, " or those matching target\n") >= 0); ASSERT (fprintf (f, "MOVE target target [n] Up to 1st target to after 2nd target, n copies\n") >= 0); ASSERT (fprintf (f, "PAGE [[+-]n|*] Forward or backward paging\n") >= 0); ASSERT (fprintf (f, "PFn cmd Binds function key n to cmd\n") >= 0); ASSERT (fprintf (f, "QQUIT Categorically quit\n") >= 0); ASSERT (fprintf (f, "READ Insert filename after current line\n") >= 0); ASSERT (fprintf (f, "RESET Reset prefixes\n") >= 0); ASSERT (fprintf (f, "SET CMD TOP|BOTTOM|*|n Place the command line\n") >= 0); ASSERT (fprintf (f, "SET IDF OFF|TOP|BOTTOM|*|n Place the file identification line\n") >= 0); ASSERT (fprintf (f, "SET SCALE OFF|TOP|BOTTOM|*|n Place the scale\n") >= 0); ASSERT (fprintf (f, "SET COLOUR|COLOR ARROW|CMDLINE|CONTROL|CURLINE|FILEAREA|IDLINE|\n") >= 0); ASSERT (fprintf (f, " MATCH|MSGLINE|PREFIX|SCALE|TOFEOF colour\n") >= 0); ASSERT (fprintf (f, "SHELL target cmd Filter lines using cmd\n") >= 0); ASSERT (fprintf (f, "S Substitute command /find/replace/ [C][target [n|* [m|*]]]\n") >= 0); ASSERT (fprintf (f, "TOGGLE Toggle between current line and command line (as do F1, F12)\n") >= 0); ASSERT (fprintf (f, "UNDO Undo until last command that made a back-up copy\n") >= 0); ASSERT (fprintf (f, "WRITE [target filename]\n") >= 0); ASSERT (fprintf (f, "\n") >= 0); ASSERT (fprintf (f, "= AGAIN, repeat last saved command\n") >= 0); ASSERT (fprintf (f, "? restore last saved command in the command buffer\n") >= 0); ASSERT (fprintf (f, "&cmd execute cmd and leave it in the command buffer\n") >= 0); ASSERT (fprintf (f, "\nTARGETS\n\n") >= 0); ASSERT (fprintf (f, ":n Absolute line number n\n") >= 0); ASSERT (fprintf (f, "[+]n n lines down\n") >= 0); ASSERT (fprintf (f, "-n n lines up\n") >= 0); ASSERT (fprintf (f, ".name line name as entered in prefix area\n") >= 0); ASSERT (fprintf (f, "[+]* top of file\n") >= 0); ASSERT (fprintf (f, "-* end of file\n") >= 0); ASSERT (fprintf (f, "[+]/REGEXP/ line matching REGEXP, search forward\n") >= 0); ASSERT (fprintf (f, "-/REGEXP/ line matching REGEXP, search backward\n") >= 0); ASSERT (fprintf (f, "\n") >= 0); ASSERT (fprintf (f, "All targets can have [+k|-k] relative offset, f.i. /IF/+1\n") >= 0); ASSERT (fprintf (f, "\n") >= 0); ASSERT (fprintf (f, "The editor uses POSIX ERE regular expression syntax.\n") >= 0); ASSERT (fprintf (f, "A prefix ~ to a regexp matches lines not matching regexp.\n") >= 0); ASSERT (fprintf (f, "\n") >= 0); ASSERT (fprintf (f, "[~]/regexp/ regexp must [not] match\n") >= 0); ASSERT (fprintf (f, "[~]/regexp/&[~]/regexp/ both lines must [not] match\n") >= 0); ASSERT (fprintf (f, "[~]/regexp/|[~]/regexp/ one or both must [not] match\n") >= 0); ASSERT (fprintf (f, "[~]/regexp/^[~]/regexp/ at most one regexp must [not] match\n") >= 0); ASSERT (fprintf (f, "\n") >= 0); ASSERT (fprintf (f, "In substitution you can specify matched subexpression with \\1 .. \\9\n") >= 0); ASSERT (fprintf (f, "syntax; furthermore you can specify \\a .. \\j or \\A .. \\J which will\n") >= 0); ASSERT (fprintf (f, "cast the subexpression to either lower - or upper case respectively.\n") >= 0); ASSERT (fprintf (f, "\nPREFIX COMMANDS\n\n") >= 0); ASSERT (fprintf (f, "/ Make line the current line\n") >= 0); ASSERT (fprintf (f, "A[n] Add n new lines below this line\n") >= 0); ASSERT (fprintf (f, "C[n] Copy lines; use P (after) or Q (before) for destination\n") >= 0); ASSERT (fprintf (f, "CC Copy block of lines marker;\n") >= 0); ASSERT (fprintf (f, " use P (after) or Q (before) for destination\n") >= 0); ASSERT (fprintf (f, "D[n] Delete lines\n") >= 0); ASSERT (fprintf (f, "DD Delete block of lines marker\n") >= 0); ASSERT (fprintf (f, "F Select line for editing\n") >= 0); ASSERT (fprintf (f, "FF Select block of lines for editing\n") >= 0); ASSERT (fprintf (f, "I Indent line relative to column or to absolute column [<|>][n]\n") >= 0); ASSERT (fprintf (f, "II Indent block of lines\n") >= 0); ASSERT (fprintf (f, "J Join with next line\n") >= 0); ASSERT (fprintf (f, "P[n] Add n copies after this line\n") >= 0); ASSERT (fprintf (f, "Q[n] Add n copies before this line\n") >= 0); ASSERT (fprintf (f, "U Unselect line from editing\n") >= 0); ASSERT (fprintf (f, "UU Unselect block of lines from editing\n") >= 0); ASSERT (fprintf (f, "X[n] Move lines; use P (after) or Q (before) for destination\n") >= 0); ASSERT (fprintf (f, "XX Move block of lines marker;\n") >= 0); ASSERT (fprintf (f, " use P (after) or Q (before) for destination\n") >= 0); ASSERT (fprintf (f, "\nCOLOURS IN SET COMMAND\n\n") >= 0); ASSERT (fprintf (f, "RED|GREEN|YELLOW|BLUE|MAGENTA|CYAN|WHITE [HIGH|NOHIGH|DIM]\n") >= 0); ASSERT (fclose (f) == 0); } /*! \brief set colour on screen \param pair same **/ static void set_colour (int pair) { if (has_colors ()) { /* On 64-bit platforms gcc may complain of a possible sign change; a warning generated in a curses macro which I cannot help. */ (void) wattrset (stdscr, pair); } } /*! brief colour to string \param f file to write to \param name field name \param clr coded attribute \param pair pair number **/ static void write_colour (FILE *f, char *name, int clr, int pair) { short fg, bg; fprintf (f, "%s", name); (void) pair_content ((short) pair, &fg, &bg); switch (fg) { case COLOR_BLACK: fprintf (f, " black"); break; case COLOR_RED: fprintf (f, " red"); break; case COLOR_GREEN: fprintf (f, " green"); break; case COLOR_YELLOW: fprintf (f, " yellow"); break; case COLOR_BLUE: fprintf (f, " blue"); break; case COLOR_MAGENTA: fprintf (f, " magenta"); break; case COLOR_CYAN: fprintf (f, " cyan"); break; case COLOR_WHITE: fprintf (f, " white"); break; default: fprintf (f, "%d %d %d", pair, (int) fg, (int) bg); break; } if (clr & (int) A_NORMAL) { fprintf (f, " nohigh"); } else if (clr & (int) A_BOLD) { fprintf (f, " high"); } else if (clr & (int) A_DIM) { fprintf (f, " low"); } fprintf (f, "\n"); } /*! \brief set pointers to track history \param ref **/ static void edit_set_history (int ref) { histprev = ref - 1; if (histprev < 0) { histprev = HISTORY - 1; while (histprev > 0 && strlen (history[histprev]) == 0) { histprev --; } } histnext = ref + 1; if (histprev >= HISTORY - 1 || strlen (history[histnext]) == 0) { histnext = 0; } } /*! \brief store command in a cyclic buffer \param cmd command to store **/ static void edit_add_history (char *cmd) { if (strlen (cmd) > 0) { histcurr ++; if (histcurr == HISTORY) { histcurr = 0; } bufcpy (history[histcurr], cmd, BUFFER_SIZE); histprev = histnext = histcurr; } } /*! \brief restore history **/ void edit_read_history (DATASET_T *dd) { char nfn[BUFFER_SIZE]; FILE *f = a68g_fopen (A68_HISTORY_FILE, "r", nfn); if (f != NO_FILE) { int k; char *cp; RESET_ERRNO; #define RESTORE_CLR(n, p)\ (void) fgets (input_line, BUFFER_SIZE, f);\ if (errno != 0) {\ ASSERT (fclose (f) == 0);\ return;\ }\ if (input_line[strlen (input_line) - 1] == NEWLINE_CHAR) {\ input_line[strlen (input_line) - 1] = NULL_CHAR;\ }\ cp = strchr (input_line, BLANK_CHAR);\ if (cp == NO_TEXT) {\ return;\ }\ (n) = parse_colour (dd, "edit", &cp[1], (p)); # RESTORE_CLR (pair_arrow, PAIR_ARROW); RESTORE_CLR (pair_cmdline, PAIR_CMDLINE); RESTORE_CLR (pair_control, PAIR_CONTROL); RESTORE_CLR (pair_curline, PAIR_CURLINE); RESTORE_CLR (pair_filearea, PAIR_FILEAREA); RESTORE_CLR (pair_idline, PAIR_IDLINE); RESTORE_CLR (pair_match, PAIR_MATCH); RESTORE_CLR (pair_msgline, PAIR_MSGLINE); RESTORE_CLR (pair_prefix, PAIR_PREFIX); RESTORE_CLR (pair_scale, PAIR_SCALE); RESTORE_CLR (pair_tofeof, PAIR_TOFEOF); #undef RESTORE_CLR if (errno != 0) { ASSERT (fclose (f) == 0); return; } for (k = 0; k < MAX_PF; k++) { (void) fgets (input_line, BUFFER_SIZE, f); if (errno != 0) { ASSERT (fclose (f) == 0); return; } if (input_line[strlen (input_line) - 1] == NEWLINE_CHAR) { input_line[strlen (input_line) - 1] = NULL_CHAR; } cp = strchr (input_line, '='); if (cp != NO_TEXT && (int) strlen (&cp[1]) > 0) { bufcpy (pf_bind[k], &cp[1], BUFFER_SIZE); } else { bufcpy (pf_bind[k], "", BUFFER_SIZE); } } if (errno != 0) { ASSERT (fclose (f) == 0); return; } histcurr = histnext = histprev = -1; while (!feof (f)) { (void) fgets (input_line, BUFFER_SIZE, f); if (errno != 0) { ASSERT (fclose (f) == 0); return; } if (input_line[strlen (input_line) - 1] == NEWLINE_CHAR) { input_line[strlen (input_line) - 1] = NULL_CHAR; } edit_add_history (input_line); } ASSERT (fclose (f) == 0); } else { /* Laissez-passer */ histcurr = histnext = histprev = -1; RESET_ERRNO; } } /*! \brief store history **/ void edit_write_history (void) { char nfn[BUFFER_SIZE]; FILE *f = a68g_fopen (A68_HISTORY_FILE, "w", nfn); if (f != NO_FILE) { int k; write_colour (f, "arrow", pair_arrow, PAIR_ARROW); write_colour (f, "cmdline", pair_cmdline, PAIR_CMDLINE); write_colour (f, "control", pair_control, PAIR_CONTROL); write_colour (f, "curline", pair_curline, PAIR_CURLINE); write_colour (f, "filearea", pair_filearea, PAIR_FILEAREA); write_colour (f, "idline", pair_idline, PAIR_IDLINE); write_colour (f, "match", pair_match, PAIR_MATCH); write_colour (f, "msgline", pair_msgline, PAIR_MSGLINE); write_colour (f, "prefix", pair_prefix, PAIR_PREFIX); write_colour (f, "scale", pair_scale, PAIR_SCALE); write_colour (f, "tofeof", pair_tofeof, PAIR_TOFEOF); for (k = 0; k < MAX_PF; k++) { fprintf (f, "pf%02d=%s\n", k + 1, pf_bind[k]); } for (k = 0; k < histcurr; k ++) { fprintf (f, "%s\n", history[k]); } ASSERT (fclose (f) == 0); } else { /* Laissez-passer */ RESET_ERRNO; } } /*! \brief whether there is space on the heap \param s bytes to allocate \return same **/ static BOOL_T heap_full (int as) { BOOL_T heap_up = (fixed_heap_pointer + as) >= (heap_size - MIN_MEM_SIZE); BOOL_T heap_down = ((int) temp_heap_pointer - (int) (fixed_heap_pointer + as)) <= MIN_MEM_SIZE; return (heap_up || heap_down); } /*! \brief allocate heap space for editor \param dd dataset that allocates \param s bytes to allocate \return pointer to same **/ static BYTE_T *edit_get_heap (DATASET_T *dd, size_t s) { DISPLAY_T *scr = &(DISPLAY (dd)); BYTE_T *z; int as = A68_ALIGN ((int) s); XABEND (heap_is_fluid == A68_FALSE, ERROR_INTERNAL_CONSISTENCY, NO_TEXT); /* If there is no space left, we collect garbage */ if (heap_full (as) && COLLECT (dd)) { edit_garbage_collect (dd, "edit"); } if (heap_full (as)) { ASSERT (snprintf (DL0 (scr), SNPRINTF_SIZE, "edit: out of memory") >= 0); return (NO_BYTE); } /* Allocate space */ z = HEAP_ADDRESS (fixed_heap_pointer); fixed_heap_pointer += as; return (z); } /*! \brief add char to line buffer \param lbuf line buffer \param lsiz size of line buffer \param ch char to add \param pos position to add ch **/ static void add_linbuf (DATASET_T *dd, char ch, int pos) { if (LINBUF (dd) == NO_TEXT || pos >= LINSIZ (dd) - 1) { char *oldb = LINBUF (dd); LINSIZ (dd) += BUFFER_SIZE; LINBUF (dd) = (char *) edit_get_heap (dd, (size_t) (LINSIZ (dd))); XABEND (LINBUF (dd) == NO_TEXT, "Insufficient memory", NO_TEXT); if (oldb == NO_TEXT) { (LINBUF (dd))[0] = NULL_CHAR; } else { bufcpy (LINBUF (dd), oldb, LINSIZ (dd)); } } (LINBUF (dd))[pos] = ch; (LINBUF (dd))[pos + 1] = NULL_CHAR; } /* REGULAR EXPRESSION SUPPORT */ /*! \brief initialise regular expression \param re regexp to initialise **/ static void init_regexp (REGEXP_T *re) { IS_COMPILED (re) = A68_FALSE; PATTERN (re)[0] = NULL_CHAR; MATCH (re) = NO_REGMATCH; NUM_MATCH (re) = 0; } /*! \brief reset regular expression \param re regexp to initialise **/ static void reset_regexp (REGEXP_T *re) { IS_COMPILED (re) = A68_FALSE; PATTERN (re)[0] = NULL_CHAR; if (MATCH (re) != NO_REGMATCH) { free (MATCH (re)); } MATCH (re) = NO_REGMATCH; NUM_MATCH (re) = 0; } /*! \brief compile regular expression \param dd current dataset \param re regexp to compile \param cmd command that calls this routine \return return code **/ static int compile_regexp (DATASET_T *dd, REGEXP_T *re, char *cmd) { DISPLAY_T *scr = &(DISPLAY (dd)); int rc; char buffer[BUFFER_SIZE]; IS_COMPILED (re) = A68_FALSE; rc = regcomp (&(COMPILED (re)), PATTERN (re), REG_EXTENDED | REG_NEWLINE); if (rc != 0) { (void) regerror (rc, &(COMPILED (re)), buffer, BUFFER_SIZE); ASSERT (snprintf (DL0 (scr), SNPRINTF_SIZE, "%s: %s", cmd, buffer) >= 0); regfree (&(COMPILED (re))); return (rc); } else { NUM_MATCH (re) = 1 + RE_NSUB (&COMPILED (re)); MATCH (re) = malloc ((size_t) (NUM_MATCH (re) * sizeof (regmatch_t))); if (MATCH (re) == NO_REGMATCH) { ASSERT (snprintf (DL0 (scr), SNPRINTF_SIZE, "%s: %s", cmd, ERROR_OUT_OF_CORE) >= 0); regfree (&(COMPILED (re))); return (-1); } } IS_COMPILED (re) = A68_TRUE; return (0); } /*! \brief match line to regular expression \param dd current dataset \param fragment whether matching the tail of a string after an earlier match \param cmd command that calls this routine \return whether match **/ static BOOL_T match_regex (DATASET_T *dd, EDLIN_T *z, int eflags, char *cmd) { DISPLAY_T *scr = &(DISPLAY (dd)); int rc1 = REG_NOMATCH, rc2 = REG_NOMATCH; BOOL_T m1 = A68_FALSE, m2 = A68_FALSE; char *str = TEXT (z); /* Match first regex if present */ if (IS_COMPILED (&TARG1 (dd))) { rc1 = regexec (&(COMPILED (&TARG1 (dd))), str, NUM_MATCH (&TARG1 (dd)), MATCH (&TARG1 (dd)), eflags); if (rc1 != 0 && rc1 != REG_NOMATCH) { char buffer[BUFFER_SIZE]; (void) regerror (rc1, &(COMPILED (&TARG1 (dd))), buffer, BUFFER_SIZE); ASSERT (snprintf (DL0 (scr), SNPRINTF_SIZE, "%s: %s", cmd, buffer) >= 0); if (MATCH (&TARG1 (dd)) != NO_REGMATCH) { free (MATCH (&TARG1 (dd))); MATCH (&TARG1 (dd)) = NO_REGMATCH; } return (A68_FALSE); } if (NEGATE (&TARG1 (dd))) { m1 = (rc1 == REG_NOMATCH); } else { m1 = (rc1 != REG_NOMATCH); } } /* Match 2nd regex if present */ if (IS_COMPILED (&TARG2 (dd))) { rc2 = regexec (&(COMPILED (&TARG2 (dd))), str, NUM_MATCH (&TARG2 (dd)), MATCH (&TARG2 (dd)), eflags); if (rc2 != 0 && rc2 != REG_NOMATCH) { char buffer[BUFFER_SIZE]; (void) regerror (rc2, &(COMPILED (&TARG2 (dd))), buffer, BUFFER_SIZE); ASSERT (snprintf (DL0 (scr), SNPRINTF_SIZE, "%s: %s", cmd, buffer) >= 0); if (MATCH (&TARG2 (dd)) != NO_REGMATCH) { free (MATCH (&TARG2 (dd))); MATCH (&TARG2 (dd)) = NO_REGMATCH; } return (A68_FALSE); } if (NEGATE (&TARG2 (dd))) { m2 = (rc2 == REG_NOMATCH); } else { m2 = (rc2 != REG_NOMATCH); } } /* Form a result */ M_MATCH (dd) = NO_EDLIN; M_SO (dd) = M_EO (dd) = -1; if (m1 && !NEGATE (&TARG1 (dd))) { M_MATCH (dd) = z; M_SO (dd) = (int) RM_SO (&(MATCH (&TARG1 (dd))[0])); M_EO (dd) = (int) RM_EO (&(MATCH (&TARG1 (dd))[0])); } else if (m2 && !NEGATE (&TARG2 (dd))) { M_MATCH (dd) = z; M_SO (dd) = (int) RM_SO (&(MATCH (&TARG2 (dd))[0])); M_EO (dd) = (int) RM_EO (&(MATCH (&TARG2 (dd))[0])); } if (OPER (dd) == NULL_CHAR) { return (m1); } else if (OPER (dd) == '|') { return (m1 | m2); } else if (OPER (dd) == '&') { return (m1 & m2); } else if (OPER (dd) == '^') { return (m1 ^ m2); } else { return (A68_FALSE); } } /*! \brief get regular expression from string \param re regular expression structure to use \param str pointer in string to regular expression, set to end upon return \param delim char to store regular expression delimiter **/ static void copy_regexp (REGEXP_T *re, char **str, char *delim) { char *pat = PATTERN (re), *q = *str; if (q[0] == '~') { NEGATE (re) = A68_TRUE; q++; } else { NEGATE (re) = A68_FALSE; } *delim = q[0]; q++; while (q[0] != *delim && q[0] != NULL_CHAR) { if (q[0] == '\\') { int k; BOOL_T found = A68_FALSE; for (k = 0; !found && NAME (®exp_tab[k]) != NO_TEXT; k ++) { if (q[1] == CODE (®exp_tab[k])) { char *r = NAME (®exp_tab[k]); while (*r != NULL_CHAR) { *(pat)++ = *(r)++; } found = A68_TRUE; q += 2; } } if (!found) { *(pat)++ = *q++; *(pat)++ = *q++; } } else { *(pat)++ = *q++; } } pat[0] = NULL_CHAR; *str = q; } /*! \brief get regexp and find target with respect to the current line \param dd current dataset \param cmd command that calls this routine \param arg points to arguments \param rest will point to text after arguments \param compile must compile or has been compiled **/ static EDLIN_T * get_regexp (DATASET_T *dd, char *cmd, char *arg, char **rest, BOOL_T compile) { /* Target is of form [+|-]/regexp/ or [+|-]/regexp/&/regexp/ both must match [+|-]/regexp/|/regexp/ one or both must match [+|-]/regexp/^/regexp/ one must match, but not both */ DISPLAY_T *scr = &(DISPLAY (dd)); char *q, delim; int rc; BOOL_T get_forward; if (compile == A68_FALSE) { if (IS_COMPILED (&(TARG1 (dd))) == A68_FALSE || SEARCH (dd) == 0) { ASSERT (snprintf (DL0 (scr), SNPRINTF_SIZE, "%s: no regular expression", cmd) >= 0); return (NO_EDLIN); } if (SEARCH (dd) == 1) { get_forward = A68_TRUE; } else { get_forward = A68_FALSE; } } else { if (EMPTY_STRING (arg)) { ASSERT (snprintf (DL0 (scr), SNPRINTF_SIZE, "%s: no regular expression", cmd) >= 0); return (NO_EDLIN); } /* Initialise */ reset_regexp (&(TARG1 (dd))); reset_regexp (&(TARG2 (dd))); OPER (dd) = NULL_CHAR; (*rest) = NO_TEXT; SKIP_WHITE (arg); q = arg; if (q[0] == '+') { get_forward = A68_TRUE; q++; } else if (q[0] == '-') { get_forward = A68_FALSE; SEARCH (dd) = -1; q++; } else { get_forward = A68_TRUE; SEARCH (dd) = 1; } /* Get first regexp */ copy_regexp (&TARG1 (dd), &q, &delim); if ((int) strlen (PATTERN (&TARG1 (dd))) == 0) { ASSERT (snprintf (DL0 (scr), SNPRINTF_SIZE, "%s: no regular expression", cmd) >= 0); return (NO_EDLIN); } rc = compile_regexp (dd, &(TARG1 (dd)), cmd); if (rc != 0) { return (NO_EDLIN); } /* Get operator and 2nd regexp, if present */ if (q[0] == delim && (q[1] == '&' || q[1] == '|' || q[1] == '^')) { q++; OPER (dd) = q[0]; q++; copy_regexp (&TARG2 (dd), &q, &delim); if ((int) strlen (PATTERN (&TARG2 (dd))) == 0) { ASSERT (snprintf (DL0 (scr), SNPRINTF_SIZE, "%s: no regular expression", cmd) >= 0); return (NO_EDLIN); } rc = compile_regexp (dd, &(TARG2 (dd)), cmd); if (rc != 0) { return (0); } } if (q[0] == delim) { (*rest) = &(q[1]); SKIP_WHITE (*rest); } else { (*rest) = &(q[0]); SKIP_WHITE (*rest); } } /* Find the first line matching the regex */ if (get_forward) { EDLIN_T *u = CURR (dd); forward_line (&u); if (NOT_EOF (u)) { EDLIN_T *z = u; for (z = u; NOT_EOF (z); forward_line (&z)) { if (match_regex (dd, z, 0, cmd)) { return (z); } } } } else { EDLIN_T *u = CURR (dd); backward_line (&u); if (NOT_TOF (u)) { EDLIN_T *z = u; for (z = u; NOT_TOF (z); backward_line (&z)) { if (match_regex (dd, z, 0, cmd)) { return (z); } } } } ASSERT (snprintf (DL0 (scr), SNPRINTF_SIZE, "%s: not found", cmd) >= 0) return (NO_EDLIN); } /*! \brief get target with respect to the current line \param dd current dataset \param cmd command that calls this routine \param arg points to arguments \param rest will point to text after arguments **/ EDLIN_T *get_target (DATASET_T *dd, char *cmd, char *args, char **rest, BOOL_T offset) { DISPLAY_T *scr = &(DISPLAY (dd)); EDLIN_T *z = NO_EDLIN; SKIP_WHITE (args); if (IS_DIGIT (args[0])) { /* n Relative displacement down */ int n = int_arg (dd, cmd, args, rest, 1); if (n == WRONG_TARGET) { return (NO_EDLIN); } else { int k; for (z = CURR (dd), k = 0; z != NO_EDLIN && k < n; forward_line (&z), k++) {;} if (z == NO_EDLIN) { ASSERT (snprintf (DL0 (scr), SNPRINTF_SIZE, "%s: target beyond end-of-data", cmd) >= 0); } } } else if (args[0] == '+' && IS_DIGIT (args[1])) { /* +n Relative displacement down */ int n = int_arg (dd, cmd, &args[1], rest, 1); if (n == WRONG_TARGET) { return (NO_EDLIN); } else { int k; for (z = CURR (dd), k = 0; z != NO_EDLIN && k < n; forward_line (&z), k++) {;} if (z == NO_EDLIN) { ASSERT (snprintf (DL0 (scr), SNPRINTF_SIZE, "%s: target beyond end-of-data", cmd) >= 0); } } } else if (args[0] == ':') { /*:n Absolute line number */ int n = int_arg (dd, cmd, &args[1], rest, 1); if (n == WRONG_TARGET) { return (NO_EDLIN); } else { for (z = TOF (dd); z != NO_EDLIN && NUMBER (z) != n; forward_line (&z)) {;} if (z == NO_EDLIN) { ASSERT (snprintf (DL0 (scr), SNPRINTF_SIZE, "%s: target outside selected lines", cmd) >= 0); } } } else if (args[0] == '-' && IS_DIGIT (args[1])) { /* -n Relative displacement up */ int n = int_arg (dd, cmd, &args[1], rest, 1); if (n == WRONG_TARGET) { return (NO_EDLIN); } else { int k; for (z = CURR (dd), k = 0; z != NO_EDLIN && k < n; backward_line (&z), k++) {;} if (z == NO_EDLIN) { ASSERT (snprintf (DL0 (scr), SNPRINTF_SIZE, "%s: target before top-of-data", cmd) >= 0); } } } else if (args[0] == '*' || args[0] == '$') { /* * end-of-data */ for (z = TOF (dd); NOT_EOF (z) ; forward_line (&z)) {;} (*rest) = (&args[1]); SKIP_WHITE (*rest); } else if (args[0] == '+' && args[1] == '*') { /* * end-of-data */ for (z = TOF (dd); NOT_EOF (z) ; forward_line (&z)) {;} (*rest) = (&args[2]); SKIP_WHITE (*rest); } else if (args[0] == '-' && args[1] == '*') { /* * top-of-data */ for (z = CURR (dd); NOT_TOF (z); backward_line (&z)) {;} (*rest) = (&args[2]); SKIP_WHITE (*rest); } else if (args[0] == '.') { /* .IDF Prefix identifier */ EDLIN_T *u; char idf[8] = {'.', NULL_CHAR, NULL_CHAR, NULL_CHAR, NULL_CHAR, NULL_CHAR, NULL_CHAR, NULL_CHAR}; int k; for (k = 1; IS_ALNUM (args[k]) && k < MARGIN - 1; k++) { idf[k] = args[k]; } (*rest) = (&args[k]); SKIP_WHITE (*rest); /* Scan all file to check multiple definitions */ for (u = TOF (dd), z = NO_EDLIN; u != NO_EDLIN; forward_line (&u)) { char *v = PRECMD (u); SKIP_WHITE (v); if (strncmp (v, idf, (size_t) (k - 1)) == 0) { if (z != NO_EDLIN) { ASSERT (snprintf (DL0 (scr), SNPRINTF_SIZE, "%s: multiple targets %s", cmd, idf) >= 0); return (NO_EDLIN); } else { z = u; } } } if (z == NO_EDLIN) { ASSERT (snprintf (DL0 (scr), SNPRINTF_SIZE, "%s: no target %s", cmd, idf) >= 0); } } else if (args[0] == '/') { z = get_regexp (dd, cmd, args, rest, A68_TRUE); } else if (args[0] == '~' && args[1] == '/') { z = get_regexp (dd, cmd, args, rest, A68_TRUE); } else if (args[0] == '-' && args[1] == '/') { z = get_regexp (dd, cmd, args, rest, A68_TRUE); } else if (args[0] == '+' && args[1] == '/') { z = get_regexp (dd, cmd, args, rest, A68_TRUE); } else if (args[0] == '-' && args[1] == '~' && args[2] == '/') { z = get_regexp (dd, cmd, args, rest, A68_TRUE); } else if (args[0] == '+' && args[1] == '~' && args[2] == '/') { z = get_regexp (dd, cmd, args, rest, A68_TRUE); } else { ASSERT (snprintf (DL0 (scr), SNPRINTF_SIZE, "%s: unrecognised target syntax", cmd) >= 0); return (NO_EDLIN); } /* A target can have an offset +-m */ if (!offset) { return (z); } args = *rest; if (args != NO_TEXT && args[0] == '+' && IS_DIGIT (args[1])) { /* +n Relative displacement down */ int n = int_arg (dd, cmd, &args[1], rest, 1); if (n == WRONG_TARGET) { return (NO_EDLIN); } else { int k; for (k = 0; z != NO_EDLIN && k < n; forward_line (&z), k++) {;} if (z == NO_EDLIN) { ASSERT (snprintf (DL0 (scr), SNPRINTF_SIZE, "%s: target beyond end-of-data", cmd) >= 0); } } } else if (args != NO_TEXT && args[0] == '-' && IS_DIGIT (args[1])) { /* -n Relative displacement up */ int n = int_arg (dd, cmd, &args[1], rest, 1); if (n == WRONG_TARGET) { return (NO_EDLIN); } else { int k; for (k = 0; z != NO_EDLIN && k < n; backward_line (&z), k++) {;} if (z == NO_EDLIN) { ASSERT (snprintf (DL0 (scr), SNPRINTF_SIZE, "%s: target before top-of-data", cmd) >= 0); } } } return (z); } /* \brief calculate positions to next tab stop \param pos where are we now \param tabs tab stop setting \return number of blanks to next stop **/ static int tab_reps (int pos, int tabs) { int disp = pos % tabs; return (tabs - disp); } /* \brief whether in a reserved row \param dd current dataset \return same **/ static BOOL_T reserved_row (DATASET_T *dd, int row) { DISPLAY_T *scr = &(DISPLAY (dd)); return (row == CMD_ROW (scr) || row == SCALE_ROW (scr) || row == IDF_ROW (scr)); } /*! \brief count reserved lines on screen \param dd current dataset \return same **/ static int count_reserved (DATASET_T *dd) { int k, n = 0; for (k = 0; k < LINES; k++) { if (reserved_row (dd, k)) { n++; } } return (n); } /*! \brief lines on screen for a line - account for tabs \param dd current dataset \param lin line to count \return same **/ static int lines_on_scr (DATASET_T *dd, EDLIN_T * lin) { int k = 0, row = 1, col = MARGIN; char *txt = TEXT (lin); while (txt[k] != NULL_CHAR) { int reps, n; if (txt[k] == '\t') { reps = tab_reps (col - MARGIN, TABS (dd)); } else { reps = 1; } for (n = 0; n < reps; n++) { if (col >= COLS) { row++; col = MARGIN; } col++; } k++; } if (col >= COLS) { row++; col = MARGIN; } return (row); } /*! \brief initialise curses \param dd current dataset **/ static void edit_init_curses (DATASET_T *dd) { DISPLAY_T *scr = &(DISPLAY (dd)); CURSOR_T *curs = &(CURS (scr)); (void) initscr (); (void) raw (); #if defined HAVE_WIN32 (void) keypad (stdscr, TRUE); (void) noecho (); (void) nonl (); (void) meta (stdscr, TRUE); #else EDIT_TEST (keypad (stdscr, TRUE) != ERR); EDIT_TEST (noecho () != ERR); EDIT_TEST (nonl () != ERR); EDIT_TEST (meta (stdscr, TRUE) != ERR); #endif /* defined HAVE_WIN32 */ #if defined USE_MOUSE (void) mousemask ((mmask_t) ALL_MOUSE_EVENTS, NULL); #endif /* defined USE_MOUSE */ EDIT_TEST (curs_set (1) != ERR); SCALE_ROW (scr) = LINES / 2; CMD_ROW (scr) = 1; IDF_ROW (scr) = 0; CURSOR_TO_COMMAND (dd, curs); REDRAW; M_MATCH (dd) = NO_EDLIN; M_SO (dd) = -1; M_EO (dd) = -1; } /*! \brief read a buffer from file \param fd file to read from \param buffer buffer to store line \return same **/ int get_buffer (FILE_T fd, char *buffer) { int bytes; RESET_ERRNO; bytes = (int) io_read (fd, buffer, (size_t) BUFFER_SIZE); return (bytes); } /*! \brief generate a new line \param dd current dataset \return new line **/ EDLIN_T *new_line (DATASET_T *dd) { EDLIN_T *newl = (EDLIN_T *) edit_get_heap (dd, (size_t) sizeof (EDLIN_T)); if (newl == NO_EDLIN) { return (NO_EDLIN); } PRECMD (newl)[0] = NULL_CHAR; SELECT (newl) = A68_TRUE; NEXT (newl) = NO_EDLIN; PREVIOUS (newl) = NO_EDLIN; TEXT (newl) = NO_TEXT; NUMBER (newl) = 0; MODIFIED (newl) = A68_FALSE; return (newl); } /*! \brief mark line as altered \param dd current dataset \return new line **/ static void alt_line (DATASET_T *dd, EDLIN_T *z) { if (!MODIFIED (z)) { MODIFIED (z) = A68_TRUE; ALTS (dd)++; } M_MATCH (dd) = NO_EDLIN; M_SO (dd) = M_EO (dd) = -1; } /*! \brief forward line, folded or not \param z line to forward **/ static void forward_line (EDLIN_T **z) { if (*z == NO_EDLIN) { return; } do { FORWARD (*z); } while (*z != NO_EDLIN && ! (SELECT (*z) || NUMBER (*z) == 0)); } /*! \brief backward line, folded or not \param z line to "backward" **/ static void backward_line (EDLIN_T **z) { if (*z == NO_EDLIN) { return; } do { BACKWARD (*z); } while (*z != NO_EDLIN && ! (SELECT (*z) || NUMBER (*z) == 0)); } /*! \brief align current line, cannot be TOF or EOF \param dd current dataset **/ static void align_current (DATASET_T *dd) { DISPLAY_T *scr = &(DISPLAY (dd)); if (IS_TOF (CURR (dd))) { EDLIN_T *z = CURR (dd); forward_line (&z); if (NOT_EOF (z)) { NEW_CURR (dd, z); } } else if (IS_EOF (CURR (dd))) { if (IS_TOF (PREVIOUS (CURR (dd)))) { NEW_CURR (dd, TOF (dd)); } else { EDLIN_T *z = CURR (dd); backward_line (&z); NEW_CURR (dd, z); } } } /*! \brief generate a new string for a line \param dd current dataset \param l line to add string to \param txt text to store in string \param eat pointer to old lines, use string if fits **/ static void new_edit_string (DATASET_T *dd, EDLIN_T *l, char *txt, EDLIN_T *eat) { if (txt == NO_TEXT || strlen(txt) == 0) { RESERVED (l) = 1; TEXT (l) = (char *) edit_get_heap (dd, (size_t) RESERVED (l)); TEXT (l)[0] = NULL_CHAR; bufcpy (PRECMD (l), BLANK, (int) (strlen (BLANK) + 1)); } else { int res = 1 + (int) strlen (txt); if (res % BLOCK_SIZE > 0) { res += (BLOCK_SIZE - res % BLOCK_SIZE); } if (eat != NO_EDLIN && RESERVED (eat) >= res) { RESERVED (l) = RESERVED (eat); TEXT (l) = TEXT (eat); } else { RESERVED (l) = res; TEXT (l) = (char *) edit_get_heap (dd, (size_t) res); } if (TEXT (l) == NO_TEXT) { return; } bufcpy (TEXT (l), txt, res); bufcpy (PRECMD (l), BLANK, (int) (strlen (BLANK) + 1)); } } /*! \brief set prefix to line \param l line to set **/ static void set_prefix (EDLIN_T *l) { bufcpy (PRECMD (l), BLANK, (int) (strlen (BLANK) + 1)); } /*! \brief reset prefixes to original state \param dd current dataset **/ static void edit_reset (DATASET_T *dd) { int k = 0; EDLIN_T *z; for (z = TOF (dd); z != NO_EDLIN; FORWARD (z)) { if (NUMBER (z) != 0) { k++; NUMBER (z) = k; } set_prefix (z); } SIZE (dd) = k; } /*! \brief delete to end of line \param dd current dataset **/ static void cdelete (DATASET_T *dd) { DISPLAY_T *scr = &(DISPLAY (dd)); CURSOR_T *curs = &(CURS (scr)); EDLIN_T *lin = LINE (curs); if (lin != NO_EDLIN && INDEX (curs) < (int) strlen (TEXT (lin))) { TEXT (lin)[INDEX (curs)] = NULL_CHAR; } } /*! \brief split line at cursor position \param dd current dataset \param cmd command that calls this routine **/ static void split_line (DATASET_T *dd, char *cmd) { /* We reset later so this routine can be repeated cheaply */ DISPLAY_T *scr = &(DISPLAY (dd)); CURSOR_T *curs = &(CURS (scr)); EDLIN_T *lin = LINE (curs), *newl; if (NEXT (lin) == NO_EDLIN) { ASSERT (snprintf (DL0 (scr), SNPRINTF_SIZE, "%s: cannot split line", cmd) >= 0); return; } BL_START (dd) = BL_END (dd) = NO_EDLIN; ALTS (dd)++; SIZE (dd)++; /* Insert a new line */ REDRAW; newl = new_line (dd); if (newl == NO_EDLIN) { return; } if ((INDEX (curs) < (int) strlen (TEXT (lin))) && IS_IN_TEXT (lin)) { new_edit_string (dd, newl, &(TEXT (lin)[INDEX (curs)]), NO_EDLIN); if (TEXT (newl) == NO_TEXT) { return; } TEXT (lin)[INDEX (curs)] = NULL_CHAR; } else { new_edit_string (dd, newl, "", NO_EDLIN); if (TEXT (newl) == NO_TEXT) { return; } } PREVIOUS (newl) = lin; NEXT (newl) = NEXT (lin); NEXT (lin) = newl; PREVIOUS (NEXT (newl)) = newl; NUMBER (newl) = NUMBER (lin) + 1; /* Position the cursor at the start of the new line */ SYNC_INDEX (curs) = 0; SYNC_LINE (curs) = newl; SYNC (curs) = A68_TRUE; if (lin == LAST_LINE (scr)) { forward_line (&CURR (dd)); } } /*! \brief join line with next one \param dd current dataset \param cmd command that calls this **/ static void join_line (DATASET_T *dd, char *cmd) { /* We reset later so this routine can be repeated cheaply */ DISPLAY_T *scr = &(DISPLAY (dd)); CURSOR_T *curs = &(CURS (scr)); EDLIN_T *lin = LINE (curs), *prv, *u; int len, lcur, lprv; if (NUMBER (lin) == 0) { ASSERT (snprintf (DL0 (scr), SNPRINTF_SIZE, "%s: cannot join line", cmd) >= 0); return; } REDRAW; BL_START (dd) = BL_END (dd) = NO_EDLIN; prv = PREVIOUS (lin); ALTS (dd)++; SIZE (dd)--; /* Join line with the previous one */ if (prv == TOF (dd)) { /* Express case */ NEXT (TOF (dd)) = NEXT (lin); PREVIOUS (NEXT (prv)) = prv; SYNC_INDEX (curs) = 0; SYNC_LINE (curs) = TOF (dd); SYNC (curs) = A68_TRUE; return; } lcur = (int) strlen (TEXT (lin)); lprv = (int) strlen (TEXT (prv)); len = lcur + lprv; if (RESERVED (prv) <= len + 1) { /* Not enough room */ int res = len + 1; char *txt = TEXT (prv); if (res % BLOCK_SIZE > 0) { res += (BLOCK_SIZE - res % BLOCK_SIZE); } RESERVED (prv) = res; TEXT (prv) = (char *) edit_get_heap (dd, (size_t) res); if (TEXT (prv) == NO_TEXT) { return; } bufcpy (TEXT (prv), txt, res); } /* Delete the current line */ bufcat (TEXT (prv), TEXT (lin), len + 1); NEXT (prv) = NEXT (lin); PREVIOUS (NEXT (prv)) = prv; /* Position the cursor at the the new line on the screen */ u = lin; backward_line (&u); if (u == NO_EDLIN) { u = TOF (dd); } if (CURR (dd) == lin) { NEW_CURR (dd, u); } SYNC_LINE (curs) = u; if (IS_IN_TEXT (u)) { if (u == prv) { SYNC_INDEX (curs) = lprv; } else { SYNC_INDEX (curs) = (int) strlen (TEXT (u)); } } else { SYNC_INDEX (curs) = 0; } SYNC (curs) = A68_TRUE; } /*! \brief read a file into a dataset \param dd current dataset \param cmd command that calls this routine \param fname file name \param eat old dataset lines to consume **/ static void edit_read (DATASET_T * dd, char *cmd, char *fname, EDLIN_T *eat) { DISPLAY_T *scr = &(DISPLAY (dd)); CURSOR_T *curs = &(CURS (scr)); FILE_T fd; int total = 0, bytes, posl; char ch; EDLIN_T *curr = CURR (dd); /* Open the file */ RESET_ERRNO; if ((int) strlen (fname) > 0) { fd = open (fname, A68_READ_ACCESS); } else { ASSERT (snprintf (DL0 (scr), SNPRINTF_SIZE, "%s: cannot open file for reading", cmd) >= 0); CURSOR_TO_COMMAND (dd, curs); return; } CHECK_ERRNO (cmd); /* Reading ... */ posl = 0; total = 0; while (A68_TRUE) { bytes = (int) io_read (fd, &ch, 1); if (bytes != 1 && total == 0) { goto end; } total ++; if (bytes != 1 || ch == NEWLINE_CHAR) { /* Link line */ LINE (curs) = curr; INDEX (curs) = (int) strlen (TEXT (curr)); split_line (dd, cmd); FORWARD (curr); if (eat != NO_EDLIN) { new_edit_string (dd, curr, LINBUF (dd), eat); FORWARD (eat); } else { new_edit_string (dd, curr, LINBUF (dd), curr); } if (bytes != 1) { goto end; } if (TEXT (curr) == NO_TEXT) { ASSERT (close (fd) == 0); return; } /* Reinit line buffer */ posl = 0; if (LINBUF (dd) != NO_TEXT) { (LINBUF (dd))[0] = NULL_CHAR; } } else { add_linbuf (dd, ch, posl); if (LINBUF (dd) == NO_TEXT) { ASSERT (close (fd) == 0); return; } posl++; } } end: ASSERT (close (fd) == 0); edit_reset (dd); BL_START (dd) = BL_END (dd) = NO_EDLIN; align_current (dd); } /*! \brief first read of a file \param dd current dataset \param cmd command that calls this routine **/ static void edit_read_initial (DATASET_T * dd, char *cmd) { DISPLAY_T *scr = &(DISPLAY (dd)); CURSOR_T *curs = &(CURS (scr)); FILE_T fd; EDLIN_T *curr = NO_EDLIN, *eof_dd = NO_EDLIN; struct stat statbuf; /* Initialisations */ CMD (scr)[0] = NULL_CHAR; init_regexp (&(TARG1 (dd))); init_regexp (&(TARG2 (dd))); init_regexp (&(FIND (dd))); init_regexp (&(REPL (dd))); SUBSET (dd) = A68_FALSE; ALTS (dd) = 0; INDEX (curs) = 0; /* Add TOF */ TOF (dd) = new_line (dd); if (TOF (dd) == NO_EDLIN) { return; } new_edit_string (dd, TOF (dd), TOPSTR, NO_EDLIN); if (TEXT (TOF (dd)) == NO_TEXT) { return; } NUMBER (TOF (dd)) = 0; set_prefix (TOF (dd)); /* Add EOF */ curr = new_line (dd); if (curr == NO_EDLIN) { return; } new_edit_string (dd, curr, BOTSTR, NO_EDLIN); if (TEXT (curr) == NO_TEXT) { return; } NUMBER (curr) = 0; set_prefix (curr); PREVIOUS (curr) = TOF (dd); NEXT (TOF (dd)) = curr; NEW_CURR (dd, TOF (dd)); eof_dd = curr; /* Open the file */ RESET_ERRNO; if ((int) strlen (NAME (dd)) > 0) { fd = open (NAME (dd), A68_READ_ACCESS); } else { fd = -1; } if (fd == -1) { char datestr[BUFFER_SIZE]; time_t rt; struct tm *tm; if (errno != 0) { ASSERT (snprintf (DL0 (scr), SNPRINTF_SIZE, "%s: %s", cmd, error_specification ()) >= 0); } else { ASSERT (snprintf (DL0 (scr), SNPRINTF_SIZE, "%s: creating new file", cmd) >= 0); } SIZE (dd) = 0; PERMS (dd) = A68_PROTECTION; NEW_FILE (dd) = A68_TRUE; /* Link one empty line just as a read of an empty file would do nl = new_line (dd); if (nl != NO_EDLIN) { NEXT (nl) = eof_dd; PREVIOUS (eof_dd) = nl; NEXT (TOF (dd)) = nl; PREVIOUS (nl) = TOF (dd); NEW_CURR (dd, nl); } */ ASSERT (time (&rt) != (time_t) (-1)); ASSERT ((tm = localtime (&rt)) != NULL); ASSERT ((strftime (datestr, BUFFER_SIZE, DATE_STRING, tm)) > 0); ASSERT (snprintf (DATE (dd), SNPRINTF_SIZE, "%s", datestr) >= 0); CURSOR_TO_COMMAND (dd, curs); return; } CHECK_ERRNO (cmd); /* Collect file information; we display file date and permissions */ NEW_FILE (dd) = A68_FALSE; if (stat (NAME (dd), &statbuf) != -1) { struct tm *tm; char datestr[BUFFER_SIZE]; PERMS (dd) = ST_MODE (&statbuf); ASSERT ((tm = localtime (&ST_MTIME (&statbuf))) != NULL); ASSERT ((strftime (datestr, BUFFER_SIZE, DATE_STRING, tm)) > 0); ASSERT (snprintf (DATE (dd), SNPRINTF_SIZE, "%s", datestr) >= 0); } /* Set up for reading */ edit_read (dd, cmd, NAME (dd), NO_EDLIN); ALTS (dd) = 0; /* Again, since edit_read inserts lines! */ NEW_CURR (dd, NEXT (TOF (dd))); } /*! \brief write dataset to file \param dd current dataset \param cmd command that calls this routine \param fname file name \param u first line to write \param v write upto, but not including, this line **/ static void edit_write (DATASET_T * dd, char *cmd, char *fname, EDLIN_T *u, EDLIN_T *v) { DISPLAY_T *scr = &(DISPLAY (dd)); CURSOR_T *curs = &(CURS (scr)); FILE_T fd; EDLIN_T *curr; /* Backwards range */ if (NOT_EOF (v) && (NUMBER (v) < NUMBER (u))) { ASSERT (snprintf (DL0 (scr), SNPRINTF_SIZE, "%s: backward range", cmd) >= 0); CURSOR_TO_COMMAND (dd, curs); return; } /* Open the file */ RESET_ERRNO; fd = open (fname, A68_WRITE_ACCESS, A68_PROTECTION); CHECK_ERRNO (cmd); if (fd == -1) { ASSERT (snprintf (DL0 (scr), SNPRINTF_SIZE, "%s: cannot open file for writing", cmd) >= 0); return; } for (curr = u; curr != v; FORWARD (curr)) { if (IS_IN_TEXT (curr)) { if ((int) strlen (TEXT (curr)) > 0) { WRITE (fd, TEXT (curr)); } if (NEXT (curr) != NO_EDLIN && NOT_EOF (NEXT (curr))) { WRITE (fd, "\n"); } } } RESET_ERRNO; ASSERT (close (fd) == 0); CHECK_ERRNO (cmd); } /*! \brief write a file for recovery \param dd current dataset \param cmd command that calls this routine **/ static void edit_write_undo_file (DATASET_T * dd, char *cmd) { if ((UNDO (dd))[0] == NULL_CHAR) { return; } edit_write (dd, cmd, UNDO (dd), TOF (dd), NO_EDLIN); UNDO_LINE (dd) = NUMBER (CURR (dd)); } /*! \brief read a file for recovery \param dd current dataset \param cmd command that calls this routine **/ static void edit_read_undo_file (DATASET_T *dd, char *cmd) { FILE_T fd; struct stat statbuf; DISPLAY_T *scr = &(DISPLAY (dd)); CURSOR_T *curs = &(CURS (scr)); if ((UNDO (dd))[0] == NULL_CHAR) { return; } RESET_ERRNO; fd = open (UNDO (dd), A68_READ_ACCESS); if (fd == -1 || errno != 0) { ASSERT (snprintf (DL0 (scr), SNPRINTF_SIZE, "%s: cannot recover", cmd) >= 0); return; } else { EDLIN_T *eat = NO_EDLIN, *curr; if (TOF (dd) != NO_EDLIN) { eat = NEXT (TOF (dd)); } ASSERT (close (fd) == 0); SUBSET (dd) = A68_FALSE; INDEX (curs) = 0; TOF (dd) = new_line (dd); if (TOF (dd) == NO_EDLIN) { return; } new_edit_string (dd, TOF (dd), TOPSTR, NO_EDLIN); if (TEXT (TOF (dd)) == NO_TEXT) { return; } NUMBER (TOF (dd)) = 0; set_prefix (TOF (dd)); curr = new_line (dd); if (curr == NO_EDLIN) { return; } new_edit_string (dd, curr, BOTSTR, NO_EDLIN); if (TEXT (curr) == NO_TEXT) { return; } NUMBER (curr) = 0; set_prefix (curr); PREVIOUS (curr) = TOF (dd); NEXT (TOF (dd)) = curr; NEW_CURR (dd, TOF (dd)); edit_read (dd, cmd, UNDO (dd), eat); if (stat (UNDO (dd), &statbuf) != -1) { struct tm *tm; char datestr[BUFFER_SIZE]; PERMS (dd) = ST_MODE (&statbuf); ASSERT ((tm = localtime (&ST_MTIME (&statbuf))) != NULL); ASSERT ((strftime (datestr, BUFFER_SIZE, DATE_STRING, tm)) > 0); ASSERT (snprintf (DL0 (scr), SNPRINTF_SIZE, "%s: %s restored to state at %s", cmd, NAME (dd), datestr) >= 0); } if (remove (UNDO (dd)) != 0) { ASSERT (snprintf (DL0 (scr), SNPRINTF_SIZE, "%s: %s", cmd, ERROR_FILE_SCRATCH) >= 0); bufcpy (CMD (scr), "", BUFFER_SIZE); CURSOR_TO_COMMAND (dd, curs); } else { char cmd2[BUFFER_SIZE]; ASSERT (snprintf (cmd2, SNPRINTF_SIZE, ":%d", UNDO_LINE (dd)) >= 0); set_current (dd, cmd, cmd2); align_current (dd); bufcpy (CMD (scr), "", BUFFER_SIZE); CURSOR_TO_COMMAND (dd, curs); } return; } } /*! \brief garbage collector for the editor \param dd current dataset \param cmd current command under execution **/ static void edit_garbage_collect (DATASET_T *dd, char *cmd) { RESET_ERRNO; edit_write_undo_file (dd, cmd); if (errno != 0) { return; } fixed_heap_pointer = HEAP_POINTER (dd); TOF (dd) = NO_EDLIN; LINBUF (dd) = NO_TEXT; LINSIZ (dd) = 0; edit_read_undo_file (dd, cmd); return; } /*! \brief put character on screen \param row current row on screen \param col current col on screen \param ch character to put \param dd current dataset \param dd_line current text line \param dd_index current index in text (of ch) **/ static void edit_putch (int row, int col, char ch, DATASET_T *dd, EDLIN_T *dd_line, int dd_index) { DISPLAY_T *scr = &(DISPLAY (dd)); CURSOR_T *curs = &(CURS (scr)); BOOL_T forbidden = reserved_row (dd, row); BOOL_T text_area = (!forbidden) && col >= MARGIN; BOOL_T prefix_area = (!forbidden) && col < MARGIN; int rc; if (row < 0 || row >= LINES) { return; } if (IS_CNTRL (ch)) { ch = '*'; } if (col < 0 || col >= COLS) { return; } if (row == CMD_ROW (scr) && ROW (curs) == row) { if (COL (curs) < MARGIN) { IN_FORBIDDEN (curs) = A68_TRUE; IN_TEXT (curs) = A68_FALSE; IN_PREFIX (curs) = A68_FALSE; IN_CMD (curs) = A68_FALSE; } else { IN_CMD (curs) = A68_TRUE; IN_TEXT (curs) = A68_FALSE; IN_PREFIX (curs) = A68_FALSE; if (COL (curs) == col) { INDEX (curs) = dd_index; } } LINE (curs) = NO_EDLIN; } else if (forbidden && ROW (curs) == row) { IN_FORBIDDEN (curs) = A68_TRUE; LINE (curs) = NO_EDLIN; } else if (text_area && SYNC (curs) && SYNC_LINE (curs) == dd_line && SYNC_INDEX (curs) == dd_index) { ROW (curs) = row; COL (curs) = col; SYNC (curs) = A68_FALSE; IN_TEXT (curs) = A68_TRUE; IN_PREFIX (curs) = A68_FALSE; IN_CMD (curs) = A68_FALSE; INDEX (curs) = dd_index; LINE (curs) = dd_line; } else if (text_area && ROW (curs) == row && COL (curs) == col) { IN_TEXT (curs) = A68_TRUE; IN_PREFIX (curs) = A68_FALSE; IN_CMD (curs) = A68_FALSE; INDEX (curs) = dd_index; if (dd_line != NO_EDLIN) { LINE (curs) = dd_line; } } else if (prefix_area && ROW (curs) == row && COL (curs) == col) { IN_TEXT (curs) = A68_FALSE; IN_CMD (curs) = A68_FALSE; IN_PREFIX (curs) = A68_TRUE; INDEX (curs) = dd_index; if (dd_line != NO_EDLIN) { LINE (curs) = dd_line; } } EDIT_TEST (wmove (stdscr, row, col) != ERR); rc = waddch (stdscr, (chtype) ch); EDIT_TEST (rc != ERR || (row == (LINES - 1) && col == (COLS - 1))); EDIT_TEST (wmove (stdscr, row, col) != ERR); } /*! \brief draw the screen \param dd current dataset **/ static void edit_draw (DATASET_T *dd) { DISPLAY_T *scr = &(DISPLAY (dd)); CURSOR_T *curs = &(CURS (scr)); EDLIN_T *run, *tos, *lin = NO_EDLIN, *z; int row, k, virt_scal, lin_abo, lin_dif, col_width = 0; char *prompt = PROMPT; BOOL_T redraw = A68_FALSE; /* Initialisations */ if (SIZE (dd) == 0) { CURR (dd) = TOF (dd); } if (LINE (curs) != NO_EDLIN) { LAST (curs) = LINE (curs); } LINE (curs) = NO_EDLIN; IN_FORBIDDEN (curs) = IN_PREFIX (curs) = IN_TEXT (curs) = IN_CMD (curs) = A68_FALSE; /* We locate the top-of-screen with respect to the current line */ if (SCALE_ROW (scr) > 0 && SCALE_ROW (scr) < LINES) { virt_scal = SCALE_ROW (scr); } else { int res = count_reserved (dd); virt_scal = res / 2 + (LINES - res) / 2; } /* How many lines above the scale ? */ for (k = 0, lin_abo = 0; k < virt_scal; k ++) { if (reserved_row (dd, k)) { lin_abo++; } } for (z = CURR (dd); z != NO_EDLIN && lin_abo < virt_scal; ) { if (z == CURR (dd)) { lin_abo ++; } else { lin_abo += lines_on_scr (dd, z); } if (lin_abo < virt_scal) { backward_line (&z); } } if (z == NO_EDLIN) { run = TOF (dd); } else { run = z; } tos = run; lin_dif = virt_scal - lin_abo; /* We now raster the screen - first reserved rows */ for (row = 0; row < LINES; ) { /* COMMAND ROW - ====> Forward */ if (row == CMD_ROW (scr)) { int col = 0, ind = 0; set_colour (pair_arrow); for (ind = 0; ind < MARGIN; ind++) { edit_putch (row, col, prompt[ind], dd, NO_EDLIN, 0); col++; } /* Set initial cursor position at start up */ if (ROW (curs) == -1) { ROW (curs) = row; COL (curs) = col; } /* Show command */ set_colour (pair_cmdline); for (ind = 0; ind < TEXT_WIDTH && IS_PRINT (CMD (scr)[ind]); ind++) { edit_putch (row, col, CMD (scr)[ind], dd, NO_EDLIN, ind); col++; } for (ind = col; ind < COLS; col++, ind++) { edit_putch (row, col, BLANK_CHAR, dd, NO_EDLIN, ind - MARGIN); } row++; } else { row++; } } /* Draw text lines */ for (row = 0; row < LINES; ) { if (reserved_row (dd, row)) { row++; } else { /* Raster a text line */ BOOL_T cont; LAST_LINE (scr) = run; if (run == NO_EDLIN) { /* Draw blank line to balance the screen */ int col; set_colour (pair_filearea); for (col = 0; col < COLS; col++) { edit_putch (row, col, BLANK_CHAR, dd, NO_EDLIN, col); } row++; } else if (lin_dif > 0) { /* Draw blank line to balance the screen */ int col; set_colour (pair_filearea); for (col = 0; col < COLS; col++) { edit_putch (row, col, BLANK_CHAR, dd, NO_EDLIN, col); } lin_dif--; row++; } else if (TEXT (run) == NO_TEXT) { row++; } else { int col = 0, ind = 0, conts = 0; char *txt = TEXT (run); /* Draw prefix */ int pn = NUMBER (run) % 1000000; char *pdigits = "0123456789"; char prefix[MARGIN + 1]; prefix[MARGIN] = NULL_CHAR; prefix[MARGIN - 1] = BLANK_CHAR; if (ROW (curs) == row) { lin = run; } if (NUMBER (run) == 0) { bufcpy (prefix, PREFIX, (strlen (PREFIX) + 1)); } else { /* Next is a cheap print int */ int pk; for (pk = MARGIN - 2; pk >= 0; pk--) { prefix[pk] = pdigits[pn % 10]; pn /= 10; } for (pk = 0; pk < MARGIN - 2 && prefix[pk] == '0'; pk ++) { /* prefix[pk] = BLANK_CHAR; */ } } set_colour (pair_prefix); for (ind = 0; ind < MARGIN; ind++) { char chc = PRECMD (run)[ind], chp = prefix[ind]; if (chc == BLANK_CHAR) { edit_putch (row, col, chp, dd, run, ind); } else { edit_putch (row, col, chc, dd, run, ind); } col++; } if (ROW (curs) == row) { lin = run; } set_colour (NUMBER (run) == 0 ? pair_tofeof : (run == CURR (dd) ? pair_curline : pair_filearea)); /* Draw text */ ind = 0; cont = A68_TRUE; while (cont) { int reps, n; char ch; if (txt[ind] == '\t') { ch = BLANK_CHAR; reps = tab_reps (col - MARGIN, TABS (dd)); } else { cont = (txt[ind] != NULL_CHAR); ch = (char) TO_UCHAR (cont ? txt[ind] : (char) BLANK_CHAR); reps = 1; } for (n = 0; n < reps; n++) { /* Take new line if needed, if lines are left */ if (col == COLS) { int num; char connum[MARGIN + 16]; char *digits = "0123456789"; k = row; if (lin_dif < 0) { lin_dif++; } else { do { row++; } while (reserved_row (dd, row)); } if (row >= LINES) { row = k; goto text_end; } if (ROW (curs) == row) { lin = run; } /* Write a continuation number in the prefix area */ conts++; connum[MARGIN - 1] = BLANK_CHAR; for (num = conts, k = MARGIN - 2; k >= 0; k--) { connum[k] = digits[num % 10]; num = num / 10; } for (k = 0; k < MARGIN - 2 && connum[k] == '0'; k ++) { connum[k] = ' '; } connum[0] = '+'; col = 0; set_colour (pair_prefix); for (k = 0; k < MARGIN; k++) { edit_putch (row, col, connum[k], dd, run, k); col++; } set_colour (NUMBER (run) == 0 ? pair_tofeof : (run == CURR (dd) ? pair_curline : pair_filearea)); } /* Put the character */ if (!IS_PRINT (ch)) { char nch = (char) TO_UCHAR ((int) 0x40 + (int) ch); set_colour (pair_control); if (IS_PRINT (nch)) { edit_putch (row, col, nch, dd, run, ind); col++; } else { edit_putch (row, col, '*', dd, run, ind); col++; } set_colour (NUMBER (run) == 0 ? pair_tofeof : (run == CURR (dd) ? pair_curline : pair_filearea)); } else if (IS_TOF (run) || IS_EOF (run)) { edit_putch (row, col, ch, dd, run, ind); col++; } else if (run == CURR (dd)) { if (run == M_MATCH (dd)) { if (ind == M_SO (dd)) { ROW (curs) = row; COL (curs) = col; } if (ind > M_SO (dd) && ind < M_EO (dd)) { set_colour (pair_match); edit_putch (row, col, ch, dd, run, ind); col++; } else { set_colour (NUMBER (run) == 0 ? pair_tofeof : (run == CURR (dd) ? pair_curline : pair_filearea)); edit_putch (row, col, ch, dd, run, ind); col++; } } else { edit_putch (row, col, ch, dd, run, ind); col++; } } else { edit_putch (row, col, ch, dd, run, ind); col++; } } if (ind > col_width) { col_width = ind; } ind++; } /* Fill the line */ text_end: for (k = col; k < COLS; k++, col++, ind++) { edit_putch (row, col, BLANK_CHAR, dd, run, ind); } if (ROW (curs) == row) { lin = run; } forward_line (&run); row++; } } } /* Write the scale row now all data is complete */ for (row = 0; row < LINES; ) { if (row == SCALE_ROW (scr)) { /* SCALE ROW - ----+----1----+----2 */ int col = 0, ind = 0; set_colour (pair_scale); for (ind = 0; ind < MARGIN - 1; ind++) { edit_putch (row, col, BLANK_CHAR, dd, NO_EDLIN, 0); col++; } edit_putch (row, col, BLANK_CHAR, dd, NO_EDLIN, ind); col++; /* Scale */ for (ind = 0; ind < TEXT_WIDTH; ind++) { k = ind + 1; if (k % 10 == 0) { char *digits = "0123456789"; edit_putch (row, col, digits[(k % 100) / 10], dd, NO_EDLIN, 0); } else if (k % TAB_STOP == 1) { edit_putch (row, col, ':', dd, NO_EDLIN, 0); } else if (k % 5 == 0) { edit_putch (row, col, '+', dd, NO_EDLIN, 0); } else { edit_putch (row, col, '-', dd, NO_EDLIN, 0); } col++; } row++; } else if (row == IDF_ROW (scr)) { /* IDF ROW - Identification, unless there is important stuff to show */ int col = 0, ind = 0, width = 6; if (strlen (DL0 (scr)) == 0) { /* Write file identification line */ /* 2. File number */ set_colour (pair_idline); ASSERT (snprintf (DL0 (scr), SNPRINTF_SIZE, "#") >= 0); for (ind = 0; ind < COLS && IS_PRINT (DL0 (scr)[ind]); ind++) { edit_putch (row, col, DL0 (scr)[ind], dd, NO_EDLIN, 0); col++; } set_colour (pair_msgline); ASSERT (snprintf (DL0 (scr), SNPRINTF_SIZE, "%d", NUM (dd)) >= 0); for (ind = 0; ind < COLS && IS_PRINT (DL0 (scr)[ind]); ind++) { edit_putch (row, col, DL0 (scr)[ind], dd, NO_EDLIN, 0); col++; } /* 3. File size */ set_colour (pair_idline); ASSERT (snprintf (DL0 (scr), SNPRINTF_SIZE, " size") >= 0); for (ind = 0; ind < COLS && IS_PRINT (DL0 (scr)[ind]); ind++) { edit_putch (row, col, DL0 (scr)[ind], dd, NO_EDLIN, 0); col++; } set_colour (pair_msgline); ASSERT (snprintf (DL0 (scr), SNPRINTF_SIZE, "%d", SIZE (dd)) >= 0); width = (int) strlen (DL0 (scr)); ASSERT (snprintf (DL0 (scr), SNPRINTF_SIZE, " %-*d", width, SIZE (dd)) >= 0); for (ind = 0; ind < COLS && IS_PRINT (DL0 (scr)[ind]); ind++) { edit_putch (row, col, DL0 (scr)[ind], dd, NO_EDLIN, 0); col++; } /* 4. Current line number */ set_colour (pair_idline); if ((IN_TEXT (curs) || IN_PREFIX (curs)) && lin != NO_EDLIN && NUMBER (lin) > 0) { ASSERT (snprintf (DL0 (scr), SNPRINTF_SIZE, " line") >= 0); for (ind = 0; ind < COLS && IS_PRINT (DL0 (scr)[ind]); ind++) { edit_putch (row, col, DL0 (scr)[ind], dd, NO_EDLIN, 0); col++; } set_colour (pair_msgline); ASSERT (snprintf (DL0 (scr), SNPRINTF_SIZE, " %-*d", width, NUMBER (lin) % 1000000) >= 0); for (ind = 0; ind < COLS && IS_PRINT (DL0 (scr)[ind]); ind++) { edit_putch (row, col, DL0 (scr)[ind], dd, NO_EDLIN, 0); col++; } } else { ASSERT (snprintf (DL0 (scr), SNPRINTF_SIZE, " line %-*d", width, 0) >= 0); for (ind = 0; ind < COLS && IS_PRINT (DL0 (scr)[ind]); ind++) { edit_putch (row, col, BLANK_CHAR, dd, NO_EDLIN, 0); col++; } } /* 5. Current column number */ set_colour (pair_idline); ASSERT (snprintf (DL0 (scr), SNPRINTF_SIZE, "%d", col_width) >= 0); width = (int) strlen (DL0 (scr)); if (IN_CMD (curs) || (! IN_PREFIX (curs) && lin != NO_EDLIN)) { ASSERT (snprintf (DL0 (scr), SNPRINTF_SIZE, " col") >= 0); for (ind = 0; ind < COLS && IS_PRINT (DL0 (scr)[ind]); ind++) { edit_putch (row, col, DL0 (scr)[ind], dd, NO_EDLIN, 0); col++; } set_colour (pair_msgline); ASSERT (snprintf (DL0 (scr), SNPRINTF_SIZE, " %-*d", width, INDEX (curs) + 1) >= 0); for (ind = 0; ind < COLS && IS_PRINT (DL0 (scr)[ind]); ind++) { edit_putch (row, col, DL0 (scr)[ind], dd, NO_EDLIN, 0); col++; } } else { ASSERT (snprintf (DL0 (scr), SNPRINTF_SIZE, " col %-*d", width, 0) >= 0); for (ind = 0; ind < COLS && IS_PRINT (DL0 (scr)[ind]); ind++) { edit_putch (row, col, BLANK_CHAR, dd, NO_EDLIN, 0); col++; } } /* 6. Alterations */ set_colour (pair_idline); ASSERT (snprintf (DL0 (scr), SNPRINTF_SIZE, " alt") >= 0); for (ind = 0; ind < COLS && IS_PRINT (DL0 (scr)[ind]); ind++) { edit_putch (row, col, DL0 (scr)[ind], dd, NO_EDLIN, 0); col++; } set_colour (pair_msgline); ASSERT (snprintf (DL0 (scr), SNPRINTF_SIZE, " %d", ALTS (dd) % 1000) >= 0); for (ind = 0; ind < COLS && IS_PRINT (DL0 (scr)[ind]); ind++) { edit_putch (row, col, DL0 (scr)[ind], dd, NO_EDLIN, 0); col++; } /* 7. Insert / overwrite mode set_colour (pair_idline); if (INS_MODE (scr)) { ASSERT (snprintf (DL0 (scr), SNPRINTF_SIZE, " i") >= 0); } else { ASSERT (snprintf (DL0 (scr), SNPRINTF_SIZE, " o") >= 0); } for (ind = 0; ind < COLS && IS_PRINT (DL0 (scr)[ind]); ind++) { edit_putch (row, col, DL0 (scr)[ind], dd, NO_EDLIN, 0); col++; } */ /* 1. File name */ set_colour (pair_msgline); ASSERT (snprintf (DL0 (scr), SNPRINTF_SIZE, " %s", NAME (dd)) >= 0); for (ind = col; ind < COLS - (int) strlen (DL0 (scr)); col++, ind++) { edit_putch (row, col, BLANK_CHAR, dd, NO_EDLIN, ind); } for (ind = 0; ind < COLS && IS_PRINT (DL0 (scr)[ind]); ind++) { edit_putch (row, col, DL0 (scr)[ind], dd, NO_EDLIN, 0); col++; } /* Done */ row++; } else { /* Write message in stead of identification */ redraw = A68_TRUE; set_colour (pair_msgline); for (ind = 0; ind < COLS && IS_PRINT (DL0 (scr)[ind]); ind++) { edit_putch (row, col, DL0 (scr)[ind], dd, NO_EDLIN, 0); col++; } for (ind = col; ind < COLS; col++, ind++) { edit_putch (row, col, BLANK_CHAR, dd, NO_EDLIN, ind); } row++; } } else { row++; } } M_MATCH (dd) = NO_EDLIN; M_SO (dd) = M_EO (dd) = -1; if (redraw) { REDRAW; } EDIT_TEST (wrefresh (stdscr) != ERR); if (redraw) { REDRAW; } } /* Routines to edit various parts of the screen */ /*! \brief edit prefix \param dd current dataset \param ch typed character **/ static void edit_prefix (DATASET_T *dd, int ch) { /* Prefix editing is very basic. You type in overwrite mode. DEL erases the character under the cursor. BACKSPACE erases the character left of the cursor. */ DISPLAY_T *scr = &(DISPLAY (dd)); CURSOR_T *curs = &(CURS (scr)); EDLIN_T *lin = LINE (curs); if (lin == NO_EDLIN) { return; } if (ch <= UCHAR_MAX && IS_PRINT (ch) && INDEX (curs) < MARGIN - 1) { PRECMD (lin)[INDEX (curs)] = (char) TO_UCHAR (ch); COL (curs) = (COL (curs) == MARGIN - 1 ? MARGIN - 1 : COL (curs) + 1); } else if ((ch == KEY_BACKSPACE || ch == BACKSPACE) && COL (curs) > 0) { int i; INDEX (curs) = COL (curs) = (COL (curs) == 0 ? 0 : COL (curs) - 1); for (i = INDEX (curs); i < MARGIN - 1; i++) { PRECMD (lin)[i] = PRECMD (lin)[i + 1]; } } else if (ch == KEY_DC && COL (curs) < MARGIN - 1) { int i; for (i = INDEX (curs); i < MARGIN - 1; i++) { PRECMD (lin)[i] = PRECMD (lin)[i + 1]; } } } /*! \brief edit command \param dd current dataset \param ch typed character **/ static void edit_cmd (DATASET_T *dd, int ch) { /* Command editing is in insert or overwrite mode. The command line is as wide as the screen minus the prompt. If the cursor is outside the command string the latter is lengthened. DEL erases the character under the cursor. BACKSPACE erases the character to the left of the cursor. */ DISPLAY_T *scr = &(DISPLAY (dd)); CURSOR_T *curs = &(CURS (scr)); if (ch <= UCHAR_MAX && IS_PRINT (ch) && (int) strlen (CMD (scr)) < (int) TEXT_WIDTH) { int j, k; while ((int) INDEX (curs) > (int) strlen (CMD (scr))) { k = (int) strlen (CMD (scr)); CMD (scr)[k] = BLANK_CHAR; CMD (scr)[k + 1] = NULL_CHAR; } if (INS_MODE (scr)) { k = (int) strlen (CMD (scr)); for (j = k + 1; j > INDEX (curs); j--) { CMD (scr)[j] = CMD (scr)[j - 1]; } } CMD (scr)[INDEX (curs)] = (char) TO_UCHAR (ch); COL (curs) = (COL (curs) == COLS - 1 ? 0 : COL (curs) + 1); } else if ((ch == KEY_BACKSPACE || ch == BACKSPACE) && INDEX (curs) > 0) { int k; if (INDEX (curs) == 0) { return; } else { INDEX (curs)--; COL (curs)--; } for (k = INDEX (curs); k < (int) strlen (CMD (scr)); k++) { CMD (scr)[k] = CMD (scr)[k + 1]; } } else if (ch == KEY_DC && COL (curs) < COLS - 1) { int k; for (k = INDEX (curs); k < (int) strlen (CMD (scr)); k++) { CMD (scr)[k] = CMD (scr)[k + 1]; } } } /*! \brief edit text \param dd current dataset \param ch typed character **/ static void edit_text (DATASET_T *dd, int ch) { /* Text editing is in insert or overwrite mode. The string can be extended as long as memory lasts. If the cursor is outside the string the latter is lengthened. DEL erases the character under the cursor. BACKSPACE erases the character to the left of the cursor. */ DISPLAY_T *scr = &(DISPLAY (dd)); CURSOR_T *curs = &(CURS (scr)); int llen = 0; EDLIN_T *lin = LINE (curs); if (lin == NO_EDLIN) { return; } if (IS_TOF (lin) || IS_EOF (lin)) { return; } if (lin == LAST_LINE (scr)) { llen = lines_on_scr (dd, lin); } alt_line (dd, lin); if (ch <= UCHAR_MAX && (IS_PRINT (ch) || ch == '\t')) { int j, k, len = (int) strlen (TEXT (lin)); if (RESERVED (lin) <= len + 2 || RESERVED (lin) <= INDEX (curs) + 2) { /* Not enough room */ char *txt = TEXT (lin); int l1 = (RESERVED (lin) <= len + 2 ? len + 2 : 0); int l2 = (RESERVED (lin) <= INDEX (curs) + 2 ? INDEX (curs) + 2 : 0); int res = (l1 > l2 ? l1 : l2) + BLOCK_SIZE; if (res % BLOCK_SIZE > 0) { res += (BLOCK_SIZE - res % BLOCK_SIZE); } RESERVED (lin) = res; TEXT (lin) = (char *) edit_get_heap (dd, (size_t) res); if (TEXT (lin) == NO_TEXT) { return; } bufcpy (TEXT (lin), txt, res); } /* Pad with spaces to cursor position if needed */ while (INDEX (curs) > (len = (int) strlen (TEXT (lin)))) { TEXT (lin)[len] = BLANK_CHAR; TEXT (lin)[len + 1] = NULL_CHAR; } if (INS_MODE (scr)) { k = (int) strlen (TEXT (lin)); for (j = k + 1; j > INDEX (curs); j--) { TEXT (lin)[j] = TEXT (lin)[j - 1]; } } TEXT (lin)[INDEX (curs)] = (char) TO_UCHAR (ch); SYNC_INDEX (curs) = INDEX (curs) + 1; SYNC_LINE (curs) = lin; SYNC (curs) = A68_TRUE; } else if (ch == KEY_BACKSPACE || ch == BACKSPACE) { int k; char del; if (INDEX (curs) == 0) { join_line (dd, "edit"); edit_reset (dd); BL_START (dd) = BL_END (dd) = NO_EDLIN; return; } else { INDEX (curs)--; del = TEXT (lin)[INDEX (curs)]; } for (k = INDEX (curs); k < (int) strlen (TEXT (lin)); k++) { TEXT (lin)[k] = TEXT (lin)[k + 1]; } /* Song and dance to avoid problems deleting tabs spanning end-of-screen */ SYNC_INDEX (curs) = INDEX (curs); SYNC_LINE (curs) = lin; SYNC (curs) = A68_TRUE; } else if (ch == KEY_DC && COL (curs) < COLS) { int k; for (k = INDEX (curs); k < (int) strlen (TEXT (lin)); k++) { TEXT (lin)[k] = TEXT (lin)[k + 1]; } SYNC_INDEX (curs) = INDEX (curs); SYNC_LINE (curs) = lin; SYNC (curs) = A68_TRUE; } if (lin == LAST_LINE (scr) && lines_on_scr (dd, lin) > llen) { forward_line (&CURR (dd)); } } /*! \brief whether x matches c; case insensitive \param string string to test \param string to match, caps in c are mandatory \param args pointer to string after the match \return whether match **/ BOOL_T match_cmd (char *x, char *c, char **args) { #define TRM(c) (c == NULL_CHAR || IS_DIGIT (c) || IS_SPACE (c) || IS_PUNCT (c)) BOOL_T match = A68_TRUE; /* Until proven otherwise */ if (x == NO_TEXT || c == NO_TEXT) { return (A68_FALSE); } /* Single-symbol commands as '?' or '='. */ if (IS_PUNCT (c[0])) { match = (BOOL_T) (x[0] == c[0]); if (args != NO_VAR) { if (match && x[1] != NULL_CHAR) { (*args) = &x[1]; SKIP_WHITE (*args); } else { (*args) = NO_TEXT; } } return ((BOOL_T) match); } /* First the required letters */ while (IS_UPPER (c[0]) && match) { match = (BOOL_T) (match & (TO_LOWER (x[0]) == TO_LOWER ((c++)[0]))); if (! TRM (x[0])) { x++; } } /* Then the facultative part */ while (! TRM (x[0]) && c[0] != NULL_CHAR && match) { match = (BOOL_T) (match & (TO_LOWER ((x++)[0]) == TO_LOWER ((c++)[0]))); } /* Determine the args (arguments, counts) */ if (args != NO_VAR) { if (match && x[0] != NULL_CHAR) { (*args) = &x[0]; SKIP_WHITE (*args); } else { (*args) = NO_TEXT; } } return ((BOOL_T) match); #undef TRM } /*! \brief parse a colour, for instance "GREEN HIGH" \param cmd command for errors \param x string to parse \param pair identifier \return colour as curses attribute or -1 on error **/ static int parse_colour (DATASET_T *dd, char *cmd, char * x, int pair) { DISPLAY_T *scr = &(DISPLAY (dd)); int att = A_NORMAL; char *rest = NO_TEXT, *end = NO_TEXT; if (match_cmd (x, "Red", &rest)) { (void) init_pair ((short) pair, COLOR_RED, COLOR_BLACK); } else if (match_cmd (x, "Green", &rest)) { (void) init_pair ((short) pair, COLOR_GREEN, COLOR_BLACK); } else if (match_cmd (x, "Yellow", &rest)) { (void) init_pair ((short) pair, COLOR_YELLOW, COLOR_BLACK); } else if (match_cmd (x, "Blue", &rest)) { (void) init_pair ((short) pair, COLOR_BLUE, COLOR_BLACK); } else if (match_cmd (x, "Magenta", &rest)) { (void) init_pair ((short) pair, COLOR_MAGENTA, COLOR_BLACK); } else if (match_cmd (x, "Cyan", &rest)) { (void) init_pair ((short) pair, COLOR_CYAN, COLOR_BLACK); } else if (match_cmd (x, "White", &rest)) { (void) init_pair ((short) pair, COLOR_WHITE, COLOR_BLACK); } else { ASSERT (snprintf (DL0 (scr), SNPRINTF_SIZE, "%s: invalid colour name %s", cmd, x) >= 0); return (-1); } if (rest == NO_TEXT || (int) strlen (rest) == 0) { att = A_NORMAL; } else if (match_cmd (rest, "High", &end)) { att = A_BOLD; } else if (match_cmd (rest, "Nohigh", &end)) { att = A_NORMAL; } else if (match_cmd (rest, "Dim", &end)) { att = A_DIM; } else { ASSERT (snprintf (DL0 (scr), SNPRINTF_SIZE, "%s: invalid colour attribute %s", cmd, rest) >= 0); return (-1); } if (!EMPTY_STRING (end)) { TRAILING (end); return (-1); } return (COLOR_PAIR (pair) | att); } /*! \brief translate integral argument \param dd current dataset \param cmd command that calls this routine \return argument value: default is 1 if no value is present, or -1 if an error occurs **/ static int int_arg (DATASET_T *dd, char *cmd, char *arg, char **rest, int def) { DISPLAY_T *scr = &(DISPLAY (dd)); char *suffix; int k; /* Fetch argument */ SKIP_WHITE (arg); if (EMPTY_STRING (arg)) { return (1); }; /* Translate argument into integer */ if (arg[0] == '*') { (*rest) = &arg[1]; SKIP_WHITE (*rest); return (def); } else { RESET_ERRNO; k = (int) strtol (arg, &suffix, 0); /* Accept also octal and hex */ if (errno != 0 || suffix == arg) { ASSERT (snprintf (DL0 (scr), SNPRINTF_SIZE, "%s: invalid integral argument", cmd) >= 0); return (WRONG_TARGET); } else { (*rest) = suffix; SKIP_WHITE (*rest); return (k); } } } /*! \brief get substitute strings \param dd current dataset \param cmd command that calls this routine \param arg point to arguments \param rest will point to trialing text **/ static BOOL_T get_subst (DATASET_T *dd, char *cmd, char *arg, char **rest) { /* Get the find and replacement string in a substitute command */ DISPLAY_T *scr = &(DISPLAY (dd)); char delim, *q, *pat1, *pat2; int rc; if (EMPTY_STRING (arg)) { ASSERT (snprintf (DL0 (scr), SNPRINTF_SIZE, "%s: no regular expression", cmd) >= 0); return (A68_FALSE); } /* Initialise */ reset_regexp (&(FIND (dd))); reset_regexp (&(REPL (dd))); (*rest) = NO_TEXT; SKIP_WHITE (arg); q = arg; delim = *(q++); /* Get find regexp */ pat1 = PATTERN (&FIND (dd)); pat1[0] = NULL_CHAR; while (q[0] != delim && q[0] != NULL_CHAR) { if (q[0] == '\\') { *(pat1)++ = *q++; if (q[0] == NULL_CHAR) { ASSERT (snprintf (DL0 (scr), SNPRINTF_SIZE, "%s: invalid regular expression", cmd) >= 0); *(pat1) = NULL_CHAR; return (A68_FALSE); } *(pat1)++ = *q++; } else { *(pat1)++ = *q++; } } *(pat1) = NULL_CHAR; if ((int) strlen (PATTERN (&FIND (dd))) == 0) { ASSERT (snprintf (DL0 (scr), SNPRINTF_SIZE, "%s: no regular expression", cmd) >= 0); return (A68_FALSE); } rc = compile_regexp (dd, &(FIND (dd)), cmd); if (rc != 0) { return (A68_FALSE); } /* Get replacement string */ if (q[0] != delim) { ASSERT (snprintf (DL0 (scr), SNPRINTF_SIZE, "%s: unrecognised regular expression syntax", cmd) >= 0); return (A68_FALSE); } q = &q[1]; pat2 = PATTERN (&REPL (dd)); pat2[0] = NULL_CHAR; while (q[0] != delim && q[0] != NULL_CHAR) { if (q[0] == '\\') { *(pat2)++ = *q++; if (q[0] == NULL_CHAR) { ASSERT (snprintf (DL0 (scr), SNPRINTF_SIZE, "%s: invalid regular expression", cmd) >= 0); *(pat2) = NULL_CHAR; return (A68_FALSE); } *(pat2)++ = *q++; } else { *(pat2)++ = *q++; } } *(pat2) = NULL_CHAR; if (q[0] == delim) { q++; } (*rest) = q; SKIP_WHITE (*rest); return (A68_TRUE); } /*! \brief substitute target in one line \param dd current dataset \param z line to substitute \param rep number of substitutions ... \param start ... starting at this occurence \param confirm confirm each change \param cmd command that calls this routine **/ static int substitute (DATASET_T *dd, EDLIN_T *z, int rep, int start, BOOL_T *confirm, char *cmd) { DISPLAY_T *scr = &(DISPLAY (dd)); CURSOR_T *curs = &(CURS (scr)); int k, subs = 0, newt = 0, matcnt = 0; /* Initialisation */ for (k = 0; k < rep; k ++) { int i, lenn, lens, lent, nnwt, pos = 0; char *txt = &(TEXT (z)[newt]); int rc = regexec (&(COMPILED (&FIND (dd))), txt, NUM_MATCH (&FIND (dd)), MATCH (&FIND (dd)), (k == 0 ? 0 : REG_NOTBOL)); if (rc == REG_NOMATCH) { goto subst_end; } matcnt++; if (matcnt < start) { newt += RM_EO (&(MATCH (&FIND (dd))[0])); continue; } if (*confirm) { char ch; BOOL_T loop; ASSERT (snprintf (DL0 (scr), SNPRINTF_SIZE, "%s: [A]ll, [S]ubstitute, [N]ext or [Q]uit?", cmd) >= 0); NEW_CURR (dd, z); edit_reset (dd); align_current (dd); M_MATCH (dd) = z; M_SO (dd) = newt + RM_SO (&(MATCH (&FIND (dd))[0])); M_EO (dd) = newt + RM_EO (&(MATCH (&FIND (dd))[0])); CURSOR_TO_COMMAND (dd, curs); edit_draw (dd); EDIT_TEST (wmove (stdscr, ROW (curs), COL (curs)) != ERR); EDIT_TEST (wrefresh (stdscr) != ERR); M_MATCH (dd) = NO_EDLIN; M_SO (dd) = -1; M_EO (dd) = -1; loop = A68_TRUE; while (loop) { ch = TO_LOWER (wgetch (stdscr)); switch (ch) { case 'a': {loop = A68_FALSE; *confirm = A68_FALSE; break;} case 's': {loop = A68_FALSE; break;} case 'q': { bufcpy (DL0 (scr), "", BUFFER_SIZE); bufcpy (CMD (scr), "", BUFFER_SIZE); return (SUBST_ERROR); } case 'n': { newt += RM_EO (&(MATCH (&FIND (dd))[0])); goto do_nothing; } } } } /* Part before match */ (LINBUF (dd))[0] = NULL_CHAR; lent = (int) strlen (TEXT (z)); for (i = 0; i < newt + RM_SO (&(MATCH (&FIND (dd))[0])); i ++) { add_linbuf (dd, TEXT (z)[i], pos); if (LINBUF (dd) == NO_TEXT) { return (SUBST_ERROR); } pos++; } /* Insert substitution string */ lens = (int) strlen (PATTERN (&REPL (dd))); i = 0; while (i < lens && PATTERN (&REPL (dd))[i] != NULL_CHAR) { if (PATTERN (&REPL (dd))[i] == '\\' && ( IS_DIGIT (PATTERN (&REPL (dd))[i + 1]) || IS_UPPER (PATTERN (&REPL (dd))[i + 1]) || IS_LOWER (PATTERN (&REPL (dd))[i + 1]) ) ) { int n = 0, strop = 0, j; switch (PATTERN (&REPL (dd))[i + 1]) { case '1': {n = 1; break;} case '2': {n = 2; break;} case '3': {n = 3; break;} case '4': {n = 4; break;} case '5': {n = 5; break;} case '6': {n = 6; break;} case '7': {n = 7; break;} case '8': {n = 8; break;} case '9': {n = 9; break;} case 'A': {n = 1; strop = 1; break;} case 'B': {n = 2; strop = 1; break;} case 'C': {n = 3; strop = 1; break;} case 'D': {n = 4; strop = 1; break;} case 'E': {n = 5; strop = 1; break;} case 'F': {n = 6; strop = 1; break;} case 'G': {n = 7; strop = 1; break;} case 'H': {n = 8; strop = 1; break;} case 'I': {n = 9; strop = 1; break;} case 'a': {n = 1; strop = -1; break;} case 'b': {n = 2; strop = -1; break;} case 'c': {n = 3; strop = -1; break;} case 'd': {n = 4; strop = -1; break;} case 'e': {n = 5; strop = -1; break;} case 'f': {n = 6; strop = -1; break;} case 'g': {n = 7; strop = -1; break;} case 'h': {n = 8; strop = -1; break;} case 'i': {n = 9; strop = -1; break;} default: { if (n >= (int) NUM_MATCH (&FIND (dd))) { ASSERT (snprintf (DL0 (scr), SNPRINTF_SIZE, "%s: invalid group \\%d", cmd, PATTERN (&REPL (dd))[i + 1]) >= 0); return (SUBST_ERROR); } } } if (n >= (int) NUM_MATCH (&FIND (dd))) { ASSERT (snprintf (DL0 (scr), SNPRINTF_SIZE, "%s: no group \\%d in regular expression", cmd, n) >= 0); return (SUBST_ERROR); } if (RM_SO (&(MATCH (&FIND (dd))[n])) == -1 && RM_EO (&(MATCH (&FIND (dd))[n])) == -1) { ASSERT (snprintf (DL0 (scr), SNPRINTF_SIZE, "%s: group \\%d in regular expression not set", cmd, n) >= 0); return (SUBST_ERROR); } for (j = RM_SO (&(MATCH (&FIND (dd))[n])); j < RM_EO (&(MATCH (&FIND (dd))[n])); j ++) { if (strop == -1) { add_linbuf (dd, TO_LOWER (TEXT (z)[newt + j]), pos); } else if (strop == 1) { add_linbuf (dd, TO_UPPER (TEXT (z)[newt + j]), pos); } else { add_linbuf (dd, TEXT (z)[newt + j], pos); } if (LINBUF (dd) == NO_TEXT) { return (SUBST_ERROR); } pos++; } i++; /* Skip digit in \n */ } else { add_linbuf (dd, PATTERN (&REPL (dd))[i], pos); if (LINBUF (dd) == NO_TEXT) { return (SUBST_ERROR); } pos++; } i++; } nnwt = pos; /* Part after match */ for (i = newt + RM_EO (&(MATCH (&FIND (dd))[0])); i < lent; i ++) { add_linbuf (dd, TEXT (z)[i], pos); if (LINBUF (dd) == NO_TEXT) { return (SUBST_ERROR); } pos++; } add_linbuf (dd, NULL_CHAR, pos); if (LINBUF (dd) == NO_TEXT) { return (SUBST_ERROR); } /* Copy the new line */ newt = nnwt; subs++; lenn = (int) strlen (LINBUF (dd)); if (RESERVED (z) >= lenn + 1) { bufcpy (TEXT (z), LINBUF (dd), RESERVED (z)); } else { int res = lenn + 1; if (res % BLOCK_SIZE > 0) { res += (BLOCK_SIZE - res % BLOCK_SIZE); } RESERVED (z) = res; TEXT (z) = (char *) edit_get_heap (dd, (size_t) res); if (TEXT (z) == NO_TEXT) { return (SUBST_ERROR); } bufcpy (TEXT (z), LINBUF (dd), res); } ALTS (dd)++; if (TEXT (z)[newt] == NULL_CHAR) { goto subst_end; } do_nothing: /* skip */; } subst_end: return (subs); } /*! \brief dispatch lines to shell command and insert command output \param dd current dataset \param cmd edit cmd that calls this routine \param u target line \param argv shell command **/ static void edit_filter (DATASET_T *dd, char *cmd, char *argv, EDLIN_T *u) { DISPLAY_T *scr = &(DISPLAY (dd)); CURSOR_T *curs = &(CURS (scr)); char shell[BUFFER_SIZE]; EDLIN_T *z; /* Write selected lines ... */ edit_write (dd, cmd, ".a68g.edit.out", CURR (dd), u); /* Delete the original lines */ for (z = CURR (dd); z != u && IS_IN_TEXT (z); forward_line (&z)) { LINE (curs) = z; LAST (curs) = z; INDEX (curs) = 0; cdelete (dd); join_line (dd, cmd); } if (IS_IN_TEXT (z)) { NEW_CURR (dd, PREVIOUS (z)); } else { NEW_CURR (dd, TOF (dd)); } align_current (dd); /* ... process the lines ... */ RESET_ERRNO; ASSERT (snprintf (shell, SNPRINTF_SIZE, "%s < .a68g.edit.out > .a68g.edit.in", argv) >= 0); EDIT_TEST (system (shell) != -1); CHECK_ERRNO (cmd); /* ... and read lines */ edit_read (dd, cmd, ".a68g.edit.in", NO_EDLIN); /* Done */ bufcpy (CMD (scr), "", BUFFER_SIZE); CURSOR_TO_COMMAND (dd, curs); return; } /*! \brief move or copy lines (move is copy + delete) \param dd current dataset \param cmd command that calls this \param args points to arguments \param cmd_move move or copy **/ static void move_copy (DATASET_T *dd, char *cmd, char *args, BOOL_T cmd_move) { DISPLAY_T *scr = &(DISPLAY (dd)); CURSOR_T *curs = &(CURS (scr)); EDLIN_T *u, *v, *w, *x, *z, *bl_start = NO_EDLIN, *bl_end = NO_EDLIN; char *cmdn, *rest = NO_TEXT; int j, n, count; if (cmd_move) { cmdn = "move"; } else { cmdn = "copy"; } if (SUBSET (dd)) { ASSERT (snprintf (DL0 (scr), SNPRINTF_SIZE, "%s: fold disables %s", cmdn, cmdn) >= 0); CURSOR_TO_COMMAND (dd, curs); return; } u = CURR (dd); if (EMPTY_STRING (args)) { ASSERT (snprintf (DL0 (scr), SNPRINTF_SIZE, "%s: insufficient arguments", cmdn) >= 0); CURSOR_TO_COMMAND (dd, curs); return; } v = get_target (dd, cmd, args, &rest, A68_TRUE); args = rest; if (EMPTY_STRING (args)) { ASSERT (snprintf (DL0 (scr), SNPRINTF_SIZE, "%s: insufficient arguments", cmdn) >= 0); CURSOR_TO_COMMAND (dd, curs); return; } w = get_target (dd, cmd, args, &rest, A68_TRUE); if (!EMPTY_STRING (rest)) { args = rest; n = int_arg (dd, cmd, args, &rest, 1); } else { n = 1; } if (!EMPTY_STRING (rest)) { TRAILING (cmdn); CURSOR_TO_COMMAND (dd, curs); return; } /* Out of range */ if (IS_EOF (w)) { ASSERT (snprintf (DL0 (scr), SNPRINTF_SIZE, "%s: cannot add after end-of-data", cmdn) >= 0); CURSOR_TO_COMMAND (dd, curs); return; } /* Backwards range */ if (NOT_EOF (v) && (NUMBER (v) < NUMBER (u))) { ASSERT (snprintf (DL0 (scr), SNPRINTF_SIZE, "%s: backward range", cmdn) >= 0); CURSOR_TO_COMMAND (dd, curs); return; } /* Copy to within range */ if (NUMBER (u) <= NUMBER (w) && NUMBER (w) < NUMBER (v) - 1) { ASSERT (snprintf (DL0 (scr), SNPRINTF_SIZE, "%s: target within selected range", cmdn) >= 0); CURSOR_TO_COMMAND (dd, curs); return; } edit_write_undo_file (dd, cmdn); /* Count */ for (count = 0, z = u; z != v; FORWARD (z)) { count++; } /* Copy */ for (j = 0; j < n; j++) { /* Add lines */ int k; for (k = 0, z = u; k < count && IS_IN_TEXT (z); k++, FORWARD (z)) { LINE (curs) = w; INDEX (curs) = (int) strlen (TEXT (w)); split_line (dd, cmd); } /* Copy text */ bl_start = NEXT (w); for (k = 0, x = NEXT (w), z = u; k < count && IS_IN_TEXT (z); k++, FORWARD (x), FORWARD (z)) { char *txt = TEXT (z); int len = 1 + (int) strlen (txt); int res = len; if (res % BLOCK_SIZE > 0) { res += (BLOCK_SIZE - res % BLOCK_SIZE); } bl_end = x; RESERVED (x) = res; TEXT (x) = (char *) edit_get_heap (dd, (size_t) res); if (TEXT (x) == NO_TEXT) { return; } bufcpy (TEXT (x), txt, res); } } /* Delete the original lines */ if (cmd_move) { for (z = u; z != v && IS_IN_TEXT (z); FORWARD (z)) { LINE (curs) = z; LAST (curs) = z; INDEX (curs) = 0; cdelete (dd); join_line (dd, cmd); } } /* Done */ edit_reset (dd); if ((count * n) == 0) { ASSERT (snprintf (DL0 (scr), SNPRINTF_SIZE, "%s: %s no lines", cmdn, (cmd_move ? "moved" : "copied")) >= 0); } else if ((count * n) == 1) { BL_START (dd) = bl_start; BL_END (dd) = bl_end; ALTS (dd)++; ASSERT (snprintf (DL0 (scr), SNPRINTF_SIZE, "%s: %s 1 line", cmdn, (cmd_move ? "moved" : "copied")) >= 0); } else if (n == 1) { BL_START (dd) = bl_start; BL_END (dd) = bl_end; ALTS (dd)++; ASSERT (snprintf (DL0 (scr), SNPRINTF_SIZE, "%s: %s %d lines", cmdn, (cmd_move ? "moved" : "copied"), count * n) >= 0); } else { BL_START (dd) = bl_start; BL_END (dd) = bl_end; ALTS (dd)++; ASSERT (snprintf (DL0 (scr), SNPRINTF_SIZE, "%s: %s %d lines %d times", cmdn, (cmd_move ? "moved" : "copied"), count, n) >= 0); } bufcpy (CMD (scr), "", BUFFER_SIZE); CURSOR_TO_COMMAND (dd, curs); return; } /*! \brief indent lines to a column \param dd current dataset \param cmd command that calls this \param args points to arguments **/ static void indent (DATASET_T *dd, char *cmd, char *args) { DISPLAY_T *scr = &(DISPLAY (dd)); CURSOR_T *curs = &(CURS (scr)); EDLIN_T *u, *v, *z; char *rest = NO_TEXT; int dir, k, n, m, count; if (SUBSET (dd)) { ASSERT (snprintf (DL0 (scr), SNPRINTF_SIZE, "%s: folded dataset", cmd) >= 0); CURSOR_TO_COMMAND (dd, curs); return; } u = CURR (dd); if (EMPTY_STRING (args)) { ASSERT (snprintf (DL0 (scr), SNPRINTF_SIZE, "%s: insufficient arguments", cmd) >= 0); CURSOR_TO_COMMAND (dd, curs); return; } v = get_target (dd, cmd, args, &rest, A68_TRUE); args = rest; if (EMPTY_STRING (args)) { ASSERT (snprintf (DL0 (scr), SNPRINTF_SIZE, "%s: insufficient arguments", cmd) >= 0); CURSOR_TO_COMMAND (dd, curs); return; } dir = 0; if (!EMPTY_STRING (rest)) { args = rest; if (args[0] == '>') { args++; dir = 1; } else if (args[0] == '<') { args++; dir = -1; } n = int_arg (dd, cmd, args, &rest, 1); } else { n = 1; } if (!EMPTY_STRING (rest)) { TRAILING (cmd); CURSOR_TO_COMMAND (dd, curs); return; } /* Backwards range */ if (NOT_EOF (v) && (NUMBER (v) < NUMBER (u))) { ASSERT (snprintf (DL0 (scr), SNPRINTF_SIZE, "%s: backward range", cmd) >= 0); CURSOR_TO_COMMAND (dd, curs); return; } /* Align */ edit_write_undo_file (dd, cmd); k = -1; count = 0; for (z = u; z != v; FORWARD (z)) { /* Find column of first printable character */ if (k == -1 && NUMBER (z) != 0) { int j; char *t = TEXT (z); for (j = 0; k == -1 && t[j] != NULL_CHAR; j++) { if (!IS_SPACE (t[j])) { k = j; } } } if (dir == 1) { m = k + n; } else if (dir == 0) { m = n - 1; } else /* if (dir == -1) */ { m = k - n; } /* Align the line, if we can */ if (k >= 0 && NUMBER (z) != 0) { int delta = m - k, i, j; char *t = TEXT (z); (LINBUF (dd))[0] = 0; i = 0; if (delta >= 0) { for (j = 0; j < delta; j ++) { add_linbuf (dd, BLANK_CHAR, i++); if (LINBUF (dd) == NO_TEXT) { CURSOR_TO_COMMAND (dd, curs); return; } } for (j = 0; t[j] != NULL_CHAR; j++) { add_linbuf (dd, t[j], i++); if (LINBUF (dd) == NO_TEXT) { CURSOR_TO_COMMAND (dd, curs); return; } } } else { for (j = 0; j < -delta && t[j] != NULL_CHAR && IS_SPACE (t[j]); j ++) {;} for (; t[j] != NULL_CHAR; j++) { add_linbuf (dd, t[j], i++); if (LINBUF (dd) == NO_TEXT) { CURSOR_TO_COMMAND (dd, curs); return; } } } new_edit_string (dd, z, LINBUF (dd), NO_EDLIN); alt_line (dd, z); if (TEXT (z) == NO_TEXT) { CURSOR_TO_COMMAND (dd, curs); return; } count++; } } /* Done */ edit_reset (dd); BL_START (dd) = BL_END (dd) = NO_EDLIN; if (count == 0) { ASSERT (snprintf (DL0 (scr), SNPRINTF_SIZE, "%s: indented no lines", cmd) >= 0); } else if (count == 1) { ASSERT (snprintf (DL0 (scr), SNPRINTF_SIZE, "%s: indented 1 line", cmd) >= 0); } else { ASSERT (snprintf (DL0 (scr), SNPRINTF_SIZE, "%s: indented %d lines", cmd, count) >= 0); } bufcpy (CMD (scr), "", BUFFER_SIZE); CURSOR_TO_COMMAND (dd, curs); return; } /*! \brief set current line \param dd current dataset \param cmd command that calls this \param target to point current line to **/ static void set_current (DATASET_T *dd, char *cmd, char *target) { DISPLAY_T *scr = &(DISPLAY (dd)); CURSOR_T *curs = &(CURS (scr)); char *rest = NO_TEXT; EDLIN_T *z = get_target (dd, cmd, target, &rest, A68_TRUE); if (!EMPTY_STRING (rest)) { TRAILING (cmd); CURSOR_TO_COMMAND (dd, curs); return; } if (z != NO_EDLIN) { NEW_CURR (dd, z); } bufcpy (CMD (scr), "", BUFFER_SIZE); CURSOR_TO_COMMAND (dd, curs); } /*! \brief set current line and store target as command \param dd current dataset \param cmd command that calls this \param target to point current line to **/ static void set_current_store (DATASET_T *dd, char *cmd, char *target) { DISPLAY_T *scr = &(DISPLAY (dd)); CURSOR_T *curs = &(CURS (scr)); char *rest = NO_TEXT; EDLIN_T *z; z = get_target (dd, cmd, target, &rest, A68_TRUE); if (!EMPTY_STRING (rest)) { TRAILING (cmd); CURSOR_TO_COMMAND (dd, curs); return; } if (z != NO_EDLIN) { NEW_CURR (dd, z); } bufcpy (CMD (scr), "", BUFFER_SIZE); CURSOR_TO_COMMAND (dd, curs); } /*! \brief give full command name \param cmd command that calls this \return same **/ static char *full_cmd (char *cmd) { if (match_cmd (cmd, "Add", NO_VAR)) { return ("add"); } else if (match_cmd (cmd, "AGain", NO_VAR)) { return ("again"); } else if (match_cmd (cmd, "Indent", NO_VAR)) { return ("indent"); } else if (match_cmd (cmd, "CAse", NO_VAR)) { return ("case"); } else if (match_cmd (cmd, "CDelete", NO_VAR)) { return ("cdelete"); } else if (match_cmd (cmd, "COpy", NO_VAR)) { return ("copy"); } else if (match_cmd (cmd, "DELete", NO_VAR)) { return ("delete"); } else if (match_cmd (cmd, "Edit", NO_VAR)) { return ("edit"); } else if (match_cmd (cmd, "FILE", NO_VAR)) { return ("file"); } else if (match_cmd (cmd, "FOld", NO_VAR)) { return ("fold"); } else if (match_cmd (cmd, "Input", NO_VAR)) { return ("input"); } else if (match_cmd (cmd, "MOve", NO_VAR)) { return ("move"); } else if (match_cmd (cmd, "Page", NO_VAR)) { return ("page"); } else if (match_cmd (cmd, "PF", NO_VAR)) { return ("pf"); } else if (match_cmd (cmd, "QQuit", NO_VAR)) { return ("qquit"); } else if (match_cmd (cmd, "Read", NO_VAR)) { return ("read"); } else if (match_cmd (cmd, "RESet", NO_VAR)) { return ("reset"); } else if (match_cmd (cmd, "SAve", NO_VAR)) { return ("save"); } else if (match_cmd (cmd, "SET", NO_VAR)) { return ("set"); } else if (match_cmd (cmd, "SHell", NO_VAR)) { return ("shell"); } else if (match_cmd (cmd, "Help", NO_VAR)) { return ("help"); } else if (match_cmd (cmd, "S", NO_VAR)) { return ("substitute"); } else if (match_cmd (cmd, "S", NO_VAR)) { return ("sc"); } else if (match_cmd (cmd, "TOGgle", NO_VAR)) { return ("toggle"); } else if (match_cmd (cmd, "Undo", NO_VAR)) { return ("undo"); } else if (match_cmd (cmd, "WQ", NO_VAR)) { return ("wq"); } else if (match_cmd (cmd, "Write", NO_VAR)) { return ("write"); } else if (match_cmd (cmd, "Xedit", NO_VAR)) { return ("xedit"); } else { return (cmd); } } /*! \brief place reserved line \param dd current dataset \param line pointer to line \param fcmd full name of SET command \param args arguments **/ static void edit_place (DATASET_T *dd, int *line, char *fcmd, char *args) { DISPLAY_T *scr = &(DISPLAY (dd)); char *rest = NO_TEXT; if (match_cmd (args, "TOP", &rest)) { if (!EMPTY_STRING (rest)) { TRAILING (fcmd); return; } if (reserved_row (dd, 0)) { ASSERT (snprintf (DL0 (scr), SNPRINTF_SIZE, "%s: cannot place at row %d", fcmd, 1) >= 0); return; } (*line) = 0; return; } else if (match_cmd (args, "BOTtom", &rest)) { if (!EMPTY_STRING (rest)) { TRAILING (fcmd); return; } if (reserved_row (dd, LINES - 1)) { ASSERT (snprintf (DL0 (scr), SNPRINTF_SIZE, "%s: cannot place at row %d", fcmd, LINES) >= 0); return; } (*line) = LINES - 1; return; } else { int n = int_arg (dd, fcmd, args, &rest, 1 + LINES / 2); if (!EMPTY_STRING (rest)) { TRAILING (fcmd); return; } if ((n < 0 || n > LINES) || reserved_row (dd, n - 1)) { ASSERT (snprintf (DL0 (scr), SNPRINTF_SIZE, "%s: cannot place at row %d", fcmd, n) >= 0); return; } (*line) = n - 1; return; } } /*! \brief execute set command \param dd current dataset \param fcmd full name of SET command \param cmd command after SET **/ static void edit_set_cmd (DATASET_T *dd, char *fcmd, char *cmd) { DISPLAY_T *scr = &(DISPLAY (dd)); CURSOR_T *curs = &(CURS (scr)); char *args = NO_TEXT, *rest = NO_TEXT; char gcmd[SNPRINTF_SIZE]; if (cmd == NO_TEXT) { ASSERT (snprintf (gcmd, SNPRINTF_SIZE, "%s", fcmd) >= 0); } else { ASSERT (snprintf (gcmd, SNPRINTF_SIZE, "%s %s", fcmd, cmd) >= 0); } if (match_cmd (cmd, "SCALE", &args)) { /* SCALE OFF|TOP|BOTTOM|*|n: set scale row */ if (match_cmd (args, "OFF", &rest)) { if (!EMPTY_STRING (rest)) { TRAILING (gcmd); CURSOR_TO_COMMAND (dd, curs); return; } SCALE_ROW (scr) = A68_MAX_INT; bufcpy (CMD (scr), "", BUFFER_SIZE); CURSOR_TO_COMMAND (dd, curs); return; } else { edit_place (dd, &SCALE_ROW (scr), gcmd, args); bufcpy (CMD (scr), "", BUFFER_SIZE); CURSOR_TO_COMMAND (dd, curs); return; } } else if (match_cmd (cmd, "IDF", &args)) { /* IDF OFF|TOP|BOTTOM|*|n: set scale row */ if (match_cmd (args, "OFF", &rest)) { if (!EMPTY_STRING (rest)) { TRAILING (gcmd); CURSOR_TO_COMMAND (dd, curs); return; } IDF_ROW (scr) = A68_MAX_INT; bufcpy (CMD (scr), "", BUFFER_SIZE); CURSOR_TO_COMMAND (dd, curs); return; } else { edit_place (dd, &IDF_ROW (scr), gcmd, args); bufcpy (CMD (scr), "", BUFFER_SIZE); CURSOR_TO_COMMAND (dd, curs); return; } } else if (match_cmd (cmd, "CMD", &args)) { /* CMD TOP|BOTTOM|*|n: set command row */ edit_place (dd, &CMD_ROW (scr), gcmd, args); bufcpy (CMD (scr), "", BUFFER_SIZE); CURSOR_TO_COMMAND (dd, curs); return; } else if (match_cmd (cmd, "COLOUR", &args) || match_cmd (cmd, "COLOR", &args)) { int clr; #define SET_COLOUR(name, colour, pair) {\ if (match_cmd (args, (name), &rest)) {\ clr = parse_colour (dd, cmd, rest, pair);\ if (clr == -1) {\ return;\ } else {\ colour = clr;\ return;\ }}} SET_COLOUR ("Arrow", pair_arrow, PAIR_ARROW); SET_COLOUR ("CMdline", pair_cmdline, PAIR_CMDLINE); SET_COLOUR ("COntrol", pair_control, PAIR_CONTROL); SET_COLOUR ("CUrline", pair_curline, PAIR_CURLINE); SET_COLOUR ("Filearea", pair_filearea, PAIR_FILEAREA); SET_COLOUR ("Idline", pair_idline, PAIR_IDLINE); SET_COLOUR ("MAtch", pair_match, PAIR_MATCH); SET_COLOUR ("MSgline", pair_msgline, PAIR_MSGLINE); SET_COLOUR ("Prefix", pair_prefix, PAIR_PREFIX); SET_COLOUR ("Scale", pair_scale, PAIR_SCALE); SET_COLOUR ("Tofeof", pair_tofeof, PAIR_TOFEOF); } ASSERT (snprintf (DL0 (scr), SNPRINTF_SIZE, "edit: undefined command \"%s\"", gcmd) >= 0); } /*! \brief execute editor command \param dd current dataset **/ static void edit_do_cmd (DATASET_T *dd) { DISPLAY_T *scr = &(DISPLAY (dd)); CURSOR_T *curs = &(CURS (scr)); char *cmd = CMD (scr), *args = NO_TEXT, *rest = NO_TEXT; char *fcmd = full_cmd (cmd); /* Initial white space is meaningless */ SKIP_WHITE (cmd); /* Empty command is meaningless */ if ((int) strlen (cmd) == 0) { CURSOR_TO_COMMAND (dd, curs); return; } /* Commands that are not stored */ if (cmd[0] == '&') { /* Execute the command but leave it in the buffer */ char cp[BUFFER_SIZE]; bufcpy (cp, cmd, BUFFER_SIZE); bufcpy (CMD (scr), &cp[1], BUFFER_SIZE); edit_do_cmd (dd); bufcpy (CMD (scr), cp, BUFFER_SIZE); CURSOR_TO_COMMAND (dd, curs); return; } else if (match_cmd (cmd, "?", &args)) { /* Restore last command; do not execute */ NO_ARGS ("?", args); if (histcurr >= 0) { bufcpy (CMD (scr), history[histcurr], BUFFER_SIZE); } CURSOR_TO_COMMAND (dd, curs); return; } else if (match_cmd (cmd, "=", &args)) { NO_ARGS ("=", args); /* Repeat last command on "=" */ if (histcurr >= 0) { bufcpy (CMD (scr), history[histcurr], BUFFER_SIZE); edit_do_cmd (dd); bufcpy (CMD (scr), "", BUFFER_SIZE); } CURSOR_TO_COMMAND (dd, curs); return; } /* Target commands that set the current line */ if (IS_DIGIT (cmd[0])) { set_current (dd, "edit", cmd); align_current (dd); return; } else if (cmd[0] == ':') { set_current (dd, "edit", cmd); align_current (dd); return; } else if (cmd[0] == '+' && IS_DIGIT (cmd[1])) { set_current (dd, "edit", cmd); align_current (dd); return; } else if (cmd[0] == '-' && IS_DIGIT (cmd[1])) { set_current (dd, "edit", cmd); align_current (dd); return; } else if (cmd[0] == '*' || cmd[0] == '$') { set_current (dd, "edit", cmd); align_current (dd); return; } else if (cmd[0] == '+' && cmd[1] == '*') { set_current (dd, "edit", cmd); align_current (dd); return; } else if (cmd[0] == '-' && cmd[1] == '*') { set_current (dd, "edit", cmd); align_current (dd); return; } else if (cmd[0] == '.') { set_current (dd, "edit", cmd); align_current (dd); return; } else if (cmd[0] == '/') { set_current_store (dd, "edit", cmd); align_current (dd); return; } else if (cmd[0] == '~' && cmd[1] == '/') { set_current_store (dd, "edit", cmd); align_current (dd); return; } else if (cmd[0] == '-' && cmd[1] == '/') { set_current_store (dd, "edit", cmd); align_current (dd); return; } else if (cmd[0] == '+' && cmd[1] == '/') { set_current_store (dd, "edit", cmd); align_current (dd); return; } else if (cmd[0] == '-' && cmd[1] == '~' && cmd[2] == '/') { set_current_store (dd, "edit", cmd); align_current (dd); return; } else if (cmd[0] == '+' && cmd[1] == '~' && cmd[2] == '/') { set_current_store (dd, "edit", cmd); align_current (dd); return; } if (match_cmd (cmd, "AGain", &args)) { /* AGAIN: repeat last search */ EDLIN_T *z; NO_ARGS (fcmd, args); z = get_regexp (dd, cmd, args, &rest, A68_FALSE); if (z != NO_EDLIN) { NEW_CURR (dd, z); } bufcpy (CMD (scr), "", BUFFER_SIZE); CURSOR_TO_COMMAND (dd, curs); return; } else if (match_cmd (cmd, "Input", &args)) { NO_ARGS (fcmd, args); CURSOR_TO_CURRENT (dd, curs); bufcpy (CMD (scr), "ADD 1", BUFFER_SIZE); edit_do_cmd (dd); return; } else if (match_cmd (cmd, "TOGgle", &args)) { /* TOGGLE: switch between prefix/text and command line */ NO_ARGS (fcmd, args); if (IN_CMD (curs)) { CURSOR_TO_CURRENT (dd, curs); } else if (! IN_FORBIDDEN (curs)) { CURSOR_TO_COMMAND (dd, curs); } else { CURSOR_TO_COMMAND (dd, curs); } bufcpy (CMD (scr), "", BUFFER_SIZE); align_current (dd); return; } else if (match_cmd (cmd, "CDelete", &args)) { /* CDELETE: delete to end of line */ NO_ARGS (fcmd, args); if (IN_TEXT (curs)) { cdelete (dd); bufcpy (CMD (scr), "", BUFFER_SIZE); } else if (IN_CMD (curs)) { CURSOR_TO_COMMAND (dd, curs); } return; /* RESET: reset prefix commands */ } else if (match_cmd (cmd, "RESet", &args)) { NO_ARGS (fcmd, args); edit_reset (dd); BL_START (dd) = BL_END (dd) = NO_EDLIN; bufcpy (CMD (scr), "", BUFFER_SIZE); return; } else if (match_cmd (cmd, "QQuit", &args)) { /* QQUIT: quit immediately - live with it like a Klingon */ NO_ARGS (fcmd, args); if (ALTS (dd) > 0) { ASSERT (snprintf (DL0 (scr), SNPRINTF_SIZE, "%s: file not saved", fcmd) >= 0); ALTS (dd) = 0; bufcpy (CMD (scr), "", BUFFER_SIZE); CURSOR_TO_COMMAND (dd, curs); return; } else { if ((UNDO (dd)[0]) != NULL_CHAR) { EDIT_TEST (remove (UNDO (dd)) != -1); } longjmp (EDIT_EXIT_LABEL (dd), 1); } } else if (match_cmd (cmd, "Page", &args)) { /* PAGE n: trace forward or backward by "drawing" the screen */ int k, n = int_arg (dd, fcmd, args, &rest, 1); EDLIN_T *old = CURR (dd); BOOL_T at_bound = A68_FALSE; if (!EMPTY_STRING (rest)) { TRAILING (fcmd); CURSOR_TO_COMMAND (dd, curs); return; } /* Count */ for (k = 0; k < abs (n); k++) { int lin = count_reserved (dd); EDLIN_T *z = CURR (dd), *u = z; BOOL_T cont = A68_TRUE; for (; IS_IN_TEXT (z) && cont;) { lin += lines_on_scr (dd, z); if (lin > LINES) { cont = A68_FALSE; } else { u = z; (n > 0 ? forward_line (&z) : backward_line (&z)); } } if (lin > LINES) { NEW_CURR (dd, u); } else { at_bound = A68_TRUE; NEW_CURR (dd, z); } align_current (dd); } if (CURR (dd) == old) { if (at_bound) { ASSERT (snprintf (DL0 (scr), SNPRINTF_SIZE, "%s: at file boundary", fcmd) >= 0); } else { ASSERT (snprintf (DL0 (scr), SNPRINTF_SIZE, "%s: line does not fit screen", fcmd) >= 0); } } CURSOR_TO_COMMAND (dd, curs); bufcpy (CMD (scr), "", BUFFER_SIZE); return; } else if (match_cmd (cmd, "CAse", &args)) { /* CASE: switch case of character under cursor */ EDLIN_T *lin = LINE (curs); NO_ARGS (fcmd, args); if (lin != NO_EDLIN && INDEX (curs) < (int) strlen (TEXT (lin))) { if (IS_UPPER (TEXT (lin)[INDEX (curs)])) { TEXT (lin)[INDEX (curs)] = TO_LOWER (TEXT (lin)[INDEX (curs)]); INDEX (curs)++; SYNC_LINE (curs) = lin; SYNC_INDEX (curs) = INDEX (curs); SYNC (curs) = A68_TRUE; alt_line (dd, lin); bufcpy (CMD (scr), "", BUFFER_SIZE); } else if (IS_LOWER (TEXT (lin)[INDEX (curs)])) { TEXT (lin)[INDEX (curs)] = TO_UPPER (TEXT (lin)[INDEX (curs)]); INDEX (curs)++; SYNC_LINE (curs) = lin; SYNC_INDEX (curs) = INDEX (curs); SYNC (curs) = A68_TRUE; alt_line (dd, lin); bufcpy (CMD (scr), "", BUFFER_SIZE); } } return; /* SET command */ } else if (match_cmd (cmd, "SET", &args)) { edit_set_cmd (dd, fcmd, args); bufcpy (CMD (scr), "", BUFFER_SIZE); CURSOR_TO_COMMAND (dd, curs); return; } else if (match_cmd (cmd, "Add", &args)) { /* ADD [repetition]: add lines */ EDLIN_T *z = CURR (dd); int k, n = int_arg (dd, fcmd, args, &rest, 1); if (!EMPTY_STRING (rest)) { TRAILING (fcmd); CURSOR_TO_COMMAND (dd, curs); return; } if (z != NO_EDLIN && NOT_EOF (z)) { for (k = 0; k < n; k ++) { LINE (curs) = z; INDEX (curs) = (int) strlen (TEXT (z)); split_line (dd, fcmd); } edit_reset (dd); BL_START (dd) = BL_END (dd) = NO_EDLIN; /* Cursor goes to next appended line, not the current line */ LINE (curs) = NEXT (z); SELECT (LINE (curs)) = A68_TRUE; INDEX (curs) = 0; SYNC_LINE (curs) = LINE (curs); SYNC_INDEX (curs) = 0; SYNC (curs) = A68_TRUE; bufcpy (CMD (scr), "", BUFFER_SIZE); } else { ASSERT (snprintf (DL0 (scr), SNPRINTF_SIZE, "%s: cannot add lines here", fcmd) >= 0); CURSOR_TO_COMMAND (dd, curs); } return; } else if (match_cmd (cmd, "DELete", &args)) { /* DELETE [/target/]: delete lines */ EDLIN_T *u, *z; int dels = 0; if (EMPTY_STRING (args)) { u = CURR (dd); forward_line (&u); } else { u = get_target (dd, fcmd, args, &rest, A68_TRUE); } if (!EMPTY_STRING (rest)) { TRAILING (fcmd); CURSOR_TO_COMMAND (dd, curs); return; } /* Backwards range */ if (NOT_EOF (u) && (NUMBER (u) < NUMBER (CURR (dd)))) { ASSERT (snprintf (DL0 (scr), SNPRINTF_SIZE, "%s: backward range", fcmd) >= 0); CURSOR_TO_COMMAND (dd, curs); return; } edit_write_undo_file (dd, fcmd); for (z = CURR (dd); z != u && IS_IN_TEXT (z); forward_line (&z)) { LINE (curs) = z; LAST (curs) = z; INDEX (curs) = 0; cdelete (dd); join_line (dd, fcmd); dels++; } NEW_CURR (dd, z); align_current (dd); edit_reset (dd); BL_START (dd) = BL_END (dd) = NO_EDLIN; if (dels == 0) { ASSERT (snprintf (DL0 (scr), SNPRINTF_SIZE, "%s: deleted no lines", fcmd) >= 0); } else if (dels == 1) { ASSERT (snprintf (DL0 (scr), SNPRINTF_SIZE, "%s: deleted 1 line", fcmd) >= 0); } else { ASSERT (snprintf (DL0 (scr), SNPRINTF_SIZE, "%s: deleted %d lines", fcmd, dels) >= 0); } bufcpy (CMD (scr), "", BUFFER_SIZE); CURSOR_TO_COMMAND (dd, curs); return; } else if (match_cmd (cmd, "FILE", &args) || match_cmd (cmd, "WQ", &args)) { /* FILE: save and quit */ if (EMPTY_STRING (args)) { edit_write (dd, fcmd, NAME (dd), TOF (dd), NO_EDLIN); ALTS (dd) = 0; bufcpy (CMD (scr), "", BUFFER_SIZE); CURSOR_TO_COMMAND (dd, curs); } else { EDLIN_T *u = get_target (dd, fcmd, args, &rest, A68_TRUE); SKIP_WHITE (rest); if (EMPTY_STRING (rest)) { ASSERT (snprintf (DL0 (scr), SNPRINTF_SIZE, "%s: missing filename", fcmd) >= 0); CURSOR_TO_COMMAND (dd, curs); return; } edit_write (dd, fcmd, rest, CURR (dd), u); bufcpy (CMD (scr), "", BUFFER_SIZE); CURSOR_TO_COMMAND (dd, curs); } if (errno == 0) { if ((UNDO (dd)[0]) != NULL_CHAR) { EDIT_TEST (remove (UNDO (dd)) != -1); } longjmp (EDIT_EXIT_LABEL (dd), 1); } else { CURSOR_TO_COMMAND (dd, curs); } return; } else if (match_cmd (cmd, "Read", &args)) { /* READ: read a dataset */ if (EMPTY_STRING (args)) { ASSERT (snprintf (DL0 (scr), SNPRINTF_SIZE, "%s: missing filename", fcmd) >= 0); CURSOR_TO_COMMAND (dd, curs); return; } else { edit_write_undo_file (dd, fcmd); edit_read (dd, fcmd, args, NO_EDLIN); bufcpy (CMD (scr), "", BUFFER_SIZE); CURSOR_TO_COMMAND (dd, curs); return; } } else if (match_cmd (cmd, "PF", &args)) { int n = int_arg (dd, fcmd, args, &rest, 1); if (n < 1 || n > MAX_PF) { ASSERT (snprintf (DL0 (scr), SNPRINTF_SIZE, "%s: cannot set f%d", fcmd, n) >= 0); CURSOR_TO_COMMAND (dd, curs); return; } else { ASSERT (snprintf (pf_bind[n - 1], SNPRINTF_SIZE, "%s", rest) >= 0); bufcpy (CMD (scr), "", BUFFER_SIZE); CURSOR_TO_COMMAND (dd, curs); return; } } else if (match_cmd (cmd, "SAve", &args) || match_cmd (cmd, "Write", &args)) { /* Write: save the dataset */ if (EMPTY_STRING (args)) { struct stat statbuf; edit_write (dd, fcmd, NAME (dd), TOF (dd), NO_EDLIN); if (stat (NAME (dd), &statbuf) != -1) { struct tm *tm; char datestr[BUFFER_SIZE]; PERMS (dd) = ST_MODE (&statbuf); ASSERT ((tm = localtime (&ST_MTIME (&statbuf))) != NULL); ASSERT ((strftime (datestr, BUFFER_SIZE, DATE_STRING, tm)) > 0); ASSERT (snprintf (DATE (dd), SNPRINTF_SIZE, "%s", datestr) >= 0); } ALTS (dd) = 0; bufcpy (CMD (scr), "", BUFFER_SIZE); CURSOR_TO_COMMAND (dd, curs); return; } else { EDLIN_T *u = get_target (dd, fcmd, args, &rest, A68_TRUE); SKIP_WHITE (rest); if (EMPTY_STRING (rest)) { ASSERT (snprintf (DL0 (scr), SNPRINTF_SIZE, "%s: missing filename", fcmd) >= 0); CURSOR_TO_COMMAND (dd, curs); return; } edit_write (dd, fcmd, rest, CURR (dd), u); bufcpy (CMD (scr), "", BUFFER_SIZE); CURSOR_TO_COMMAND (dd, curs); return; } } else if (match_cmd (cmd, "MSG", &args)) { /* MSG: display its argument in the message area */ ARGS (fcmd, args); bufcpy (DL0 (scr), args, BUFFER_SIZE); bufcpy (CMD (scr), "", BUFFER_SIZE); CURSOR_TO_COMMAND (dd, curs); return; } else if (match_cmd (cmd, "Undo", &args)) { /* UNDO: restore to state last saved, if any */ edit_read_undo_file (dd, fcmd); bufcpy (CMD (scr), "", BUFFER_SIZE); CURSOR_TO_COMMAND (dd, curs); return; } else if (match_cmd (cmd, "DUmp", &args)) { FILE_T fd; char buff[BUFFER_SIZE]; int j, k; NO_ARGS (fcmd, args); RESET_ERRNO; fd = open (".a68g.edit.dump", A68_WRITE_ACCESS, A68_PROTECTION); CHECK_ERRNO (fcmd); if (fd == -1) { ASSERT (snprintf (DL0 (scr), SNPRINTF_SIZE, "%s: cannot open file for writing", fcmd) >= 0); return; } for (j = 0; j < LINES; j++) { for (k = 0; k < COLS; k++) { EDIT_TEST (wmove (stdscr, j, k) != ERR); ASSERT (snprintf (buff, SNPRINTF_SIZE, "%c", (char) inch ()) >= 0); WRITE (fd, buff); } WRITE (fd, "\n"); } RESET_ERRNO; ASSERT (close (fd) == 0); CHECK_ERRNO (fcmd); bufcpy (CMD (scr), "", BUFFER_SIZE); CURSOR_TO_COMMAND (dd, curs); return; } else if (match_cmd (cmd, "Edit", &args) || match_cmd (cmd, "Xedit", &args)) { /* EDIT filename: recursively edit another file */ DATASET_T ndd; DISPLAY_T *nscr = &(DISPLAY (&ndd)); CURSOR_T *ncurs = &(CURS (nscr)); int salts = ALTS (dd); edit_write_undo_file (dd, fcmd); SCALE_ROW (nscr) = LINES / 2; CMD_ROW (nscr) = 1; IDF_ROW (nscr) = 0; CURSOR_TO_COMMAND (&ndd, ncurs); REDRAW; M_MATCH (&ndd) = NO_EDLIN; M_SO (&ndd) = -1; M_EO (&ndd) = -1; edit_dataset (&ndd, NUM (dd) + 1, args, NO_TEXT); fixed_heap_pointer = HEAP_POINTER (dd); LINBUF (dd) = NO_TEXT; LINSIZ (dd) = 0; TOF (dd) = NO_EDLIN; edit_read_undo_file (dd, fcmd); ALTS (dd) = salts; bufcpy (CMD (scr), "", BUFFER_SIZE); CURSOR_TO_COMMAND (dd, curs); return; } else if (match_cmd (cmd, "Help", &args)) { /* EDIT: recursively edit another file */ char nfn[BUFFER_SIZE]; write_help_file (EDIT_HELP_FILE, nfn); ASSERT (snprintf (CMD (scr), SNPRINTF_SIZE, "edit %s", nfn) >= 0); edit_do_cmd (dd); return; } /* Commands with targets */ if (match_cmd (cmd, "FOld", &args)) { /* FOLD [[TO] /target/]: select lines */ EDLIN_T *z; if (!EMPTY_STRING (args) && match_cmd (args, "TO", &rest)) { /* Select all lines upto matching target */ EDLIN_T *u; args = rest; u = get_target (dd, fcmd, args, &rest, A68_FALSE); if (!EMPTY_STRING (rest)) { TRAILING (fcmd); CURSOR_TO_COMMAND (dd, curs); return; } if (!IS_IN_TEXT (u)) { CURSOR_TO_COMMAND (dd, curs); return; } /* Backwards range */ if (NOT_EOF (u) && (NUMBER (u) < NUMBER (CURR (dd)))) { ASSERT (snprintf (DL0 (scr), SNPRINTF_SIZE, "%s: backward range", fcmd) >= 0); CURSOR_TO_COMMAND (dd, curs); return; } /* Empty range */ if (u == CURR (dd)) { ASSERT (snprintf (DL0 (scr), SNPRINTF_SIZE, "%s: empty range", fcmd) >= 0); CURSOR_TO_COMMAND (dd, curs); return; } for (z = TOF (dd); z != NO_EDLIN; FORWARD (z)) { SELECT (z) = A68_FALSE; } for (z = CURR (dd); z != u; FORWARD (z)) { SELECT (z) = A68_TRUE; } SUBSET (dd) = A68_TRUE; bufcpy (CMD (scr), "", BUFFER_SIZE); CURSOR_TO_COMMAND (dd, curs); M_MATCH (dd) = NO_EDLIN; M_SO (dd) = M_EO (dd) = -1; /* Show no match */ return; } else { /* FOLD [/target/]: select lines matching a target */ /* Reset all lines */ if (!EMPTY_STRING (args)) { /* Select all lines that match target */ EDLIN_T *u = get_target (dd, fcmd, args, &rest, A68_FALSE); if (!EMPTY_STRING (rest)) { TRAILING (fcmd); CURSOR_TO_COMMAND (dd, curs); return; } if (!IS_IN_TEXT (u)) { CURSOR_TO_COMMAND (dd, curs); return; } for (z = TOF (dd); z != NO_EDLIN; FORWARD (z)) { SELECT (z) = A68_FALSE; } SELECT (u) = A68_TRUE; for (z = NEXT (u); z != NO_EDLIN; FORWARD (z)) { SELECT (z) = match_regex (dd, z, 0, fcmd); } SUBSET (dd) = A68_TRUE; } else { /* UNFOLD */ for (z = TOF (dd); z != NO_EDLIN; FORWARD (z)) { SELECT (z) = A68_TRUE; } SUBSET (dd) = A68_FALSE; } NEW_CURR (dd, TOF (dd)); forward_line (&(CURR (dd))); bufcpy (CMD (scr), "", BUFFER_SIZE); CURSOR_TO_COMMAND (dd, curs); M_MATCH (dd) = NO_EDLIN; M_SO (dd) = M_EO (dd) = -1; /* Show no match */ return; } } else if (match_cmd (cmd, "Move", &args)) { /* MOVE /target/ /target/ [n]: move lines */ move_copy (dd, cmd, args, A68_TRUE); return; } else if (match_cmd (cmd, "COpy", &args)) { /* COPY /target/ /target/ [n]: copy lines */ move_copy (dd, cmd, args, A68_FALSE); } else if (match_cmd (cmd, "SHell", &args)) { if (EMPTY_STRING (args)) { ASSERT (snprintf (DL0 (scr), SNPRINTF_SIZE, "%s: missing arguments", fcmd) >= 0); CURSOR_TO_COMMAND (dd, curs); return; } else { EDLIN_T *u = get_target (dd, fcmd, args, &rest, A68_TRUE); SKIP_WHITE (rest); if (EMPTY_STRING (rest)) { ASSERT (snprintf (DL0 (scr), SNPRINTF_SIZE, "%s: missing shell command", fcmd) >= 0); CURSOR_TO_COMMAND (dd, curs); return; } edit_write_undo_file (dd, fcmd); edit_filter (dd, fcmd, rest, u); bufcpy (CMD (scr), "", BUFFER_SIZE); CURSOR_TO_COMMAND (dd, curs); return; } } else if (match_cmd (cmd, "Indent", &args)) { /* INDENT target column: indent lines to column */ indent (dd, fcmd, args); return; } else if (match_cmd (cmd, "S", &args)) { /* SUBSTITUTE /find/replace/ [C] [/target/] [repetition]: replace substrings */ int reps, start, subs = 0; BOOL_T confirm = A68_FALSE; if (!get_subst (dd, fcmd, args, &rest)) { ASSERT (snprintf (DL0 (scr), SNPRINTF_SIZE, "%s: unrecognised syntax", fcmd) >= 0); CURSOR_TO_COMMAND (dd, curs); return; } if (EMPTY_STRING (rest)) { int m; confirm = A68_FALSE; m = substitute (dd, CURR (dd), A68_MAX_INT, 1, &confirm, fcmd); if (m == SUBST_ERROR) { CURSOR_TO_COMMAND (dd, curs); return; } subs = m; } else { EDLIN_T *u, *z; int m; SKIP_WHITE (rest); if (TO_LOWER (rest[0]) == 'c') { confirm = A68_TRUE; rest++; } args = rest; u = get_target (dd, fcmd, args, &rest, A68_TRUE); if (! EMPTY_STRING (rest)) { args = rest; reps = int_arg (dd, fcmd, args, &rest, A68_MAX_INT); } else { reps = A68_MAX_INT; /* Default is global substitution */ } if (! EMPTY_STRING (rest)) { args = rest; start = int_arg (dd, fcmd, args, &rest, 1); } else { start = 1; } if (! EMPTY_STRING (rest)) { TRAILING (fcmd); CURSOR_TO_COMMAND (dd, curs); return; } /* Backwards range */ if (NOT_EOF (u) && (NUMBER (u) < NUMBER (CURR (dd)))) { ASSERT (snprintf (DL0 (scr), SNPRINTF_SIZE, "%s: backward range", fcmd) >= 0); CURSOR_TO_COMMAND (dd, curs); return; } edit_write_undo_file (dd, fcmd); for (z = CURR (dd); z != u && IS_IN_TEXT (z); forward_line (&z)) { m = substitute (dd, z, reps, start, &confirm, fcmd); if (m == SUBST_ERROR) { CURSOR_TO_COMMAND (dd, curs); return; } subs += m; } if (IS_IN_TEXT (z)) { NEW_CURR (dd, z); } } if (subs == 1) { ASSERT (snprintf (DL0 (scr), SNPRINTF_SIZE, "%s: %d occurences %sd", fcmd, subs, fcmd) >= 0); } else { ASSERT (snprintf (DL0 (scr), SNPRINTF_SIZE, "%s: %d occurences %sd", fcmd, subs, fcmd) >= 0); } bufcpy (CMD (scr), "", BUFFER_SIZE); CURSOR_TO_COMMAND (dd, curs); return; } else { /* Give error and clear the last command - sorry for the inconvenience */ ASSERT (snprintf (DL0 (scr), SNPRINTF_SIZE, "edit: undefined command \"%s\"", cmd) >= 0); bufcpy (CMD (scr), "", BUFFER_SIZE); CURSOR_TO_COMMAND (dd, curs); return; } } /*! \brief do a prefix command \param dd current dataset **/ static void edit_do_prefix (DATASET_T *dd) { DISPLAY_T *scr = &(DISPLAY (dd)); CURSOR_T *curs = &(CURS (scr)); int as = 0, cs = 0, ccs = 0, ds = 0, dds = 0, fs = 0, a68g_ffs = 0, is = 0, iis = 0, js = 0, xs = 0, xxs = 0, ps = 0, qs = 0, divs = 0, us = 0, uus = 0, total = 0; EDLIN_T *z; char *arg; /* Check prefix command */ for (z = TOF (dd); z != NO_EDLIN; FORWARD (z)) { char *p = PRECMD (z); SKIP_WHITE (p); if (match_cmd (p, "CC", &arg)) { if (NUMBER (z) == 0) { ASSERT (snprintf (DL0 (scr), SNPRINTF_SIZE, "copy: CC in invalid line") >= 0); } else { ccs++; total++; } } else if (match_cmd (p, "DD", &arg)) { if (NUMBER (z) == 0) { ASSERT (snprintf (DL0 (scr), SNPRINTF_SIZE, "delete: DD in invalid line") >= 0); } else { dds++; total++; } } else if (match_cmd (p, "FF", &arg)) { if (NUMBER (z) == 0) { ASSERT (snprintf (DL0 (scr), SNPRINTF_SIZE, "fold: FF in invalid line") >= 0); } else { a68g_ffs++; total++; } } else if (match_cmd (p, "II", &arg)) { if (NUMBER (z) == 0) { ASSERT (snprintf (DL0 (scr), SNPRINTF_SIZE, "indent: II in invalid line") >= 0); } else { iis++; total++; } } else if (match_cmd (p, "UU", &arg)) { if (NUMBER (z) == 0) { ASSERT (snprintf (DL0 (scr), SNPRINTF_SIZE, "unselect: UU in invalid line") >= 0); } else { uus++; total++; } } else if (match_cmd (p, "XX", &arg)) { if (NUMBER (z) == 0) { ASSERT (snprintf (DL0 (scr), SNPRINTF_SIZE, "move: XX in invalid line") >= 0); } else { xxs++; total++; } } else if (match_cmd (p, "A", &arg)) { as++; total++; } else if (match_cmd (p, "C", &arg)) { cs++; total++; } else if (match_cmd (p, "D", &arg)) { ds++; total++; } else if (match_cmd (p, "F", &arg)) { fs++; total++; } else if (match_cmd (p, "J", &arg)) { js++; total++; } else if (match_cmd (p, "I", &arg)) { is++; total++; } else if (match_cmd (p, "P", &arg)) { ps++; total++; } else if (match_cmd (p, "Q", &arg)) { qs++; total++; } else if (match_cmd (p, "U", &arg)) { us++; total++; } else if (match_cmd (p, "X", &arg)) { xs++; total++; } else if (match_cmd (p, "/", &arg)) { divs++; total++; } } /* Execute the command */ if (as == 1 && total == 1) { /* ADD */ for (z = TOF (dd); z != NO_EDLIN; FORWARD (z)) { char *p = PRECMD (z); EDLIN_T *cursavi = CURR (dd); SKIP_WHITE (p); if (match_cmd (p, "A", &arg)) { NEW_CURR (dd, z); ASSERT (snprintf (CMD (scr), SNPRINTF_SIZE, "add %s", arg) >= 0); edit_do_cmd (dd); edit_reset (dd); BL_START (dd) = BL_END (dd) = NO_EDLIN; NEW_CURR (dd, cursavi); align_current (dd); bufcpy (CMD (scr), "", BUFFER_SIZE); return; } } } else if (is == 1 && total == 1) { /* INDENT */ for (z = TOF (dd); z != NO_EDLIN; FORWARD (z)) { char *p = PRECMD (z); EDLIN_T *cursavi = CURR (dd); SKIP_WHITE (p); if (match_cmd (p, "I", &arg)) { NEW_CURR (dd, z); ASSERT (snprintf (CMD (scr), SNPRINTF_SIZE, "indent 1 %s", arg) >= 0); edit_do_cmd (dd); edit_reset (dd); NEW_CURR (dd, cursavi); align_current (dd); bufcpy (CMD (scr), "", BUFFER_SIZE); return; } } } else if (fs == 1 && total == 1) { /* FOLD/SELECT */ for (z = TOF (dd); z != NO_EDLIN; FORWARD (z)) { char *p = PRECMD (z); EDLIN_T *cursavi = CURR (dd); SKIP_WHITE (p); if (match_cmd (p, "F", &arg)) { NO_ARGS ("F", arg); SELECT (z) = A68_TRUE; edit_reset (dd); BL_START (dd) = BL_END (dd) = NO_EDLIN; NEW_CURR (dd, cursavi); align_current (dd); bufcpy (CMD (scr), "", BUFFER_SIZE); return; } } } else if (js == 1 && total == 1) { /* JOIN */ for (z = TOF (dd); z != NO_EDLIN; FORWARD (z)) { char *p = PRECMD (z); EDLIN_T *cursavi = CURR (dd); SKIP_WHITE (p); if (match_cmd (p, "J", &arg)) { EDLIN_T *x = NEXT (z); NO_ARGS ("J", arg); if (NUMBER (z) == 0 || x == NO_EDLIN || NUMBER (x) == 0) { ASSERT (snprintf (DL0 (scr), SNPRINTF_SIZE, "join: cannot join") >= 0); } else { NEW_CURR (dd, x); LINE (curs) = x; LAST (curs) = x; INDEX (curs) = 0; join_line (dd, "join"); } edit_reset (dd); BL_START (dd) = BL_END (dd) = NO_EDLIN; NEW_CURR (dd, cursavi); align_current (dd); bufcpy (CMD (scr), "", BUFFER_SIZE); return; } } } else if (ds == 1 && total == 1) { /* DELETE */ EDLIN_T *w; for (z = TOF (dd); z != NO_EDLIN; FORWARD (z)) { char *p = PRECMD (z); SKIP_WHITE (p); if (match_cmd (p, "D", &arg)) { w = CURR (dd); NEW_CURR (dd, z); if (EMPTY_STRING (arg)) { ASSERT (snprintf (CMD (scr), SNPRINTF_SIZE, "delete") >= 0); } else { ASSERT (snprintf (CMD (scr), SNPRINTF_SIZE, "delete %s", arg) >= 0); } edit_do_cmd (dd); if (w == z) { NEW_CURR (dd, PREVIOUS (w)); } else { NEW_CURR (dd, w); } edit_reset (dd); BL_START (dd) = BL_END (dd) = NO_EDLIN; align_current (dd); bufcpy (CMD (scr), "", BUFFER_SIZE); return; } } } else if (us == 1 && total == 1) { /* UNSELECT */ for (z = TOF (dd); z != NO_EDLIN; FORWARD (z)) { char *p = PRECMD (z); EDLIN_T *cursavi = CURR (dd); SKIP_WHITE (p); if (match_cmd (p, "U", &arg)) { NO_ARGS ("U", arg); SELECT (z) = A68_FALSE; edit_reset (dd); BL_START (dd) = BL_END (dd) = NO_EDLIN; NEW_CURR (dd, cursavi); align_current (dd); bufcpy (CMD (scr), "", BUFFER_SIZE); return; } } } else if (divs == 1 && total == 1) { /* Set current line */ for (z = TOF (dd); z != NO_EDLIN; FORWARD (z)) { char *p = PRECMD (z); SKIP_WHITE (p); if (match_cmd (p, "/", &arg)) { NO_ARGS ("/", arg); NEW_CURR (dd, z); edit_reset (dd); align_current (dd); bufcpy (CMD (scr), "", BUFFER_SIZE); return; } } } else if (dds == 2 && total == 2) { /* DELETE block */ EDLIN_T *u = NO_EDLIN, *v = NO_EDLIN, *w = CURR (dd); for (z = TOF (dd); z != NO_EDLIN; FORWARD (z)) { char *p = PRECMD (z); SKIP_WHITE (p); if (match_cmd (p, "DD", &arg)) { NO_ARGS ("DD", arg); if (u == NO_EDLIN) { u = z; } else { v = z; } } } NEW_CURR (dd, u); if (IS_EOF (v)) { ASSERT (snprintf (CMD (scr), SNPRINTF_SIZE, "delete *") >= 0); } else { ASSERT (snprintf (CMD (scr), SNPRINTF_SIZE, "delete :%d+1", NUMBER (v)) >= 0); } edit_do_cmd (dd); if (NUMBER (u) <= NUMBER (w) && NUMBER (w) <= NUMBER (v)) { NEW_CURR (dd, PREVIOUS (w)); } else { NEW_CURR (dd, w); } edit_reset (dd); BL_START (dd) = BL_END (dd) = NO_EDLIN; align_current (dd); bufcpy (CMD (scr), "", BUFFER_SIZE); return; } else if (a68g_ffs == 2 && total == 2) { /* FOLD/SELECT block */ EDLIN_T *u = NO_EDLIN, *v = NO_EDLIN, *cursavi = CURR (dd); for (z = TOF (dd); z != NO_EDLIN; FORWARD (z)) { char *p = PRECMD (z); SKIP_WHITE (p); if (match_cmd (p, "FF", &arg)) { if (u == NO_EDLIN) { NO_ARGS ("fold", arg); u = z; } else { NO_ARGS ("fold", arg); v = z; } } } for (z = TOF (dd); z != NO_EDLIN; FORWARD (z)) { SELECT (z) = A68_FALSE; } for (z = u; z != v; FORWARD (z)) { SELECT (z) = A68_TRUE; } edit_reset (dd); BL_START (dd) = BL_END (dd) = NO_EDLIN; NEW_CURR (dd, cursavi); align_current (dd); bufcpy (CMD (scr), "", BUFFER_SIZE); return; } else if (iis == 2 && total == 2) { /* INDENT block */ EDLIN_T *u = NO_EDLIN, *v = NO_EDLIN, *cursavi = CURR (dd); char upto[BUFFER_SIZE]; char *rep = NO_TEXT; for (z = TOF (dd); z != NO_EDLIN; FORWARD (z)) { char *p = PRECMD (z); SKIP_WHITE (p); if (match_cmd (p, "II", &arg)) { if (u == NO_EDLIN) { rep = arg; u = z; } else { NO_ARGS ("indent", arg); v = z; } } } NEW_CURR (dd, u); if (IS_EOF (v)) { ASSERT (snprintf (upto, BUFFER_SIZE - 1, "*") >= 0); } else if (NOT_EOF (v)) { ASSERT (snprintf (upto, BUFFER_SIZE - 1, ":%d+1", NUMBER (v)) >= 0); } if (EMPTY_STRING (rep)) { ASSERT (snprintf (DL0 (scr), SNPRINTF_SIZE, "indent: expected column number") >= 0); } else { ASSERT (snprintf (CMD (scr), SNPRINTF_SIZE, "indent %s %s", upto, rep) >= 0); edit_do_cmd (dd); edit_reset (dd); } NEW_CURR (dd, cursavi); align_current (dd); bufcpy (CMD (scr), "", BUFFER_SIZE); return; } else if (uus == 2 && total == 2) { /* UNSELECT block */ EDLIN_T *u = NO_EDLIN, *v = NO_EDLIN, *cursavi = CURR (dd); for (z = TOF (dd); z != NO_EDLIN; FORWARD (z)) { char *p = PRECMD (z); SKIP_WHITE (p); if (match_cmd (p, "UU", &arg)) { if (u == NO_EDLIN) { NO_ARGS ("unselect", arg); u = z; } else { NO_ARGS ("unselect", arg); v = z; } } } for (z = u; z != v; FORWARD (z)) { SELECT (z) = A68_FALSE; } edit_reset (dd); BL_START (dd) = BL_END (dd) = NO_EDLIN; NEW_CURR (dd, cursavi); align_current (dd); bufcpy (CMD (scr), "", BUFFER_SIZE); return; } else if ((ccs == 2 || xxs == 2) && (ps == 1 || qs == 1) && total == 3) { /* COPY or MOVE block */ EDLIN_T *u = NO_EDLIN, *v = NO_EDLIN, *w = NO_EDLIN, *cursavi = CURR (dd); char upto[BUFFER_SIZE], ins[BUFFER_SIZE]; char *cmd = NO_TEXT, *delim = NO_TEXT, *rep = NO_TEXT; if (ccs == 2) { cmd = "copy"; delim = "CC"; } else if (xxs == 2) { cmd = "move"; delim = "XX"; } for (z = TOF (dd); z != NO_EDLIN; FORWARD (z)) { char *p = PRECMD (z); SKIP_WHITE (p); if (match_cmd (p, delim, &arg)) { NO_ARGS (delim, arg); if (u == NO_EDLIN) { u = z; } else { v = z; } } else if (match_cmd (p, "P", &arg)) { rep = arg; w = z; } else if (match_cmd (p, "Q", &arg)) { rep = arg; w = z; } } NEW_CURR (dd, u); if (IS_EOF (v)) { ASSERT (snprintf (upto, BUFFER_SIZE - 1, "*") >= 0); } else if (NOT_EOF (v)) { ASSERT (snprintf (upto, BUFFER_SIZE - 1, ":%d+1", NUMBER (v)) >= 0); } if (IS_EOF (w) && ps == 1) { ASSERT (snprintf (ins, BUFFER_SIZE - 1, "*") >= 0); } else if (IS_EOF (w) && qs == 1) { ASSERT (snprintf (ins, BUFFER_SIZE - 1, "*-1") >= 0); } else if (NOT_EOF (w) && ps == 1) { ASSERT (snprintf (ins, BUFFER_SIZE - 1, ":%d", NUMBER (w)) >= 0); } else if (NOT_EOF (w) && qs == 1) { ASSERT (snprintf (ins, BUFFER_SIZE - 1, ":%d-1", NUMBER (w)) >= 0); } if (EMPTY_STRING (rep)) { ASSERT (snprintf (CMD (scr), SNPRINTF_SIZE, "%s %s %s", cmd, upto, ins) >= 0); } else { ASSERT (snprintf (CMD (scr), SNPRINTF_SIZE, "%s %s %s %s", cmd, upto, ins, rep) >= 0); } edit_do_cmd (dd); edit_reset (dd); NEW_CURR (dd, cursavi); align_current (dd); bufcpy (CMD (scr), "", BUFFER_SIZE); return; } else if ((cs == 1 || xs == 1) && (ps == 1 || qs == 1) && total == 2) { /* COPY or MOVE line */ EDLIN_T *u = NO_EDLIN, *w = NO_EDLIN, *cursavi = CURR (dd); char ins[BUFFER_SIZE]; char *cmd = NO_TEXT, *delim = NO_TEXT, *target = NO_TEXT, *rep = NO_TEXT; if (cs == 1) { cmd = "copy"; delim = "C"; } else if (xs == 1) { cmd = "move"; delim = "X"; } for (z = TOF (dd); z != NO_EDLIN; FORWARD (z)) { char *p = PRECMD (z); SKIP_WHITE (p); if (match_cmd (p, delim, &arg)) { target = arg; u = z; } else if (match_cmd (p, "P", &arg)) { rep = arg; w = z; } else if (match_cmd (p, "Q", &arg)) { rep = arg; w = z; } } NEW_CURR (dd, u); if (IS_EOF (w) && ps == 1) { ASSERT (snprintf (ins, BUFFER_SIZE - 1, "*") >= 0); } else if (IS_EOF (w) && qs == 1) { ASSERT (snprintf (ins, BUFFER_SIZE - 1, "*-1") >= 0); } else if (NOT_EOF (w) && ps == 1) { ASSERT (snprintf (ins, BUFFER_SIZE - 1, ":%d", NUMBER (w)) >= 0); } else if (NOT_EOF (w) && qs == 1) { ASSERT (snprintf (ins, BUFFER_SIZE - 1, ":%d-1", NUMBER (w)) >= 0); } if (EMPTY_STRING (target) && EMPTY_STRING (rep)) { ASSERT (snprintf (CMD (scr), SNPRINTF_SIZE, "%s 1 %s", cmd, ins) >= 0); } else if (EMPTY_STRING (target) && !EMPTY_STRING (rep)) { ASSERT (snprintf (CMD (scr), SNPRINTF_SIZE, "%s 1 %s %s", cmd, ins, rep) >= 0); } else if (!EMPTY_STRING (target) && EMPTY_STRING (rep)) { ASSERT (snprintf (CMD (scr), SNPRINTF_SIZE, "%s %s %s", cmd, target, ins) >= 0); } else if (!EMPTY_STRING (target) && !EMPTY_STRING (rep)) { ASSERT (snprintf (CMD (scr), SNPRINTF_SIZE, "%s %s %s %s", cmd, target, ins, rep) >= 0); } ASSERT (snprintf (TMP_TEXT (scr), SNPRINTF_SIZE, "%s", CMD (scr)) >= 0); edit_do_cmd (dd); edit_reset (dd); NEW_CURR (dd, cursavi); align_current (dd); bufcpy (CMD (scr), "", BUFFER_SIZE); return; } else if ((ps == 1 || qs == 1) && total == 1) { /* COPY previous block */ EDLIN_T *u = BL_START (dd), *v = BL_END (dd), *w = NO_EDLIN, *cursavi = CURR (dd); char upto[BUFFER_SIZE], ins[BUFFER_SIZE]; char *cmd = "copy", *rep = NO_TEXT; if (u == NO_EDLIN || v == NO_EDLIN) { ASSERT (snprintf (DL0 (scr), SNPRINTF_SIZE, "copy: no previous block") >= 0); return; } for (z = TOF (dd); z != NO_EDLIN; FORWARD (z)) { char *p = PRECMD (z); SKIP_WHITE (p); if (match_cmd (p, "P", &arg)) { rep = arg; w = z; } else if (match_cmd (p, "Q", &arg)) { rep = arg; w = z; } } NEW_CURR (dd, u); if (IS_EOF (v)) { ASSERT (snprintf (upto, BUFFER_SIZE - 1, "*") >= 0); } else if (u == v) { ASSERT (snprintf (upto, BUFFER_SIZE - 1, "1") >= 0); } else if (NOT_EOF (v)) { ASSERT (snprintf (upto, BUFFER_SIZE - 1, ":%d+1", NUMBER (v)) >= 0); } if (IS_EOF (w) && ps == 1) { ASSERT (snprintf (ins, BUFFER_SIZE - 1, "*") >= 0); } else if (IS_EOF (w) && qs == 1) { ASSERT (snprintf (ins, BUFFER_SIZE - 1, "*-1") >= 0); } else if (NOT_EOF (w) && ps == 1) { ASSERT (snprintf (ins, BUFFER_SIZE - 1, ":%d", NUMBER (w)) >= 0); } else if (NOT_EOF (w) && qs == 1) { ASSERT (snprintf (ins, BUFFER_SIZE - 1, ":%d-1", NUMBER (w)) >= 0); } if (EMPTY_STRING (rep)) { ASSERT (snprintf (CMD (scr), SNPRINTF_SIZE, "%s %s %s", cmd, upto, ins) >= 0); } else { ASSERT (snprintf (CMD (scr), SNPRINTF_SIZE, "%s %s %s %s", cmd, upto, ins, rep) >= 0); } edit_do_cmd (dd); edit_reset (dd); NEW_CURR (dd, cursavi); align_current (dd); bufcpy (CMD (scr), "", BUFFER_SIZE); return; } ASSERT (snprintf (DL0 (scr), SNPRINTF_SIZE, "edit: unrecognised prefix command") >= 0); } /*! \brief execute command from function key \param dd current dataset \param cmd command bound to key **/ static void key_command (DATASET_T *dd, char *cmd) { DISPLAY_T *scr = &(DISPLAY (dd)); CURSOR_T *curs = &(CURS (scr)); SAVE_CURSOR (dd, curs); bufcpy (CMD (scr), cmd, BUFFER_SIZE); edit_do_cmd (dd); CURSOR_TO_SAVE (dd, curs); REDRAW; } /*! \brief editor loop: get a key and do something with it \param dd current dataset **/ static void edit_loop (DATASET_T *dd) { DISPLAY_T *scr = &(DISPLAY (dd)); CURSOR_T *curs = &(CURS (scr)); for (;;) { int ch, k; loop_cnt ++; /* Redraw the screen ... */ edit_draw (dd); /* ... and set the cursor like this or else ncurses can misplace it :-( */ EDIT_TEST (wmove (stdscr, ROW (curs), COL (curs)) != ERR); EDIT_TEST (wrefresh (stdscr) != ERR); bufcpy (DL0 (scr), "", BUFFER_SIZE); ch = wgetch (stdscr); if (ch == ESCAPE_CHAR) { /* Curses does not decode all keys on all terminals. You may notice this when some function keys appear as escape sequences. This is probably a bug of those terminals; we work around a number of them: Get some CSI/SS2/SS3 sequences from different terminals. */ char esc[8] = {NULL_CHAR, NULL_CHAR, NULL_CHAR, NULL_CHAR, NULL_CHAR, NULL_CHAR, NULL_CHAR, NULL_CHAR}; int j = 0, n = 0, m = 0; BOOL_T cont = A68_TRUE; while (cont && j < 6) { esc[j] = (char) ch; n = 0; for (k = 0; CODE (&dec_key[k]) >= 0; k++) { if (strncmp (NAME (&dec_key[k]), esc, (size_t) (j + 1)) == 0) { n++; m = k; } } if (n == 0) { ch = '~'; ASSERT (snprintf (DL0 (scr), SNPRINTF_SIZE, "edit: undefined escape sequence %s", &esc[1]) >= 1); cont = A68_FALSE; } else if (n == 1) { for (j++ ; j != (int) strlen (NAME (&dec_key[m])); j++) { esc[j] = (char) wgetch (stdscr); } if (strcmp (NAME (&dec_key[m]), esc) == 0) { ch = CODE (&dec_key[m]); } else { ch = '~'; ASSERT (snprintf (DL0 (scr), SNPRINTF_SIZE, "edit: undefined escape sequence %s", &esc[1]) >= 1); } cont = A68_FALSE; } else if (n > 1) { ch = wgetch (stdscr); j++; } } } /* Substitute keys for uniform behaviour */ for (k = 0; CODE (&trans_tab[k]) >= 0; k++) { if (ch == CODE (&trans_tab[k])) { ch = TRANS (&trans_tab[k]); } } /* Interprete the key */ if (KEY_F0 < ch && ch <= KEY_F0 + 24) { /* PF keys */ for (k = 0; k < 24; k++) { if (ch == KEY_F0 + k + 1) { if ((int) strlen (pf_bind[k]) == 0) { ASSERT (snprintf (DL0 (scr), SNPRINTF_SIZE, "edit: PF%02d has no command", k + 1) >= 0); } else { SAVE_CURSOR (dd, curs); bufcpy (CMD (scr), pf_bind[k], BUFFER_SIZE); edit_do_cmd (dd); REDRAW; if (! match_cmd (pf_bind[k], "TOGGLE", NO_VAR) && ! match_cmd (pf_bind[k], "CASE", NO_VAR)) { CURSOR_TO_SAVE (dd, curs); } } } } /* Prefix editing */ } else if (ch <= UCHAR_MAX && IS_PRINT (ch) && IN_PREFIX (curs)) { edit_prefix (dd, ch); } else if ((ch == KEY_BACKSPACE || ch == BACKSPACE || ch == KEY_DC) && IN_PREFIX (curs)) { edit_prefix (dd, ch); } else if (ch == NEWLINE_CHAR && IN_PREFIX (curs)) { SAVE_CURSOR (dd, curs); edit_do_prefix (dd); CURSOR_TO_SAVE (dd, curs); REDRAW; /* Command line editing */ } else if (ch <= UCHAR_MAX && IS_PRINT (ch) && IN_CMD (curs)) { edit_cmd (dd, ch); } else if ((ch == KEY_BACKSPACE || ch == BACKSPACE || ch == KEY_DC) && IN_CMD (curs)) { edit_cmd (dd, ch); } else if (ch == NEWLINE_CHAR && IN_CMD (curs)) { edit_add_history (CMD (scr)); edit_do_cmd (dd); REDRAW; ROW (curs) = -1; COL (curs) = -1; /* Text editing */ } else if (ch <= UCHAR_MAX && (IS_PRINT (ch) || ch == '\t') && IN_TEXT (curs)) { edit_text (dd, ch); } else if ((ch == KEY_BACKSPACE || ch == BACKSPACE || ch == KEY_DC) && !IN_FORBIDDEN (curs)) { edit_text (dd, ch); } else if (ch == NEWLINE_CHAR && !IN_FORBIDDEN (curs)) { split_line (dd, "edit"); edit_reset (dd); BL_START (dd) = BL_END (dd) = NO_EDLIN; if (SIZE (dd) == 1) { NEW_CURR (dd, NEXT (TOF (dd))); } #if defined KEY_RESIZE } else if (ch == KEY_RESIZE) { /* Resize event triggers reinitialisation */ edit_write_history (); EDIT_TEST (endwin () != ERR); edit_init_curses (dd); edit_read_history (dd); #endif } else if (ch == KEY_MOUSE) { /* Mouse control is basic: you can point with the cursor but little else */ #if defined USE_MOUSE MEVENT event; if (getmouse (&event) != ERR) { BSTATE (curs) = BSTATE (&event); if (BSTATE (&event) & (BUTTON1_CLICKED | BUTTON1_DOUBLE_CLICKED | BUTTON1_PRESSED | BUTTON1_RELEASED)) { if (reserved_row (dd, Y (&event)) && Y (&event) != CMD_ROW (scr)) { PROTECTED ("edit"); } else { ROW (curs) = Y (&event); COL (curs) = X (&event); } } else if (BSTATE (&event) & (BUTTON3_CLICKED | BUTTON3_DOUBLE_CLICKED | BUTTON3_PRESSED | BUTTON3_RELEASED)) { if (reserved_row (dd, Y (&event)) && Y (&event) != CMD_ROW (scr)) { PROTECTED ("edit"); } else { ROW (curs) = Y (&event); COL (curs) = X (&event); } } } #endif /* defined USE_MOUSE */ /* Keyboard control keys */ } else if (ch == KEY_UP) { int u = ROW (curs); do { u = (u == 0 ? LINES - 1 : u - 1); } while (reserved_row (dd, u) && u != CMD_ROW (scr)); ROW (curs) = u; } else if (ch == KEY_DOWN) { int u = ROW (curs); do { u = (u == LINES - 1 ? 0 : u + 1); } while (reserved_row (dd, u) && u != CMD_ROW (scr)); ROW (curs) = u; } else if (ch == KEY_CTRL ('W') && ROW (curs) == CMD_ROW (scr)) { if (histcurr >= 0) { if (histprev >= 0) { bufcpy (CMD (scr), history[histprev], BUFFER_SIZE); edit_set_history (histprev); } } } else if (ch == KEY_CTRL ('X') && ROW (curs) == CMD_ROW (scr)) { if (histcurr >= 0) { if (histnext >= 0) { bufcpy (CMD (scr), history[histnext], BUFFER_SIZE); edit_set_history (histnext); } } } else if (ch == KEY_RIGHT) { COL (curs) = (COL (curs) == COLS - 1 ? 0 : COL (curs) + 1); } else if (ch == KEY_LEFT) { COL (curs) = (COL (curs) == 0 ? COLS - 1 : COL (curs) - 1); } else if (ch == KEY_NPAGE || ch == KEY_C3) { key_command (dd, "page +1"); } else if (ch == KEY_PPAGE || ch == KEY_A3) { key_command (dd, "page -1"); } else if (ch == KEY_HOME || ch == KEY_A1) { key_command (dd, "-*"); } else if (ch == KEY_END || ch == KEY_C1) { key_command (dd, "+*"); } else if (ch == KEY_SLEFT || ch == KEY_CTRL('A')) { if (IN_TEXT (curs) || IN_CMD (curs)) { INDEX (curs) = 0; COL (curs) = MARGIN; } else { PROTECTED ("edit"); } } else if (ch == KEY_SRIGHT || ch == KEY_CTRL ('D')) { if (IN_TEXT (curs)) { INDEX (curs) = (int) strlen (TEXT (LINE (curs))); SYNC_INDEX (curs) = INDEX (curs); SYNC_LINE (curs) = LINE (curs); SYNC (curs) = A68_TRUE; } else if (IN_CMD (curs)) { INDEX (curs) = (int) strlen (CMD (scr)); COL (curs) = MARGIN + INDEX (curs); } else { PROTECTED ("edit"); } } else if (ch == KEY_B2) { if (IN_TEXT (curs)) { if (LINE (curs) != NO_EDLIN && NUMBER (LINE (curs)) > 0) { NEW_CURR (dd, LINE (curs)); SYNC_INDEX (curs) = 0; SYNC_LINE (curs) = CURR (dd); SYNC (curs) = A68_TRUE; } } else { PROTECTED ("edit"); } /* Other keys */ } else if (ch == KEY_IC) { INS_MODE (scr) = !INS_MODE (scr); } else if (ch > 127) { if (IN_FORBIDDEN (curs)) { PROTECTED ("edit"); goto end; } for (k = 0; CODE (&key_tab[k]) >= 0; k++) { if (ch == CODE (&key_tab[k])) { /* File a complaint. */ ASSERT (snprintf (DL0 (scr), SNPRINTF_SIZE, "edit: undefined key %s", NAME (&key_tab[k])) >= 1); goto end; } } /* ASSERT (snprintf (DL0 (scr), SNPRINTF_SIZE, "edit: undefined key %d", ch) >= 0); */ } end: continue; } } /*! \brief edit a dataset \param dd current dataset \param num number of dataset \param filename file to edit \param target optional target for initial current line **/ static void edit_dataset (DATASET_T *dd, int num, char *filename, char *target) { DISPLAY_T *scr = &(DISPLAY (dd)); CURSOR_T *curs = &(CURS (scr)); bufcpy (NAME (dd), filename, BUFFER_SIZE); TABS (dd) = TAB_STOP; HEAP_POINTER (dd) = fixed_heap_pointer; /* Init edit */ DL0 (&DISPLAY (dd))[0] = NULL_CHAR; CMD (&DISPLAY (dd))[0] = NULL_CHAR; LINBUF (dd) = NO_TEXT; LINSIZ (dd) = 0; COLLECT (dd) = A68_FALSE; edit_read_initial (dd, "edit"); XABEND (heap_full (BUFFER_SIZE), "out of memory", NO_TEXT); COLLECT (dd) = A68_TRUE; INS_MODE (&DISPLAY (dd)) = A68_TRUE; MSGS (dd) = -1; /* File not open */ NUM (dd) = num; UNDO_LINE (dd) = 0; SEARCH (dd) = 0; BL_START (dd) = BL_END (dd) = NO_EDLIN; M_MATCH (dd) = NO_EDLIN; M_SO (dd) = M_EO (dd) = -1; /* No match */ if (target != NO_TEXT && (int) (strlen (target)) > 0) { char *rest; EDLIN_T *z = get_target (dd, "edit", target, &rest, A68_TRUE); if (z != NO_EDLIN) { NEW_CURR (dd, z); } else { ASSERT (snprintf (DL0 (&DISPLAY (dd)), SNPRINTF_SIZE, "edit: optional target not set") >= 0); } } if (!a68g_mkstemp (UNDO (dd), A68_WRITE_ACCESS, A68_PROTECTION)) { (UNDO (dd))[0] = NULL_CHAR; ASSERT (snprintf (DL0 (&DISPLAY (dd)), SNPRINTF_SIZE, "edit: cannot open temporary file for undo") >= 0); } EDIT_TEST (remove (UNDO (dd)) != -1); CURSOR_TO_COMMAND (dd, curs); loop_cnt = 0; if (setjmp (EDIT_EXIT_LABEL (dd)) == 0) { edit_loop (dd); } } /*! \brief edit main routine \param start_text not used **/ void edit (char *start_text) { DATASET_T dataset; DISPLAY_T *scr = &(DISPLAY (&dataset)); int k; (void) start_text; genie_init_rng (); for (k = 0; k < HISTORY; k++) { bufcpy (history[k], "", BUFFER_SIZE); } for (k = 0; k < MAX_PF; k++) { pf_bind[k][0] = NULL_CHAR; } ASSERT (snprintf (pf_bind[0], SNPRINTF_SIZE, "toggle") >= 0); ASSERT (snprintf (pf_bind[1], SNPRINTF_SIZE, "-1") >= 0); ASSERT (snprintf (pf_bind[2], SNPRINTF_SIZE, "+1") >= 0); ASSERT (snprintf (pf_bind[3], SNPRINTF_SIZE, "again") >= 0); ASSERT (snprintf (pf_bind[4], SNPRINTF_SIZE, "case") >= 0); ASSERT (snprintf (pf_bind[5], SNPRINTF_SIZE, "cdelete") >= 0); ASSERT (snprintf (pf_bind[6], SNPRINTF_SIZE, "syntax") >= 0); ASSERT (snprintf (pf_bind[7], SNPRINTF_SIZE, "message") >= 0); ASSERT (snprintf (pf_bind[11], SNPRINTF_SIZE, "toggle") >= 0); if (FILE_INITIAL_NAME (&program) == NO_TEXT) { #if ! defined HAVE_WIN32 errno = ENOTSUP; #endif /* ! defined HAVE_WIN32 */ SCAN_ERROR (A68_TRUE, NO_LINE, NO_TEXT, "edit: no filename"); } /* Init ncurses */ edit_init_curses (&dataset); edit_init_colours (&dataset); edit_read_history (&dataset); edit_dataset (&dataset, 1, FILE_INITIAL_NAME (&program), OPTION_TARGET (&program)); /* Exit edit */ edit_write_history (); EDIT_TEST (wclear (stdscr) != ERR); EDIT_TEST (wrefresh (stdscr) != ERR); EDIT_TEST (endwin () != ERR); exit (EXIT_SUCCESS); } #endif /* HAVE_EDITOR */ algol68g-2.4.1/source/environ.c0000644000175000001440000214342211770453650013222 00000000000000/*! \file environ.c \brief standard prelude implementation */ /* This file is part of Algol68G - an Algol 68 interpreter. Copyright (C) 2001-2012 J. Marcel van der Veer . This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 3 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see . */ #if defined HAVE_CONFIG_H #include "a68g-config.h" #endif #include "a68g.h" #define A68_STD A68_TRUE #define A68_EXT A68_FALSE TABLE_T *a68g_standenv; static MOID_T *proc_int, *proc_real, *proc_real_real, *proc_real_real_real, *proc_real_real_real_real, *proc_complex_complex, *proc_bool, *proc_char, *proc_void; /*! \brief enter tag in standenv symbol table \param portable whether portable \param a attribute \param n node where defined \param c name of token \param m moid of token \param p priority, if applicable \param q interpreter routine that executes this token **/ static void add_a68g_standenv (BOOL_T portable, int a, NODE_T * n, char *c, MOID_T * m, int p, GPROC * q) { #define INSERT_TAG(l, n) {\ NEXT (n) = *(l);\ *(l) = (n);\ } TAG_T *new_one = new_tag (); PROCEDURE_LEVEL (INFO (n)) = 0; USE (new_one) = A68_FALSE; HEAP (new_one) = HEAP_SYMBOL; TAG_TABLE (new_one) = a68g_standenv; NODE (new_one) = n; VALUE (new_one) = (c != NO_TEXT ? TEXT (add_token (&top_token, c)) : NO_TEXT); PRIO (new_one) = p; PROCEDURE (new_one) = q; A68G_STANDENV_PROC (new_one) = (BOOL_T) (q != NO_GPROC); UNIT (new_one) = NULL; PORTABLE (new_one) = portable; MOID (new_one) = m; NEXT (new_one) = NO_TAG; if (a == IDENTIFIER) { INSERT_TAG (&IDENTIFIERS (a68g_standenv), new_one); } else if (a == OP_SYMBOL) { INSERT_TAG (&OPERATORS (a68g_standenv), new_one); } else if (a == PRIO_SYMBOL) { INSERT_TAG (&PRIO (a68g_standenv), new_one); } else if (a == INDICANT) { INSERT_TAG (&INDICANTS (a68g_standenv), new_one); } else if (a == LABEL) { INSERT_TAG (&LABELS (a68g_standenv), new_one); } #undef INSERT_TAG } /*! \brief compose PROC moid from arguments - first result, than arguments \param m result moid \return entry in mode table **/ static MOID_T *a68_proc (MOID_T * m, ...) { MOID_T *y, **z = &TOP_MOID (&program); PACK_T *p = NO_PACK, *q = NO_PACK; va_list attribute; va_start (attribute, m); while ((y = va_arg (attribute, MOID_T *)) != NO_MOID) { PACK_T *new_one = new_pack (); MOID (new_one) = y; TEXT (new_one) = NO_TEXT; NEXT (new_one) = NO_PACK; if (q != NO_PACK) { NEXT (q) = new_one; } else { p = new_one; } q = new_one; } va_end (attribute); return (add_mode (z, PROC_SYMBOL, count_pack_members (p), NO_NODE, m, p)); } /*! \brief enter an identifier in standenv \param n name of identifier \param m mode of identifier \param q interpreter routine that executes this token **/ static void a68_idf (BOOL_T portable, char *n, MOID_T * m, GPROC * q) { add_a68g_standenv (portable, IDENTIFIER, some_node (TEXT (add_token (&top_token, n))), NO_TEXT, m, 0, q); } /*! \brief enter a moid in standenv \param p sizety \param t name of moid \param m will point to entry in mode table **/ static void a68_mode (int p, char *t, MOID_T ** m) { (*m) = add_mode (&TOP_MOID (&program), STANDARD, p, some_node (TEXT (find_keyword (top_keyword, t))), NO_MOID, NO_PACK); } /*! \brief enter a priority in standenv \param p name of operator \param b priority of operator **/ static void a68_prio (char *p, int b) { add_a68g_standenv (A68_TRUE, PRIO_SYMBOL, some_node (TEXT (add_token (&top_token, p))), NO_TEXT, NO_MOID, b, NO_GPROC); } /*! \brief enter operator in standenv \param n name of operator \param m mode of operator \param q interpreter routine that executes this token **/ static void a68_op (BOOL_T portable, char *n, MOID_T * m, GPROC * q) { add_a68g_standenv (portable, OP_SYMBOL, some_node (TEXT (add_token (&top_token, n))), NO_TEXT, m, 0, q); } /*! \brief enter standard modes in standenv **/ static void stand_moids (void) { MOID_T *m; PACK_T *z; /* Primitive A68 moids */ a68_mode (0, "VOID", &MODE (VOID)); /* Standard precision */ a68_mode (0, "INT", &MODE (INT)); a68_mode (0, "REAL", &MODE (REAL)); a68_mode (0, "COMPLEX", &MODE (COMPLEX)); a68_mode (0, "COMPL", &MODE (COMPL)); a68_mode (0, "BITS", &MODE (BITS)); a68_mode (0, "BYTES", &MODE (BYTES)); /* Multiple precision */ a68_mode (1, "INT", &MODE (LONG_INT)); a68_mode (1, "REAL", &MODE (LONG_REAL)); a68_mode (1, "COMPLEX", &MODE (LONG_COMPLEX)); a68_mode (1, "COMPL", &MODE (LONG_COMPL)); a68_mode (1, "BITS", &MODE (LONG_BITS)); a68_mode (1, "BYTES", &MODE (LONG_BYTES)); a68_mode (2, "REAL", &MODE (LONGLONG_REAL)); a68_mode (2, "INT", &MODE (LONGLONG_INT)); a68_mode (2, "COMPLEX", &MODE (LONGLONG_COMPLEX)); a68_mode (2, "COMPL", &MODE (LONGLONG_COMPL)); a68_mode (2, "BITS", &MODE (LONGLONG_BITS)); /* Other */ a68_mode (0, "BOOL", &MODE (BOOL)); a68_mode (0, "CHAR", &MODE (CHAR)); a68_mode (0, "STRING", &MODE (STRING)); a68_mode (0, "FILE", &MODE (FILE)); a68_mode (0, "CHANNEL", &MODE (CHANNEL)); a68_mode (0, "PIPE", &MODE (PIPE)); a68_mode (0, "FORMAT", &MODE (FORMAT)); a68_mode (0, "SEMA", &MODE (SEMA)); a68_mode (0, "SOUND", &MODE (SOUND)); PORTABLE (MODE (PIPE)) = A68_FALSE; HAS_ROWS (MODE (SOUND)) = A68_TRUE; PORTABLE (MODE (SOUND)) = A68_FALSE; /* ROWS */ MODE (ROWS) = add_mode (&TOP_MOID (&program), ROWS_SYMBOL, 0, NO_NODE, NO_MOID, NO_PACK); /* REFs */ MODE (REF_INT) = add_mode (&TOP_MOID (&program), REF_SYMBOL, 0, NO_NODE, MODE (INT), NO_PACK); MODE (REF_REAL) = add_mode (&TOP_MOID (&program), REF_SYMBOL, 0, NO_NODE, MODE (REAL), NO_PACK); MODE (REF_COMPLEX) = MODE (REF_COMPL) = add_mode (&TOP_MOID (&program), REF_SYMBOL, 0, NO_NODE, MODE (COMPLEX), NO_PACK); MODE (REF_BITS) = add_mode (&TOP_MOID (&program), REF_SYMBOL, 0, NO_NODE, MODE (BITS), NO_PACK); MODE (REF_BYTES) = add_mode (&TOP_MOID (&program), REF_SYMBOL, 0, NO_NODE, MODE (BYTES), NO_PACK); MODE (REF_FORMAT) = add_mode (&TOP_MOID (&program), REF_SYMBOL, 0, NO_NODE, MODE (FORMAT), NO_PACK); MODE (REF_PIPE) = add_mode (&TOP_MOID (&program), REF_SYMBOL, 0, NO_NODE, MODE (PIPE), NO_PACK); /* Multiple precision */ MODE (REF_LONG_INT) = add_mode (&TOP_MOID (&program), REF_SYMBOL, 0, NO_NODE, MODE (LONG_INT), NO_PACK); MODE (REF_LONG_REAL) = add_mode (&TOP_MOID (&program), REF_SYMBOL, 0, NO_NODE, MODE (LONG_REAL), NO_PACK); MODE (REF_LONG_COMPLEX) = MODE (REF_LONG_COMPL) = add_mode (&TOP_MOID (&program), REF_SYMBOL, 0, NO_NODE, MODE (LONG_COMPLEX), NO_PACK); MODE (REF_LONGLONG_INT) = add_mode (&TOP_MOID (&program), REF_SYMBOL, 0, NO_NODE, MODE (LONGLONG_INT), NO_PACK); MODE (REF_LONGLONG_REAL) = add_mode (&TOP_MOID (&program), REF_SYMBOL, 0, NO_NODE, MODE (LONGLONG_REAL), NO_PACK); MODE (REF_LONGLONG_COMPLEX) = MODE (REF_LONGLONG_COMPL) = add_mode (&TOP_MOID (&program), REF_SYMBOL, 0, NO_NODE, MODE (LONGLONG_COMPLEX), NO_PACK); MODE (REF_LONG_BITS) = add_mode (&TOP_MOID (&program), REF_SYMBOL, 0, NO_NODE, MODE (LONG_BITS), NO_PACK); MODE (REF_LONGLONG_BITS) = add_mode (&TOP_MOID (&program), REF_SYMBOL, 0, NO_NODE, MODE (LONGLONG_BITS), NO_PACK); MODE (REF_LONG_BYTES) = add_mode (&TOP_MOID (&program), REF_SYMBOL, 0, NO_NODE, MODE (LONG_BYTES), NO_PACK); /* Other */ MODE (REF_BOOL) = add_mode (&TOP_MOID (&program), REF_SYMBOL, 0, NO_NODE, MODE (BOOL), NO_PACK); MODE (REF_CHAR) = add_mode (&TOP_MOID (&program), REF_SYMBOL, 0, NO_NODE, MODE (CHAR), NO_PACK); MODE (REF_FILE) = add_mode (&TOP_MOID (&program), REF_SYMBOL, 0, NO_NODE, MODE (FILE), NO_PACK); MODE (REF_REF_FILE) = add_mode (&TOP_MOID (&program), REF_SYMBOL, 0, NO_NODE, MODE (REF_FILE), NO_PACK); MODE (REF_SOUND) = add_mode (&TOP_MOID (&program), REF_SYMBOL, 0, NO_NODE, MODE (SOUND), NO_PACK); /* [] INT */ MODE (ROW_INT) = add_mode (&TOP_MOID (&program), ROW_SYMBOL, 1, NO_NODE, MODE (INT), NO_PACK); HAS_ROWS (MODE (ROW_INT)) = A68_TRUE; SLICE (MODE (ROW_INT)) = MODE (INT); MODE (REF_ROW_INT) = add_mode (&TOP_MOID (&program), REF_SYMBOL, 0, NO_NODE, MODE (ROW_INT), NO_PACK); NAME (MODE (REF_ROW_INT)) = MODE (REF_INT); /* [] REAL */ MODE (ROW_REAL) = add_mode (&TOP_MOID (&program), ROW_SYMBOL, 1, NO_NODE, MODE (REAL), NO_PACK); HAS_ROWS (MODE (ROW_REAL)) = A68_TRUE; SLICE (MODE (ROW_REAL)) = MODE (REAL); MODE (REF_ROW_REAL) = add_mode (&TOP_MOID (&program), REF_SYMBOL, 0, NO_NODE, MODE (ROW_REAL), NO_PACK); NAME (MODE (REF_ROW_REAL)) = MODE (REF_REAL); /* [,] REAL */ MODE (ROWROW_REAL) = add_mode (&TOP_MOID (&program), ROW_SYMBOL, 2, NO_NODE, MODE (REAL), NO_PACK); HAS_ROWS (MODE (ROWROW_REAL)) = A68_TRUE; SLICE (MODE (ROWROW_REAL)) = MODE (ROW_REAL); MODE (REF_ROWROW_REAL) = add_mode (&TOP_MOID (&program), REF_SYMBOL, 0, NO_NODE, MODE (ROWROW_REAL), NO_PACK); NAME (MODE (REF_ROWROW_REAL)) = MODE (REF_ROW_REAL); /* [] COMPLEX */ MODE (ROW_COMPLEX) = add_mode (&TOP_MOID (&program), ROW_SYMBOL, 1, NO_NODE, MODE (COMPLEX), NO_PACK); HAS_ROWS (MODE (ROW_COMPLEX)) = A68_TRUE; SLICE (MODE (ROW_COMPLEX)) = MODE (COMPLEX); MODE (REF_ROW_COMPLEX) = add_mode (&TOP_MOID (&program), REF_SYMBOL, 0, NO_NODE, MODE (ROW_COMPLEX), NO_PACK); NAME (MODE (REF_ROW_COMPLEX)) = MODE (REF_COMPLEX); /* [,] COMPLEX */ MODE (ROWROW_COMPLEX) = add_mode (&TOP_MOID (&program), ROW_SYMBOL, 2, NO_NODE, MODE (COMPLEX), NO_PACK); HAS_ROWS (MODE (ROWROW_COMPLEX)) = A68_TRUE; SLICE (MODE (ROWROW_COMPLEX)) = MODE (ROW_COMPLEX); MODE (REF_ROWROW_COMPLEX) = add_mode (&TOP_MOID (&program), REF_SYMBOL, 0, NO_NODE, MODE (ROWROW_COMPLEX), NO_PACK); NAME (MODE (REF_ROWROW_COMPLEX)) = MODE (REF_ROW_COMPLEX); /* [] BOOL */ MODE (ROW_BOOL) = add_mode (&TOP_MOID (&program), ROW_SYMBOL, 1, NO_NODE, MODE (BOOL), NO_PACK); HAS_ROWS (MODE (ROW_BOOL)) = A68_TRUE; SLICE (MODE (ROW_BOOL)) = MODE (BOOL); /* [] BITS */ MODE (ROW_BITS) = add_mode (&TOP_MOID (&program), ROW_SYMBOL, 1, NO_NODE, MODE (BITS), NO_PACK); HAS_ROWS (MODE (ROW_BITS)) = A68_TRUE; SLICE (MODE (ROW_BITS)) = MODE (BITS); /* [] LONG BITS */ MODE (ROW_LONG_BITS) = add_mode (&TOP_MOID (&program), ROW_SYMBOL, 1, NO_NODE, MODE (LONG_BITS), NO_PACK); HAS_ROWS (MODE (ROW_LONG_BITS)) = A68_TRUE; SLICE (MODE (ROW_LONG_BITS)) = MODE (LONG_BITS); /* [] LONG LONG BITS */ MODE (ROW_LONGLONG_BITS) = add_mode (&TOP_MOID (&program), ROW_SYMBOL, 1, NO_NODE, MODE (LONGLONG_BITS), NO_PACK); HAS_ROWS (MODE (ROW_LONGLONG_BITS)) = A68_TRUE; SLICE (MODE (ROW_LONGLONG_BITS)) = MODE (LONGLONG_BITS); /* [] CHAR */ MODE (ROW_CHAR) = add_mode (&TOP_MOID (&program), ROW_SYMBOL, 1, NO_NODE, MODE (CHAR), NO_PACK); HAS_ROWS (MODE (ROW_CHAR)) = A68_TRUE; SLICE (MODE (ROW_CHAR)) = MODE (CHAR); /* [][] CHAR */ MODE (ROW_ROW_CHAR) = add_mode (&TOP_MOID (&program), ROW_SYMBOL, 1, NO_NODE, MODE (ROW_CHAR), NO_PACK); HAS_ROWS (MODE (ROW_ROW_CHAR)) = A68_TRUE; SLICE (MODE (ROW_ROW_CHAR)) = MODE (ROW_CHAR); /* MODE STRING = FLEX [] CHAR */ m = add_mode (&TOP_MOID (&program), FLEX_SYMBOL, 0, NO_NODE, MODE (ROW_CHAR), NO_PACK); HAS_ROWS (m) = A68_TRUE; MODE (FLEX_ROW_CHAR) = m; EQUIVALENT (MODE (STRING)) = m; /* REF [] CHAR */ MODE (REF_ROW_CHAR) = add_mode (&TOP_MOID (&program), REF_SYMBOL, 0, NO_NODE, MODE (ROW_CHAR), NO_PACK); NAME (MODE (REF_ROW_CHAR)) = MODE (REF_CHAR); /* PROC [] CHAR */ MODE (PROC_ROW_CHAR) = add_mode (&TOP_MOID (&program), PROC_SYMBOL, 0, NO_NODE, MODE (ROW_CHAR), NO_PACK); /* REF STRING = REF FLEX [] CHAR */ MODE (REF_STRING) = add_mode (&TOP_MOID (&program), REF_SYMBOL, 0, NO_NODE, EQUIVALENT (MODE (STRING)), NO_PACK); NAME (MODE (REF_STRING)) = MODE (REF_CHAR); DEFLEXED (MODE (REF_STRING)) = MODE (REF_ROW_CHAR); /* [] STRING */ MODE (ROW_STRING) = add_mode (&TOP_MOID (&program), ROW_SYMBOL, 1, NO_NODE, MODE (STRING), NO_PACK); HAS_ROWS (MODE (ROW_STRING)) = A68_TRUE; SLICE (MODE (ROW_STRING)) = MODE (STRING); DEFLEXED (MODE (ROW_STRING)) = MODE (ROW_ROW_CHAR); /* PROC STRING */ MODE (PROC_STRING) = add_mode (&TOP_MOID (&program), PROC_SYMBOL, 0, NO_NODE, MODE (STRING), NO_PACK); DEFLEXED (MODE (PROC_STRING)) = MODE (PROC_ROW_CHAR); /* COMPLEX */ z = NO_PACK; (void) add_mode_to_pack (&z, MODE (REAL), TEXT (add_token (&top_token, "im")), NO_NODE); (void) add_mode_to_pack (&z, MODE (REAL), TEXT (add_token (&top_token, "re")), NO_NODE); m = add_mode (&TOP_MOID (&program), STRUCT_SYMBOL, count_pack_members (z), NO_NODE, NO_MOID, z); EQUIVALENT (MODE (COMPLEX)) = EQUIVALENT (MODE (COMPL)) = m; z = NO_PACK; (void) add_mode_to_pack (&z, MODE (REF_REAL), TEXT (add_token (&top_token, "im")), NO_NODE); (void) add_mode_to_pack (&z, MODE (REF_REAL), TEXT (add_token (&top_token, "re")), NO_NODE); m = add_mode (&TOP_MOID (&program), STRUCT_SYMBOL, count_pack_members (z), NO_NODE, NO_MOID, z); NAME (MODE (REF_COMPLEX)) = NAME (MODE (REF_COMPL)) = m; /* LONG COMPLEX */ z = NO_PACK; (void) add_mode_to_pack (&z, MODE (LONG_REAL), TEXT (add_token (&top_token, "im")), NO_NODE); (void) add_mode_to_pack (&z, MODE (LONG_REAL), TEXT (add_token (&top_token, "re")), NO_NODE); m = add_mode (&TOP_MOID (&program), STRUCT_SYMBOL, count_pack_members (z), NO_NODE, NO_MOID, z); EQUIVALENT (MODE (LONG_COMPLEX)) = EQUIVALENT (MODE (LONG_COMPL)) = m; z = NO_PACK; (void) add_mode_to_pack (&z, MODE (REF_LONG_REAL), TEXT (add_token (&top_token, "im")), NO_NODE); (void) add_mode_to_pack (&z, MODE (REF_LONG_REAL), TEXT (add_token (&top_token, "re")), NO_NODE); m = add_mode (&TOP_MOID (&program), STRUCT_SYMBOL, count_pack_members (z), NO_NODE, NO_MOID, z); NAME (MODE (REF_LONG_COMPLEX)) = NAME (MODE (REF_LONG_COMPL)) = m; /* LONG_LONG COMPLEX */ z = NO_PACK; (void) add_mode_to_pack (&z, MODE (LONGLONG_REAL), TEXT (add_token (&top_token, "im")), NO_NODE); (void) add_mode_to_pack (&z, MODE (LONGLONG_REAL), TEXT (add_token (&top_token, "re")), NO_NODE); m = add_mode (&TOP_MOID (&program), STRUCT_SYMBOL, count_pack_members (z), NO_NODE, NO_MOID, z); EQUIVALENT (MODE (LONGLONG_COMPLEX)) = EQUIVALENT (MODE (LONGLONG_COMPL)) = m; z = NO_PACK; (void) add_mode_to_pack (&z, MODE (REF_LONGLONG_REAL), TEXT (add_token (&top_token, "im")), NO_NODE); (void) add_mode_to_pack (&z, MODE (REF_LONGLONG_REAL), TEXT (add_token (&top_token, "re")), NO_NODE); m = add_mode (&TOP_MOID (&program), STRUCT_SYMBOL, count_pack_members (z), NO_NODE, NO_MOID, z); NAME (MODE (REF_LONGLONG_COMPLEX)) = NAME (MODE (REF_LONGLONG_COMPL)) = m; /* NUMBER */ z = NO_PACK; (void) add_mode_to_pack (&z, MODE (INT), NO_TEXT, NO_NODE); (void) add_mode_to_pack (&z, MODE (LONG_INT), NO_TEXT, NO_NODE); (void) add_mode_to_pack (&z, MODE (LONGLONG_INT), NO_TEXT, NO_NODE); (void) add_mode_to_pack (&z, MODE (REAL), NO_TEXT, NO_NODE); (void) add_mode_to_pack (&z, MODE (LONG_REAL), NO_TEXT, NO_NODE); (void) add_mode_to_pack (&z, MODE (LONGLONG_REAL), NO_TEXT, NO_NODE); MODE (NUMBER) = add_mode (&TOP_MOID (&program), UNION_SYMBOL, count_pack_members (z), NO_NODE, NO_MOID, z); /* SEMA */ z = NO_PACK; (void) add_mode_to_pack (&z, MODE (REF_INT), NO_TEXT, NO_NODE); EQUIVALENT (MODE (SEMA)) = add_mode (&TOP_MOID (&program), STRUCT_SYMBOL, count_pack_members (z), NO_NODE, NO_MOID, z); /* PROC VOID */ z = NO_PACK; MODE (PROC_VOID) = add_mode (&TOP_MOID (&program), PROC_SYMBOL, count_pack_members (z), NO_NODE, MODE (VOID), z); /* PROC (REAL) REAL */ z = NO_PACK; (void) add_mode_to_pack (&z, MODE (REAL), NO_TEXT, NO_NODE); MODE (PROC_REAL_REAL) = add_mode (&TOP_MOID (&program), PROC_SYMBOL, count_pack_members (z), NO_NODE, MODE (REAL), z); /* IO: PROC (REF FILE) BOOL */ z = NO_PACK; (void) add_mode_to_pack (&z, MODE (REF_FILE), NO_TEXT, NO_NODE); MODE (PROC_REF_FILE_BOOL) = add_mode (&TOP_MOID (&program), PROC_SYMBOL, count_pack_members (z), NO_NODE, MODE (BOOL), z); /* IO: PROC (REF FILE) VOID */ z = NO_PACK; (void) add_mode_to_pack (&z, MODE (REF_FILE), NO_TEXT, NO_NODE); MODE (PROC_REF_FILE_VOID) = add_mode (&TOP_MOID (&program), PROC_SYMBOL, count_pack_members (z), NO_NODE, MODE (VOID), z); /* IO: SIMPLIN and SIMPLOUT */ MODE (SIMPLIN) = add_mode (&TOP_MOID (&program), IN_TYPE_MODE, 0, NO_NODE, NO_MOID, NO_PACK); MODE (ROW_SIMPLIN) = add_mode (&TOP_MOID (&program), ROW_SYMBOL, 1, NO_NODE, MODE (SIMPLIN), NO_PACK); SLICE (MODE (ROW_SIMPLIN)) = MODE (SIMPLIN); MODE (SIMPLOUT) = add_mode (&TOP_MOID (&program), OUT_TYPE_MODE, 0, NO_NODE, NO_MOID, NO_PACK); MODE (ROW_SIMPLOUT) = add_mode (&TOP_MOID (&program), ROW_SYMBOL, 1, NO_NODE, MODE (SIMPLOUT), NO_PACK); SLICE (MODE (ROW_SIMPLOUT)) = MODE (SIMPLOUT); /* PIPE */ z = NO_PACK; (void) add_mode_to_pack (&z, MODE (INT), TEXT (add_token (&top_token, "pid")), NO_NODE); (void) add_mode_to_pack (&z, MODE (REF_FILE), TEXT (add_token (&top_token, "write")), NO_NODE); (void) add_mode_to_pack (&z, MODE (REF_FILE), TEXT (add_token (&top_token, "read")), NO_NODE); EQUIVALENT (MODE (PIPE)) = add_mode (&TOP_MOID (&program), STRUCT_SYMBOL, count_pack_members (z), NO_NODE, NO_MOID, z); z = NO_PACK; (void) add_mode_to_pack (&z, MODE (REF_INT), TEXT (add_token (&top_token, "pid")), NO_NODE); (void) add_mode_to_pack (&z, MODE (REF_REF_FILE), TEXT (add_token (&top_token, "write")), NO_NODE); (void) add_mode_to_pack (&z, MODE (REF_REF_FILE), TEXT (add_token (&top_token, "read")), NO_NODE); NAME (MODE (REF_PIPE)) = add_mode (&TOP_MOID (&program), STRUCT_SYMBOL, count_pack_members (z), NO_NODE, NO_MOID, z); } /*! \brief set up standenv - general RR but not transput **/ static void stand_prelude (void) { MOID_T *m; /* Identifiers */ a68_idf (A68_STD, "intlengths", MODE (INT), genie_int_lengths); a68_idf (A68_STD, "intshorths", MODE (INT), genie_int_shorths); a68_idf (A68_STD, "maxint", MODE (INT), genie_max_int); a68_idf (A68_STD, "maxreal", MODE (REAL), genie_max_real); a68_idf (A68_STD, "minreal", MODE (REAL), genie_min_real); a68_idf (A68_STD, "smallreal", MODE (REAL), genie_small_real); a68_idf (A68_STD, "reallengths", MODE (INT), genie_real_lengths); a68_idf (A68_STD, "realshorths", MODE (INT), genie_real_shorths); a68_idf (A68_STD, "compllengths", MODE (INT), genie_complex_lengths); a68_idf (A68_STD, "complshorths", MODE (INT), genie_complex_shorths); a68_idf (A68_STD, "bitslengths", MODE (INT), genie_bits_lengths); a68_idf (A68_STD, "bitsshorths", MODE (INT), genie_bits_shorths); a68_idf (A68_STD, "bitswidth", MODE (INT), genie_bits_width); a68_idf (A68_STD, "longbitswidth", MODE (INT), genie_long_bits_width); a68_idf (A68_STD, "longlongbitswidth", MODE (INT), genie_longlong_bits_width); a68_idf (A68_STD, "maxbits", MODE (BITS), genie_max_bits); a68_idf (A68_STD, "longmaxbits", MODE (LONG_BITS), genie_long_max_bits); a68_idf (A68_STD, "longlongmaxbits", MODE (LONGLONG_BITS), genie_longlong_max_bits); a68_idf (A68_STD, "byteslengths", MODE (INT), genie_bytes_lengths); a68_idf (A68_STD, "bytesshorths", MODE (INT), genie_bytes_shorths); a68_idf (A68_STD, "byteswidth", MODE (INT), genie_bytes_width); a68_idf (A68_STD, "maxabschar", MODE (INT), genie_max_abs_char); a68_idf (A68_STD, "pi", MODE (REAL), genie_pi); a68_idf (A68_STD, "dpi", MODE (LONG_REAL), genie_pi_long_mp); a68_idf (A68_STD, "longpi", MODE (LONG_REAL), genie_pi_long_mp); a68_idf (A68_STD, "qpi", MODE (LONGLONG_REAL), genie_pi_long_mp); a68_idf (A68_STD, "longlongpi", MODE (LONGLONG_REAL), genie_pi_long_mp); a68_idf (A68_STD, "intwidth", MODE (INT), genie_int_width); a68_idf (A68_STD, "realwidth", MODE (INT), genie_real_width); a68_idf (A68_STD, "expwidth", MODE (INT), genie_exp_width); a68_idf (A68_STD, "longintwidth", MODE (INT), genie_long_int_width); a68_idf (A68_STD, "longlongintwidth", MODE (INT), genie_longlong_int_width); a68_idf (A68_STD, "longrealwidth", MODE (INT), genie_long_real_width); a68_idf (A68_STD, "longlongrealwidth", MODE (INT), genie_longlong_real_width); a68_idf (A68_STD, "longexpwidth", MODE (INT), genie_long_exp_width); a68_idf (A68_STD, "longlongexpwidth", MODE (INT), genie_longlong_exp_width); a68_idf (A68_STD, "longmaxint", MODE (LONG_INT), genie_long_max_int); a68_idf (A68_STD, "longlongmaxint", MODE (LONGLONG_INT), genie_longlong_max_int); a68_idf (A68_STD, "longsmallreal", MODE (LONG_REAL), genie_long_small_real); a68_idf (A68_STD, "longlongsmallreal", MODE (LONGLONG_REAL), genie_longlong_small_real); a68_idf (A68_STD, "longmaxreal", MODE (LONG_REAL), genie_long_max_real); a68_idf (A68_STD, "longminreal", MODE (LONG_REAL), genie_long_min_real); a68_idf (A68_STD, "longlongmaxreal", MODE (LONGLONG_REAL), genie_longlong_max_real); a68_idf (A68_STD, "longlongminreal", MODE (LONGLONG_REAL), genie_longlong_min_real); a68_idf (A68_STD, "longbyteswidth", MODE (INT), genie_long_bytes_width); a68_idf (A68_EXT, "seconds", MODE (REAL), genie_cputime); a68_idf (A68_EXT, "clock", MODE (REAL), genie_cputime); a68_idf (A68_EXT, "cputime", MODE (REAL), genie_cputime); a68_idf (A68_EXT, "collections", proc_int, genie_garbage_collections); a68_idf (A68_EXT, "blocks",proc_int, genie_block); m = a68_proc (MODE (VOID), proc_void, NO_MOID); a68_idf (A68_EXT, "ongcevent", m, genie_on_gc_event); m = a68_proc (MODE (LONG_INT), NO_MOID); a68_idf (A68_EXT, "garbage", m, genie_garbage_freed); a68_idf (A68_EXT, "collectseconds", proc_real, genie_garbage_seconds); a68_idf (A68_EXT, "stackpointer", MODE (INT), genie_stack_pointer); a68_idf (A68_EXT, "systemstackpointer", MODE (INT), genie_system_stack_pointer); a68_idf (A68_EXT, "systemstacksize", MODE (INT), genie_system_stack_size); a68_idf (A68_EXT, "actualstacksize", MODE (INT), genie_stack_pointer); m = proc_void; a68_idf (A68_EXT, "gcheap", m, genie_gc_heap); a68_idf (A68_EXT, "sweepheap", m, genie_gc_heap); a68_idf (A68_EXT, "preemptivegc", m, genie_preemptive_gc_heap); a68_idf (A68_EXT, "preemptivesweep", m, genie_preemptive_gc_heap); a68_idf (A68_EXT, "preemptivesweepheap", m, genie_preemptive_gc_heap); a68_idf (A68_EXT, "break", m, genie_break); a68_idf (A68_EXT, "debug", m, genie_debug); a68_idf (A68_EXT, "monitor", m, genie_debug); m = a68_proc (MODE (STRING), MODE (STRING), NO_MOID); a68_idf (A68_EXT, "evaluate", m, genie_evaluate); m = a68_proc (MODE (INT), MODE (STRING), NO_MOID); a68_idf (A68_EXT, "system", m, genie_system); m = a68_proc (MODE (STRING), MODE (STRING), NO_MOID); a68_idf (A68_EXT, "acronym", m, genie_acronym); a68_idf (A68_EXT, "vmsacronym", m, genie_acronym); /* BITS procedures */ m = a68_proc (MODE (BITS), MODE (ROW_BOOL), NO_MOID); a68_idf (A68_STD, "bitspack", m, genie_bits_pack); m = a68_proc (MODE (LONG_BITS), MODE (ROW_BOOL), NO_MOID); a68_idf (A68_STD, "longbitspack", m, genie_long_bits_pack); m = a68_proc (MODE (LONGLONG_BITS), MODE (ROW_BOOL), NO_MOID); a68_idf (A68_STD, "longlongbitspack", m, genie_long_bits_pack); /* RNG procedures */ m = a68_proc (MODE (VOID), MODE (INT), NO_MOID); a68_idf (A68_STD, "firstrandom", m, genie_first_random); m = proc_real; a68_idf (A68_STD, "nextrandom", m, genie_next_random); a68_idf (A68_STD, "random", m, genie_next_random); a68_idf (A68_STD, "rnd", m, genie_next_rnd); m = a68_proc (MODE (LONG_REAL), NO_MOID); a68_idf (A68_STD, "longnextrandom", m, genie_long_next_random); a68_idf (A68_STD, "longrandom", m, genie_long_next_random); m = a68_proc (MODE (LONGLONG_REAL), NO_MOID); a68_idf (A68_STD, "longlongnextrandom", m, genie_long_next_random); a68_idf (A68_STD, "longlongrandom", m, genie_long_next_random); /* Priorities */ a68_prio ("+:=", 1); a68_prio ("-:=", 1); a68_prio ("*:=", 1); a68_prio ("/:=", 1); a68_prio ("%:=", 1); a68_prio ("%*:=", 1); a68_prio ("+=:", 1); a68_prio ("PLUSAB", 1); a68_prio ("MINUSAB", 1); a68_prio ("TIMESAB", 1); a68_prio ("DIVAB", 1); a68_prio ("OVERAB", 1); a68_prio ("MODAB", 1); a68_prio ("PLUSTO", 1); a68_prio ("OR", 2); a68_prio ("AND", 3); a68_prio ("&", 3); a68_prio ("XOR", 3); a68_prio ("=", 4); a68_prio ("/=", 4); a68_prio ("~=", 4); a68_prio ("^=", 4); a68_prio ("<", 5); a68_prio ("<=", 5); a68_prio (">", 5); a68_prio (">=", 5); a68_prio ("EQ", 4); a68_prio ("NE", 4); a68_prio ("LT", 5); a68_prio ("LE", 5); a68_prio ("GT", 5); a68_prio ("GE", 5); a68_prio ("+", 6); a68_prio ("-", 6); a68_prio ("*", 7); a68_prio ("/", 7); a68_prio ("OVER", 7); a68_prio ("%", 7); a68_prio ("MOD", 7); a68_prio ("%*", 7); a68_prio ("ELEM", 7); a68_prio ("SET", 7); a68_prio ("CLEAR", 7); a68_prio ("**", 8); a68_prio ("SHL", 8); a68_prio ("SHR", 8); a68_prio ("UP", 8); a68_prio ("DOWN", 8); a68_prio ("^", 8); a68_prio ("ELEMS", 8); a68_prio ("LWB", 8); a68_prio ("UPB", 8); a68_prio ("SORT", 8); a68_prio ("I", 9); a68_prio ("+*", 9); /* INT ops */ m = a68_proc (MODE (INT), MODE (INT), NO_MOID); a68_op (A68_STD, "+", m, genie_idle); a68_op (A68_STD, "-", m, genie_minus_int); a68_op (A68_STD, "ABS", m, genie_abs_int); a68_op (A68_STD, "SIGN", m, genie_sign_int); m = a68_proc (MODE (BOOL), MODE (INT), NO_MOID); a68_op (A68_STD, "ODD", m, genie_odd_int); m = a68_proc (MODE (BOOL), MODE (INT), MODE (INT), NO_MOID); a68_op (A68_STD, "=", m, genie_eq_int); a68_op (A68_STD, "/=", m, genie_ne_int); a68_op (A68_STD, "~=", m, genie_ne_int); a68_op (A68_STD, "^=", m, genie_ne_int); a68_op (A68_STD, "<", m, genie_lt_int); a68_op (A68_STD, "<=", m, genie_le_int); a68_op (A68_STD, ">", m, genie_gt_int); a68_op (A68_STD, ">=", m, genie_ge_int); a68_op (A68_STD, "EQ", m, genie_eq_int); a68_op (A68_STD, "NE", m, genie_ne_int); a68_op (A68_STD, "LT", m, genie_lt_int); a68_op (A68_STD, "LE", m, genie_le_int); a68_op (A68_STD, "GT", m, genie_gt_int); a68_op (A68_STD, "GE", m, genie_ge_int); m = a68_proc (MODE (INT), MODE (INT), MODE (INT), NO_MOID); a68_op (A68_STD, "+", m, genie_add_int); a68_op (A68_STD, "-", m, genie_sub_int); a68_op (A68_STD, "*", m, genie_mul_int); a68_op (A68_STD, "OVER", m, genie_over_int); a68_op (A68_STD, "%", m, genie_over_int); a68_op (A68_STD, "MOD", m, genie_mod_int); a68_op (A68_STD, "%*", m, genie_mod_int); a68_op (A68_STD, "**", m, genie_pow_int); a68_op (A68_STD, "UP", m, genie_pow_int); a68_op (A68_STD, "^", m, genie_pow_int); m = a68_proc (MODE (REAL), MODE (INT), MODE (INT), NO_MOID); a68_op (A68_STD, "/", m, genie_div_int); m = a68_proc (MODE (REF_INT), MODE (REF_INT), MODE (INT), NO_MOID); a68_op (A68_STD, "+:=", m, genie_plusab_int); a68_op (A68_STD, "-:=", m, genie_minusab_int); a68_op (A68_STD, "*:=", m, genie_timesab_int); a68_op (A68_STD, "%:=", m, genie_overab_int); a68_op (A68_STD, "%*:=", m, genie_modab_int); a68_op (A68_STD, "PLUSAB", m, genie_plusab_int); a68_op (A68_STD, "MINUSAB", m, genie_minusab_int); a68_op (A68_STD, "TIMESAB", m, genie_timesab_int); a68_op (A68_STD, "OVERAB", m, genie_overab_int); a68_op (A68_STD, "MODAB", m, genie_modab_int); /* REAL ops */ m = proc_real_real; a68_op (A68_STD, "+", m, genie_idle); a68_op (A68_STD, "-", m, genie_minus_real); a68_op (A68_STD, "ABS", m, genie_abs_real); m = a68_proc (MODE (INT), MODE (REAL), NO_MOID); a68_op (A68_STD, "SIGN", m, genie_sign_real); a68_op (A68_STD, "ROUND", m, genie_round_real); a68_op (A68_STD, "ENTIER", m, genie_entier_real); m = a68_proc (MODE (BOOL), MODE (REAL), MODE (REAL), NO_MOID); a68_op (A68_STD, "=", m, genie_eq_real); a68_op (A68_STD, "/=", m, genie_ne_real); a68_op (A68_STD, "~=", m, genie_ne_real); a68_op (A68_STD, "^=", m, genie_ne_real); a68_op (A68_STD, "<", m, genie_lt_real); a68_op (A68_STD, "<=", m, genie_le_real); a68_op (A68_STD, ">", m, genie_gt_real); a68_op (A68_STD, ">=", m, genie_ge_real); a68_op (A68_STD, "EQ", m, genie_eq_real); a68_op (A68_STD, "NE", m, genie_ne_real); a68_op (A68_STD, "LT", m, genie_lt_real); a68_op (A68_STD, "LE", m, genie_le_real); a68_op (A68_STD, "GT", m, genie_gt_real); a68_op (A68_STD, "GE", m, genie_ge_real); m = proc_real_real_real; a68_op (A68_STD, "+", m, genie_add_real); a68_op (A68_STD, "-", m, genie_sub_real); a68_op (A68_STD, "*", m, genie_mul_real); a68_op (A68_STD, "/", m, genie_div_real); a68_op (A68_STD, "**", m, genie_pow_real); a68_op (A68_STD, "UP", m, genie_pow_real); a68_op (A68_STD, "^", m, genie_pow_real); m = a68_proc (MODE (REAL), MODE (REAL), MODE (INT), NO_MOID); a68_op (A68_STD, "**", m, genie_pow_real_int); a68_op (A68_STD, "UP", m, genie_pow_real_int); a68_op (A68_STD, "^", m, genie_pow_real_int); m = a68_proc (MODE (REF_REAL), MODE (REF_REAL), MODE (REAL), NO_MOID); a68_op (A68_STD, "+:=", m, genie_plusab_real); a68_op (A68_STD, "-:=", m, genie_minusab_real); a68_op (A68_STD, "*:=", m, genie_timesab_real); a68_op (A68_STD, "/:=", m, genie_divab_real); a68_op (A68_STD, "PLUSAB", m, genie_plusab_real); a68_op (A68_STD, "MINUSAB", m, genie_minusab_real); a68_op (A68_STD, "TIMESAB", m, genie_timesab_real); a68_op (A68_STD, "DIVAB", m, genie_divab_real); m = proc_real_real; a68_idf (A68_STD, "sqrt", m, genie_sqrt_real); a68_idf (A68_EXT, "cbrt", m, genie_curt_real); a68_idf (A68_EXT, "curt", m, genie_curt_real); a68_idf (A68_STD, "exp", m, genie_exp_real); a68_idf (A68_STD, "ln", m, genie_ln_real); a68_idf (A68_STD, "log", m, genie_log_real); a68_idf (A68_STD, "sin", m, genie_sin_real); a68_idf (A68_STD, "cos", m, genie_cos_real); a68_idf (A68_STD, "tan", m, genie_tan_real); a68_idf (A68_STD, "asin", m, genie_arcsin_real); a68_idf (A68_STD, "acos", m, genie_arccos_real); a68_idf (A68_STD, "atan", m, genie_arctan_real); a68_idf (A68_STD, "arcsin", m, genie_arcsin_real); a68_idf (A68_STD, "arccos", m, genie_arccos_real); a68_idf (A68_STD, "arctan", m, genie_arctan_real); a68_idf (A68_EXT, "sinh", m, genie_sinh_real); a68_idf (A68_EXT, "cosh", m, genie_cosh_real); a68_idf (A68_EXT, "tanh", m, genie_tanh_real); a68_idf (A68_EXT, "asinh", m, genie_arcsinh_real); a68_idf (A68_EXT, "acosh", m, genie_arccosh_real); a68_idf (A68_EXT, "atanh", m, genie_arctanh_real); a68_idf (A68_EXT, "arcsinh", m, genie_arcsinh_real); a68_idf (A68_EXT, "arccosh", m, genie_arccosh_real); a68_idf (A68_EXT, "arctanh", m, genie_arctanh_real); a68_idf (A68_EXT, "inverseerf", m, genie_inverf_real); a68_idf (A68_EXT, "inverseerfc", m, genie_inverfc_real); m = proc_real_real_real; a68_idf (A68_EXT, "arctan2", m, genie_atan2_real); m = proc_real_real_real_real; a68_idf (A68_EXT, "lje126", m, genie_lj_e_12_6); a68_idf (A68_EXT, "ljf126", m, genie_lj_f_12_6); /* COMPLEX ops */ m = a68_proc (MODE (COMPLEX), MODE (REAL), MODE (REAL), NO_MOID); a68_op (A68_STD, "I", m, genie_icomplex); a68_op (A68_STD, "+*", m, genie_icomplex); m = a68_proc (MODE (COMPLEX), MODE (INT), MODE (INT), NO_MOID); a68_op (A68_STD, "I", m, genie_iint_complex); a68_op (A68_STD, "+*", m, genie_iint_complex); m = a68_proc (MODE (REAL), MODE (COMPLEX), NO_MOID); a68_op (A68_STD, "RE", m, genie_re_complex); a68_op (A68_STD, "IM", m, genie_im_complex); a68_op (A68_STD, "ABS", m, genie_abs_complex); a68_op (A68_STD, "ARG", m, genie_arg_complex); m = proc_complex_complex; a68_op (A68_STD, "+", m, genie_idle); a68_op (A68_STD, "-", m, genie_minus_complex); a68_op (A68_STD, "CONJ", m, genie_conj_complex); m = a68_proc (MODE (BOOL), MODE (COMPLEX), MODE (COMPLEX), NO_MOID); a68_op (A68_STD, "=", m, genie_eq_complex); a68_op (A68_STD, "/=", m, genie_ne_complex); a68_op (A68_STD, "~=", m, genie_ne_complex); a68_op (A68_STD, "^=", m, genie_ne_complex); a68_op (A68_STD, "EQ", m, genie_eq_complex); a68_op (A68_STD, "NE", m, genie_ne_complex); m = a68_proc (MODE (COMPLEX), MODE (COMPLEX), MODE (COMPLEX), NO_MOID); a68_op (A68_STD, "+", m, genie_add_complex); a68_op (A68_STD, "-", m, genie_sub_complex); a68_op (A68_STD, "*", m, genie_mul_complex); a68_op (A68_STD, "/", m, genie_div_complex); m = a68_proc (MODE (COMPLEX), MODE (COMPLEX), MODE (INT), NO_MOID); a68_op (A68_STD, "**", m, genie_pow_complex_int); a68_op (A68_STD, "UP", m, genie_pow_complex_int); a68_op (A68_STD, "^", m, genie_pow_complex_int); m = a68_proc (MODE (REF_COMPLEX), MODE (REF_COMPLEX), MODE (COMPLEX), NO_MOID); a68_op (A68_STD, "+:=", m, genie_plusab_complex); a68_op (A68_STD, "-:=", m, genie_minusab_complex); a68_op (A68_STD, "*:=", m, genie_timesab_complex); a68_op (A68_STD, "/:=", m, genie_divab_complex); a68_op (A68_STD, "PLUSAB", m, genie_plusab_complex); a68_op (A68_STD, "MINUSAB", m, genie_minusab_complex); a68_op (A68_STD, "TIMESAB", m, genie_timesab_complex); a68_op (A68_STD, "DIVAB", m, genie_divab_complex); /* BOOL ops */ m = a68_proc (MODE (BOOL), MODE (BOOL), NO_MOID); a68_op (A68_STD, "NOT", m, genie_not_bool); a68_op (A68_STD, "~", m, genie_not_bool); m = a68_proc (MODE (INT), MODE (BOOL), NO_MOID); a68_op (A68_STD, "ABS", m, genie_abs_bool); m = a68_proc (MODE (BOOL), MODE (BOOL), MODE (BOOL), NO_MOID); a68_op (A68_STD, "OR", m, genie_or_bool); a68_op (A68_STD, "AND", m, genie_and_bool); a68_op (A68_STD, "&", m, genie_and_bool); a68_op (A68_EXT, "XOR", m, genie_xor_bool); a68_op (A68_STD, "=", m, genie_eq_bool); a68_op (A68_STD, "/=", m, genie_ne_bool); a68_op (A68_STD, "~=", m, genie_ne_bool); a68_op (A68_STD, "^=", m, genie_ne_bool); a68_op (A68_STD, "EQ", m, genie_eq_bool); a68_op (A68_STD, "NE", m, genie_ne_bool); /* CHAR ops */ m = a68_proc (MODE (BOOL), MODE (CHAR), MODE (CHAR), NO_MOID); a68_op (A68_STD, "=", m, genie_eq_char); a68_op (A68_STD, "/=", m, genie_ne_char); a68_op (A68_STD, "~=", m, genie_ne_char); a68_op (A68_STD, "^=", m, genie_ne_char); a68_op (A68_STD, "<", m, genie_lt_char); a68_op (A68_STD, "<=", m, genie_le_char); a68_op (A68_STD, ">", m, genie_gt_char); a68_op (A68_STD, ">=", m, genie_ge_char); a68_op (A68_STD, "EQ", m, genie_eq_char); a68_op (A68_STD, "NE", m, genie_ne_char); a68_op (A68_STD, "LT", m, genie_lt_char); a68_op (A68_STD, "LE", m, genie_le_char); a68_op (A68_STD, "GT", m, genie_gt_char); a68_op (A68_STD, "GE", m, genie_ge_char); m = a68_proc (MODE (INT), MODE (CHAR), NO_MOID); a68_op (A68_STD, "ABS", m, genie_abs_char); m = a68_proc (MODE (CHAR), MODE (INT), NO_MOID); a68_op (A68_STD, "REPR", m, genie_repr_char); m = a68_proc (MODE (BOOL), MODE (CHAR), NO_MOID); a68_idf (A68_EXT, "isalnum", m, genie_is_alnum); a68_idf (A68_EXT, "isalpha", m, genie_is_alpha); a68_idf (A68_EXT, "iscntrl", m, genie_is_cntrl); a68_idf (A68_EXT, "isdigit", m, genie_is_digit); a68_idf (A68_EXT, "isgraph", m, genie_is_graph); a68_idf (A68_EXT, "islower", m, genie_is_lower); a68_idf (A68_EXT, "isprint", m, genie_is_print); a68_idf (A68_EXT, "ispunct", m, genie_is_punct); a68_idf (A68_EXT, "isspace", m, genie_is_space); a68_idf (A68_EXT, "isupper", m, genie_is_upper); a68_idf (A68_EXT, "isxdigit", m, genie_is_xdigit); m = a68_proc (MODE (CHAR), MODE (CHAR), NO_MOID); a68_idf (A68_EXT, "tolower", m, genie_to_lower); a68_idf (A68_EXT, "toupper", m, genie_to_upper); /* BITS ops */ m = a68_proc (MODE (INT), MODE (BITS), NO_MOID); a68_op (A68_STD, "ABS", m, genie_abs_bits); m = a68_proc (MODE (BITS), MODE (INT), NO_MOID); a68_op (A68_STD, "BIN", m, genie_bin_int); m = a68_proc (MODE (BITS), MODE (BITS), NO_MOID); a68_op (A68_STD, "NOT", m, genie_not_bits); a68_op (A68_STD, "~", m, genie_not_bits); m = a68_proc (MODE (BOOL), MODE (BITS), MODE (BITS), NO_MOID); a68_op (A68_STD, "=", m, genie_eq_bits); a68_op (A68_STD, "/=", m, genie_ne_bits); a68_op (A68_STD, "~=", m, genie_ne_bits); a68_op (A68_STD, "^=", m, genie_ne_bits); a68_op (A68_STD, "<=", m, genie_le_bits); a68_op (A68_STD, ">=", m, genie_ge_bits); a68_op (A68_STD, "EQ", m, genie_eq_bits); a68_op (A68_STD, "NE", m, genie_ne_bits); a68_op (A68_STD, "LE", m, genie_le_bits); a68_op (A68_STD, "GE", m, genie_ge_bits); m = a68_proc (MODE (BITS), MODE (BITS), MODE (BITS), NO_MOID); a68_op (A68_STD, "AND", m, genie_and_bits); a68_op (A68_STD, "&", m, genie_and_bits); a68_op (A68_STD, "OR", m, genie_or_bits); a68_op (A68_EXT, "XOR", m, genie_xor_bits); m = a68_proc (MODE (BITS), MODE (BITS), MODE (INT), NO_MOID); a68_op (A68_STD, "SHL", m, genie_shl_bits); a68_op (A68_STD, "UP", m, genie_shl_bits); a68_op (A68_STD, "SHR", m, genie_shr_bits); a68_op (A68_STD, "DOWN", m, genie_shr_bits); m = a68_proc (MODE (BOOL), MODE (INT), MODE (BITS), NO_MOID); a68_op (A68_STD, "ELEM", m, genie_elem_bits); m = a68_proc (MODE (BITS), MODE (INT), MODE (BITS), NO_MOID); a68_op (A68_STD, "SET", m, genie_set_bits); a68_op (A68_STD, "CLEAR", m, genie_clear_bits); /* BYTES ops */ m = a68_proc (MODE (BYTES), MODE (STRING), NO_MOID); a68_idf (A68_STD, "bytespack", m, genie_bytespack); m = a68_proc (MODE (CHAR), MODE (INT), MODE (BYTES), NO_MOID); a68_op (A68_STD, "ELEM", m, genie_elem_bytes); m = a68_proc (MODE (BYTES), MODE (BYTES), MODE (BYTES), NO_MOID); a68_op (A68_STD, "+", m, genie_add_bytes); m = a68_proc (MODE (REF_BYTES), MODE (REF_BYTES), MODE (BYTES), NO_MOID); a68_op (A68_STD, "+:=", m, genie_plusab_bytes); a68_op (A68_STD, "PLUSAB", m, genie_plusab_bytes); m = a68_proc (MODE (REF_BYTES), MODE (BYTES), MODE (REF_BYTES), NO_MOID); a68_op (A68_STD, "+=:", m, genie_plusto_bytes); a68_op (A68_STD, "PLUSTO", m, genie_plusto_bytes); m = a68_proc (MODE (BOOL), MODE (BYTES), MODE (BYTES), NO_MOID); a68_op (A68_STD, "=", m, genie_eq_bytes); a68_op (A68_STD, "/=", m, genie_ne_bytes); a68_op (A68_STD, "~=", m, genie_ne_bytes); a68_op (A68_STD, "^=", m, genie_ne_bytes); a68_op (A68_STD, "<", m, genie_lt_bytes); a68_op (A68_STD, "<=", m, genie_le_bytes); a68_op (A68_STD, ">", m, genie_gt_bytes); a68_op (A68_STD, ">=", m, genie_ge_bytes); a68_op (A68_STD, "EQ", m, genie_eq_bytes); a68_op (A68_STD, "NE", m, genie_ne_bytes); a68_op (A68_STD, "LT", m, genie_lt_bytes); a68_op (A68_STD, "LE", m, genie_le_bytes); a68_op (A68_STD, "GT", m, genie_gt_bytes); a68_op (A68_STD, "GE", m, genie_ge_bytes); /* LONG BYTES ops */ m = a68_proc (MODE (LONG_BYTES), MODE (BYTES), NO_MOID); a68_op (A68_STD, "LENG", m, genie_leng_bytes); m = a68_proc (MODE (BYTES), MODE (LONG_BYTES), NO_MOID); a68_idf (A68_STD, "SHORTEN", m, genie_shorten_bytes); m = a68_proc (MODE (LONG_BYTES), MODE (STRING), NO_MOID); a68_idf (A68_STD, "longbytespack", m, genie_long_bytespack); m = a68_proc (MODE (CHAR), MODE (INT), MODE (LONG_BYTES), NO_MOID); a68_op (A68_STD, "ELEM", m, genie_elem_long_bytes); m = a68_proc (MODE (LONG_BYTES), MODE (LONG_BYTES), MODE (LONG_BYTES), NO_MOID); a68_op (A68_STD, "+", m, genie_add_long_bytes); m = a68_proc (MODE (REF_LONG_BYTES), MODE (REF_LONG_BYTES), MODE (LONG_BYTES), NO_MOID); a68_op (A68_STD, "+:=", m, genie_plusab_long_bytes); a68_op (A68_STD, "PLUSAB", m, genie_plusab_long_bytes); m = a68_proc (MODE (REF_LONG_BYTES), MODE (LONG_BYTES), MODE (REF_LONG_BYTES), NO_MOID); a68_op (A68_STD, "+=:", m, genie_plusto_long_bytes); a68_op (A68_STD, "PLUSTO", m, genie_plusto_long_bytes); m = a68_proc (MODE (BOOL), MODE (LONG_BYTES), MODE (LONG_BYTES), NO_MOID); a68_op (A68_STD, "=", m, genie_eq_long_bytes); a68_op (A68_STD, "/=", m, genie_ne_long_bytes); a68_op (A68_STD, "~=", m, genie_ne_long_bytes); a68_op (A68_STD, "^=", m, genie_ne_long_bytes); a68_op (A68_STD, "<", m, genie_lt_long_bytes); a68_op (A68_STD, "<=", m, genie_le_long_bytes); a68_op (A68_STD, ">", m, genie_gt_long_bytes); a68_op (A68_STD, ">=", m, genie_ge_long_bytes); a68_op (A68_STD, "EQ", m, genie_eq_long_bytes); a68_op (A68_STD, "NE", m, genie_ne_long_bytes); a68_op (A68_STD, "LT", m, genie_lt_long_bytes); a68_op (A68_STD, "LE", m, genie_le_long_bytes); a68_op (A68_STD, "GT", m, genie_gt_long_bytes); a68_op (A68_STD, "GE", m, genie_ge_long_bytes); /* STRING ops */ m = a68_proc (MODE (BOOL), MODE (STRING), MODE (STRING), NO_MOID); a68_op (A68_STD, "=", m, genie_eq_string); a68_op (A68_STD, "/=", m, genie_ne_string); a68_op (A68_STD, "~=", m, genie_ne_string); a68_op (A68_STD, "^=", m, genie_ne_string); a68_op (A68_STD, "<", m, genie_lt_string); a68_op (A68_STD, "<=", m, genie_le_string); a68_op (A68_STD, ">=", m, genie_ge_string); a68_op (A68_STD, ">", m, genie_gt_string); a68_op (A68_STD, "EQ", m, genie_eq_string); a68_op (A68_STD, "NE", m, genie_ne_string); a68_op (A68_STD, "LT", m, genie_lt_string); a68_op (A68_STD, "LE", m, genie_le_string); a68_op (A68_STD, "GE", m, genie_ge_string); a68_op (A68_STD, "GT", m, genie_gt_string); m = a68_proc (MODE (STRING), MODE (CHAR), MODE (CHAR), NO_MOID); a68_op (A68_STD, "+", m, genie_add_char); m = a68_proc (MODE (STRING), MODE (STRING), MODE (STRING), NO_MOID); a68_op (A68_STD, "+", m, genie_add_string); m = a68_proc (MODE (REF_STRING), MODE (REF_STRING), MODE (STRING), NO_MOID); a68_op (A68_STD, "+:=", m, genie_plusab_string); a68_op (A68_STD, "PLUSAB", m, genie_plusab_string); m = a68_proc (MODE (REF_STRING), MODE (REF_STRING), MODE (INT), NO_MOID); a68_op (A68_STD, "*:=", m, genie_timesab_string); a68_op (A68_STD, "TIMESAB", m, genie_timesab_string); m = a68_proc (MODE (REF_STRING), MODE (STRING), MODE (REF_STRING), NO_MOID); a68_op (A68_STD, "+=:", m, genie_plusto_string); a68_op (A68_STD, "PLUSTO", m, genie_plusto_string); m = a68_proc (MODE (STRING), MODE (STRING), MODE (INT), NO_MOID); a68_op (A68_STD, "*", m, genie_times_string_int); m = a68_proc (MODE (STRING), MODE (INT), MODE (STRING), NO_MOID); a68_op (A68_STD, "*", m, genie_times_int_string); m = a68_proc (MODE (STRING), MODE (INT), MODE (CHAR), NO_MOID); a68_op (A68_STD, "*", m, genie_times_int_char); m = a68_proc (MODE (STRING), MODE (CHAR), MODE (INT), NO_MOID); a68_op (A68_STD, "*", m, genie_times_char_int); m = a68_proc (MODE (CHAR), MODE (INT), MODE (ROW_CHAR), NO_MOID); a68_op (A68_STD, "ELEM", m, genie_elem_string); /* SEMA ops */ #if defined HAVE_PARALLEL_CLAUSE m = a68_proc (MODE (SEMA), MODE (INT), NO_MOID); a68_op (A68_STD, "LEVEL", m, genie_level_sema_int); m = a68_proc (MODE (INT), MODE (SEMA), NO_MOID); a68_op (A68_STD, "LEVEL", m, genie_level_int_sema); m = a68_proc (MODE (VOID), MODE (SEMA), NO_MOID); a68_op (A68_STD, "UP", m, genie_up_sema); a68_op (A68_STD, "DOWN", m, genie_down_sema); #else m = a68_proc (MODE (SEMA), MODE (INT), NO_MOID); a68_op (A68_STD, "LEVEL", m, genie_unimplemented); m = a68_proc (MODE (INT), MODE (SEMA), NO_MOID); a68_op (A68_STD, "LEVEL", m, genie_unimplemented); m = a68_proc (MODE (VOID), MODE (SEMA), NO_MOID); a68_op (A68_STD, "UP", m, genie_unimplemented); a68_op (A68_STD, "DOWN", m, genie_unimplemented); #endif /* ROWS ops */ m = a68_proc (MODE (INT), MODE (ROWS), NO_MOID); a68_op (A68_EXT, "ELEMS", m, genie_monad_elems); a68_op (A68_STD, "LWB", m, genie_monad_lwb); a68_op (A68_STD, "UPB", m, genie_monad_upb); m = a68_proc (MODE (INT), MODE (INT), MODE (ROWS), NO_MOID); a68_op (A68_EXT, "ELEMS", m, genie_dyad_elems); a68_op (A68_STD, "LWB", m, genie_dyad_lwb); a68_op (A68_STD, "UPB", m, genie_dyad_upb); m = a68_proc (MODE (ROW_STRING), MODE (ROW_STRING), NO_MOID); a68_op (A68_EXT, "SORT", m, genie_sort_row_string); /* Binding for the multiple-precision library */ /* LONG INT */ m = a68_proc (MODE (LONG_INT), MODE (INT), NO_MOID); a68_op (A68_STD, "LENG", m, genie_lengthen_int_to_long_mp); m = a68_proc (MODE (LONG_INT), MODE (LONG_INT), NO_MOID); a68_op (A68_STD, "+", m, genie_idle); a68_op (A68_STD, "-", m, genie_minus_long_mp); a68_op (A68_STD, "ABS", m, genie_abs_long_mp); m = a68_proc (MODE (INT), MODE (LONG_INT), NO_MOID); a68_op (A68_STD, "SHORTEN", m, genie_shorten_long_mp_to_int); a68_op (A68_STD, "SIGN", m, genie_sign_long_mp); m = a68_proc (MODE (BOOL), MODE (LONG_INT), NO_MOID); a68_op (A68_STD, "ODD", m, genie_odd_long_mp); m = a68_proc (MODE (LONG_INT), MODE (LONG_REAL), NO_MOID); a68_op (A68_STD, "ENTIER", m, genie_entier_long_mp); a68_op (A68_STD, "ROUND", m, genie_round_long_mp); m = a68_proc (MODE (LONG_INT), MODE (LONG_INT), MODE (LONG_INT), NO_MOID); a68_op (A68_STD, "+", m, genie_add_long_int); a68_op (A68_STD, "-", m, genie_sub_long_int); a68_op (A68_STD, "*", m, genie_mul_long_int); a68_op (A68_STD, "OVER", m, genie_over_long_mp); a68_op (A68_STD, "%", m, genie_over_long_mp); a68_op (A68_STD, "MOD", m, genie_mod_long_mp); a68_op (A68_STD, "%*", m, genie_mod_long_mp); m = a68_proc (MODE (REF_LONG_INT), MODE (REF_LONG_INT), MODE (LONG_INT), NO_MOID); a68_op (A68_STD, "+:=", m, genie_plusab_long_int); a68_op (A68_STD, "-:=", m, genie_minusab_long_int); a68_op (A68_STD, "*:=", m, genie_timesab_long_int); a68_op (A68_STD, "%:=", m, genie_overab_long_mp); a68_op (A68_STD, "%*:=", m, genie_modab_long_mp); a68_op (A68_STD, "PLUSAB", m, genie_plusab_long_int); a68_op (A68_STD, "MINUSAB", m, genie_minusab_long_int); a68_op (A68_STD, "TIMESAB", m, genie_timesab_long_int); a68_op (A68_STD, "OVERAB", m, genie_overab_long_mp); a68_op (A68_STD, "MODAB", m, genie_modab_long_mp); m = a68_proc (MODE (BOOL), MODE (LONG_INT), MODE (LONG_INT), NO_MOID); a68_op (A68_STD, "=", m, genie_eq_long_mp); a68_op (A68_STD, "EQ", m, genie_eq_long_mp); a68_op (A68_STD, "/=", m, genie_ne_long_mp); a68_op (A68_STD, "~=", m, genie_ne_long_mp); a68_op (A68_STD, "^=", m, genie_ne_long_mp); a68_op (A68_STD, "NE", m, genie_ne_long_mp); a68_op (A68_STD, "<", m, genie_lt_long_mp); a68_op (A68_STD, "LT", m, genie_lt_long_mp); a68_op (A68_STD, "<=", m, genie_le_long_mp); a68_op (A68_STD, "LE", m, genie_le_long_mp); a68_op (A68_STD, ">", m, genie_gt_long_mp); a68_op (A68_STD, "GT", m, genie_gt_long_mp); a68_op (A68_STD, ">=", m, genie_ge_long_mp); a68_op (A68_STD, "GE", m, genie_ge_long_mp); m = a68_proc (MODE (LONG_REAL), MODE (LONG_INT), MODE (LONG_INT), NO_MOID); a68_op (A68_STD, "/", m, genie_div_long_mp); m = a68_proc (MODE (LONG_INT), MODE (LONG_INT), MODE (INT), NO_MOID); a68_op (A68_STD, "**", m, genie_pow_long_mp_int_int); a68_op (A68_STD, "^", m, genie_pow_long_mp_int_int); m = a68_proc (MODE (LONG_COMPLEX), MODE (LONG_INT), MODE (LONG_INT), NO_MOID); a68_op (A68_STD, "I", m, genie_idle); a68_op (A68_STD, "+*", m, genie_idle); /* LONG REAL */ m = a68_proc (MODE (LONG_REAL), MODE (REAL), NO_MOID); a68_op (A68_STD, "LENG", m, genie_lengthen_real_to_long_mp); m = a68_proc (MODE (REAL), MODE (LONG_REAL), NO_MOID); a68_op (A68_STD, "SHORTEN", m, genie_shorten_long_mp_to_real); m = a68_proc (MODE (LONG_REAL), MODE (LONG_REAL), NO_MOID); a68_op (A68_STD, "+", m, genie_idle); a68_op (A68_STD, "-", m, genie_minus_long_mp); a68_op (A68_STD, "ABS", m, genie_abs_long_mp); a68_idf (A68_STD, "longsqrt", m, genie_sqrt_long_mp); a68_idf (A68_EXT, "longcbrt", m, genie_curt_long_mp); a68_idf (A68_EXT, "longcurt", m, genie_curt_long_mp); a68_idf (A68_STD, "longexp", m, genie_exp_long_mp); a68_idf (A68_STD, "longln", m, genie_ln_long_mp); a68_idf (A68_STD, "longlog", m, genie_log_long_mp); a68_idf (A68_STD, "longsin", m, genie_sin_long_mp); a68_idf (A68_STD, "longcos", m, genie_cos_long_mp); a68_idf (A68_STD, "longtan", m, genie_tan_long_mp); a68_idf (A68_STD, "longasin", m, genie_asin_long_mp); a68_idf (A68_STD, "longacos", m, genie_acos_long_mp); a68_idf (A68_STD, "longatan", m, genie_atan_long_mp); a68_idf (A68_STD, "longarcsin", m, genie_asin_long_mp); a68_idf (A68_STD, "longarccos", m, genie_acos_long_mp); a68_idf (A68_STD, "longarctan", m, genie_atan_long_mp); a68_idf (A68_EXT, "longsinh", m, genie_sinh_long_mp); a68_idf (A68_EXT, "longcosh", m, genie_cosh_long_mp); a68_idf (A68_EXT, "longtanh", m, genie_tanh_long_mp); a68_idf (A68_EXT, "longasinh", m, genie_arcsinh_long_mp); a68_idf (A68_EXT, "longacosh", m, genie_arccosh_long_mp); a68_idf (A68_EXT, "longatanh", m, genie_arctanh_long_mp); a68_idf (A68_EXT, "longarcsinh", m, genie_arcsinh_long_mp); a68_idf (A68_EXT, "longarccosh", m, genie_arccosh_long_mp); a68_idf (A68_EXT, "longarctanh", m, genie_arctanh_long_mp); a68_idf (A68_EXT, "dsqrt", m, genie_sqrt_long_mp); a68_idf (A68_EXT, "dcbrt", m, genie_curt_long_mp); a68_idf (A68_EXT, "dcurt", m, genie_curt_long_mp); a68_idf (A68_EXT, "dexp", m, genie_exp_long_mp); a68_idf (A68_EXT, "dln", m, genie_ln_long_mp); a68_idf (A68_EXT, "dlog", m, genie_log_long_mp); a68_idf (A68_EXT, "dsin", m, genie_sin_long_mp); a68_idf (A68_EXT, "dcos", m, genie_cos_long_mp); a68_idf (A68_EXT, "dtan", m, genie_tan_long_mp); a68_idf (A68_EXT, "dasin", m, genie_asin_long_mp); a68_idf (A68_EXT, "dacos", m, genie_acos_long_mp); a68_idf (A68_EXT, "datan", m, genie_atan_long_mp); a68_idf (A68_EXT, "dsinh", m, genie_sinh_long_mp); a68_idf (A68_EXT, "dcosh", m, genie_cosh_long_mp); a68_idf (A68_EXT, "dtanh", m, genie_tanh_long_mp); a68_idf (A68_EXT, "dasinh", m, genie_arcsinh_long_mp); a68_idf (A68_EXT, "dacosh", m, genie_arccosh_long_mp); a68_idf (A68_EXT, "datanh", m, genie_arctanh_long_mp); m = a68_proc (MODE (LONG_REAL), MODE (LONG_REAL), MODE (LONG_REAL), NO_MOID); a68_idf (A68_STD, "longarctan2", m, genie_atan2_long_mp); a68_idf (A68_STD, "darctan2", m, genie_atan2_long_mp); m = a68_proc (MODE (INT), MODE (LONG_REAL), NO_MOID); a68_op (A68_STD, "SIGN", m, genie_sign_long_mp); m = a68_proc (MODE (LONG_REAL), MODE (LONG_REAL), MODE (LONG_REAL), NO_MOID); a68_op (A68_STD, "+", m, genie_add_long_mp); a68_op (A68_STD, "-", m, genie_sub_long_mp); a68_op (A68_STD, "*", m, genie_mul_long_mp); a68_op (A68_STD, "/", m, genie_div_long_mp); a68_op (A68_STD, "**", m, genie_pow_long_mp); a68_op (A68_STD, "UP", m, genie_pow_long_mp); a68_op (A68_STD, "^", m, genie_pow_long_mp); m = a68_proc (MODE (REF_LONG_REAL), MODE (REF_LONG_REAL), MODE (LONG_REAL), NO_MOID); a68_op (A68_STD, "+:=", m, genie_plusab_long_mp); a68_op (A68_STD, "-:=", m, genie_minusab_long_mp); a68_op (A68_STD, "*:=", m, genie_timesab_long_mp); a68_op (A68_STD, "/:=", m, genie_divab_long_mp); a68_op (A68_STD, "PLUSAB", m, genie_plusab_long_mp); a68_op (A68_STD, "MINUSAB", m, genie_minusab_long_mp); a68_op (A68_STD, "TIMESAB", m, genie_timesab_long_mp); a68_op (A68_STD, "DIVAB", m, genie_divab_long_mp); m = a68_proc (MODE (BOOL), MODE (LONG_REAL), MODE (LONG_REAL), NO_MOID); a68_op (A68_STD, "=", m, genie_eq_long_mp); a68_op (A68_STD, "EQ", m, genie_eq_long_mp); a68_op (A68_STD, "/=", m, genie_ne_long_mp); a68_op (A68_STD, "~=", m, genie_ne_long_mp); a68_op (A68_STD, "^=", m, genie_ne_long_mp); a68_op (A68_STD, "NE", m, genie_ne_long_mp); a68_op (A68_STD, "<", m, genie_lt_long_mp); a68_op (A68_STD, "LT", m, genie_lt_long_mp); a68_op (A68_STD, "<=", m, genie_le_long_mp); a68_op (A68_STD, "LE", m, genie_le_long_mp); a68_op (A68_STD, ">", m, genie_gt_long_mp); a68_op (A68_STD, "GT", m, genie_gt_long_mp); a68_op (A68_STD, ">=", m, genie_ge_long_mp); a68_op (A68_STD, "GE", m, genie_ge_long_mp); m = a68_proc (MODE (LONG_REAL), MODE (LONG_REAL), MODE (INT), NO_MOID); a68_op (A68_STD, "**", m, genie_pow_long_mp_int); a68_op (A68_STD, "UP", m, genie_pow_long_mp_int); a68_op (A68_STD, "^", m, genie_pow_long_mp_int); m = a68_proc (MODE (LONG_COMPLEX), MODE (LONG_REAL), MODE (LONG_REAL), NO_MOID); a68_op (A68_STD, "I", m, genie_idle); a68_op (A68_STD, "+*", m, genie_idle); /* LONG COMPLEX */ m = a68_proc (MODE (LONG_COMPLEX), MODE (COMPLEX), NO_MOID); a68_op (A68_STD, "LENG", m, genie_lengthen_complex_to_long_complex); m = a68_proc (MODE (COMPLEX), MODE (LONG_COMPLEX), NO_MOID); a68_op (A68_STD, "SHORTEN", m, genie_shorten_long_complex_to_complex); m = a68_proc (MODE (LONG_REAL), MODE (LONG_COMPLEX), NO_MOID); a68_op (A68_STD, "RE", m, genie_re_long_complex); a68_op (A68_STD, "IM", m, genie_im_long_complex); a68_op (A68_STD, "ARG", m, genie_arg_long_complex); a68_op (A68_STD, "ABS", m, genie_abs_long_complex); m = a68_proc (MODE (LONG_COMPLEX), MODE (LONG_COMPLEX), NO_MOID); a68_op (A68_STD, "+", m, genie_idle); a68_op (A68_STD, "-", m, genie_minus_long_complex); a68_op (A68_STD, "CONJ", m, genie_conj_long_complex); m = a68_proc (MODE (LONG_COMPLEX), MODE (LONG_COMPLEX), MODE (LONG_COMPLEX), NO_MOID); a68_op (A68_STD, "+", m, genie_add_long_complex); a68_op (A68_STD, "-", m, genie_sub_long_complex); a68_op (A68_STD, "*", m, genie_mul_long_complex); a68_op (A68_STD, "/", m, genie_div_long_complex); m = a68_proc (MODE (LONG_COMPLEX), MODE (LONG_COMPLEX), MODE (INT), NO_MOID); a68_op (A68_STD, "**", m, genie_pow_long_complex_int); a68_op (A68_STD, "UP", m, genie_pow_long_complex_int); a68_op (A68_STD, "^", m, genie_pow_long_complex_int); m = a68_proc (MODE (BOOL), MODE (LONG_COMPLEX), MODE (LONG_COMPLEX), NO_MOID); a68_op (A68_STD, "=", m, genie_eq_long_complex); a68_op (A68_STD, "EQ", m, genie_eq_long_complex); a68_op (A68_STD, "/=", m, genie_ne_long_complex); a68_op (A68_STD, "~=", m, genie_ne_long_complex); a68_op (A68_STD, "^=", m, genie_ne_long_complex); a68_op (A68_STD, "NE", m, genie_ne_long_complex); m = a68_proc (MODE (REF_LONG_COMPLEX), MODE (REF_LONG_COMPLEX), MODE (LONG_COMPLEX), NO_MOID); a68_op (A68_STD, "+:=", m, genie_plusab_long_complex); a68_op (A68_STD, "-:=", m, genie_minusab_long_complex); a68_op (A68_STD, "*:=", m, genie_timesab_long_complex); a68_op (A68_STD, "/:=", m, genie_divab_long_complex); a68_op (A68_STD, "PLUSAB", m, genie_plusab_long_complex); a68_op (A68_STD, "MINUSAB", m, genie_minusab_long_complex); a68_op (A68_STD, "TIMESAB", m, genie_timesab_long_complex); a68_op (A68_STD, "DIVAB", m, genie_divab_long_complex); /* LONG BITS ops */ m = a68_proc (MODE (LONG_INT), MODE (LONG_BITS), NO_MOID); a68_op (A68_STD, "ABS", m, genie_idle); m = a68_proc (MODE (LONG_BITS), MODE (LONG_INT), NO_MOID); a68_op (A68_STD, "BIN", m, genie_bin_long_mp); m = a68_proc (MODE (BITS), MODE (LONG_BITS), NO_MOID); a68_op (A68_STD, "SHORTEN", m, genie_shorten_long_mp_to_bits); m = a68_proc (MODE (LONG_BITS), MODE (BITS), NO_MOID); a68_op (A68_STD, "LENG", m, genie_lengthen_unsigned_to_long_mp); m = a68_proc (MODE (LONGLONG_BITS), MODE (LONG_BITS), NO_MOID); a68_op (A68_STD, "LENG", m, genie_lengthen_long_mp_to_longlong_mp); m = a68_proc (MODE (LONG_BITS), MODE (LONG_BITS), NO_MOID); a68_op (A68_STD, "NOT", m, genie_not_long_mp); a68_op (A68_STD, "~", m, genie_not_long_mp); m = a68_proc (MODE (BOOL), MODE (LONG_BITS), MODE (LONG_BITS), NO_MOID); a68_op (A68_STD, "=", m, genie_eq_long_mp); a68_op (A68_STD, "EQ", m, genie_eq_long_mp); a68_op (A68_STD, "/=", m, genie_ne_long_mp); a68_op (A68_STD, "~=", m, genie_ne_long_mp); a68_op (A68_STD, "^=", m, genie_ne_long_mp); a68_op (A68_STD, "NE", m, genie_ne_long_mp); a68_op (A68_STD, "<=", m, genie_le_long_bits); a68_op (A68_STD, "LE", m, genie_le_long_bits); a68_op (A68_STD, ">=", m, genie_ge_long_bits); a68_op (A68_STD, "GE", m, genie_ge_long_bits); m = a68_proc (MODE (LONG_BITS), MODE (LONG_BITS), MODE (LONG_BITS), NO_MOID); a68_op (A68_STD, "AND", m, genie_and_long_mp); a68_op (A68_STD, "&", m, genie_and_long_mp); a68_op (A68_STD, "OR", m, genie_or_long_mp); a68_op (A68_EXT, "XOR", m, genie_xor_long_mp); m = a68_proc (MODE (LONG_BITS), MODE (LONG_BITS), MODE (INT), NO_MOID); a68_op (A68_STD, "SHL", m, genie_shl_long_mp); a68_op (A68_STD, "UP", m, genie_shl_long_mp); a68_op (A68_STD, "SHR", m, genie_shr_long_mp); a68_op (A68_STD, "DOWN", m, genie_shr_long_mp); m = a68_proc (MODE (BOOL), MODE (INT), MODE (LONG_BITS), NO_MOID); a68_op (A68_STD, "ELEM", m, genie_elem_long_bits); m = a68_proc (MODE (LONG_BITS), MODE (INT), MODE (LONG_BITS), NO_MOID); a68_op (A68_STD, "SET", m, genie_set_long_bits); a68_op (A68_STD, "CLEAR", m, genie_clear_long_bits); /* LONG LONG INT */ m = a68_proc (MODE (LONGLONG_INT), MODE (LONG_INT), NO_MOID); a68_op (A68_STD, "LENG", m, genie_lengthen_long_mp_to_longlong_mp); m = a68_proc (MODE (LONG_INT), MODE (LONGLONG_INT), NO_MOID); a68_op (A68_STD, "SHORTEN", m, genie_shorten_longlong_mp_to_long_mp); m = a68_proc (MODE (LONGLONG_INT), MODE (LONGLONG_INT), NO_MOID); a68_op (A68_STD, "+", m, genie_idle); a68_op (A68_STD, "-", m, genie_minus_long_mp); a68_op (A68_STD, "ABS", m, genie_abs_long_mp); m = a68_proc (MODE (INT), MODE (LONGLONG_INT), NO_MOID); a68_op (A68_STD, "SIGN", m, genie_sign_long_mp); m = a68_proc (MODE (BOOL), MODE (LONGLONG_INT), NO_MOID); a68_op (A68_STD, "ODD", m, genie_odd_long_mp); m = a68_proc (MODE (LONGLONG_INT), MODE (LONGLONG_REAL), NO_MOID); a68_op (A68_STD, "ENTIER", m, genie_entier_long_mp); a68_op (A68_STD, "ROUND", m, genie_round_long_mp); m = a68_proc (MODE (LONGLONG_INT), MODE (LONGLONG_INT), MODE (LONGLONG_INT), NO_MOID); a68_op (A68_STD, "+", m, genie_add_long_int); a68_op (A68_STD, "-", m, genie_sub_long_int); a68_op (A68_STD, "*", m, genie_mul_long_int); a68_op (A68_STD, "OVER", m, genie_over_long_mp); a68_op (A68_STD, "%", m, genie_over_long_mp); a68_op (A68_STD, "MOD", m, genie_mod_long_mp); a68_op (A68_STD, "%*", m, genie_mod_long_mp); m = a68_proc (MODE (REF_LONGLONG_INT), MODE (REF_LONGLONG_INT), MODE (LONGLONG_INT), NO_MOID); a68_op (A68_STD, "+:=", m, genie_plusab_long_int); a68_op (A68_STD, "-:=", m, genie_minusab_long_int); a68_op (A68_STD, "*:=", m, genie_timesab_long_int); a68_op (A68_STD, "%:=", m, genie_overab_long_mp); a68_op (A68_STD, "%*:=", m, genie_modab_long_mp); a68_op (A68_STD, "PLUSAB", m, genie_plusab_long_int); a68_op (A68_STD, "MINUSAB", m, genie_minusab_long_int); a68_op (A68_STD, "TIMESAB", m, genie_timesab_long_int); a68_op (A68_STD, "OVERAB", m, genie_overab_long_mp); a68_op (A68_STD, "MODAB", m, genie_modab_long_mp); m = a68_proc (MODE (LONGLONG_REAL), MODE (LONGLONG_INT), MODE (LONGLONG_INT), NO_MOID); a68_op (A68_STD, "/", m, genie_div_long_mp); m = a68_proc (MODE (BOOL), MODE (LONGLONG_INT), MODE (LONGLONG_INT), NO_MOID); a68_op (A68_STD, "=", m, genie_eq_long_mp); a68_op (A68_STD, "EQ", m, genie_eq_long_mp); a68_op (A68_STD, "/=", m, genie_ne_long_mp); a68_op (A68_STD, "~=", m, genie_ne_long_mp); a68_op (A68_STD, "^=", m, genie_ne_long_mp); a68_op (A68_STD, "NE", m, genie_ne_long_mp); a68_op (A68_STD, "<", m, genie_lt_long_mp); a68_op (A68_STD, "LT", m, genie_lt_long_mp); a68_op (A68_STD, "<=", m, genie_le_long_mp); a68_op (A68_STD, "LE", m, genie_le_long_mp); a68_op (A68_STD, ">", m, genie_gt_long_mp); a68_op (A68_STD, "GT", m, genie_gt_long_mp); a68_op (A68_STD, ">=", m, genie_ge_long_mp); a68_op (A68_STD, "GE", m, genie_ge_long_mp); m = a68_proc (MODE (LONGLONG_INT), MODE (LONGLONG_INT), MODE (INT), NO_MOID); a68_op (A68_STD, "**", m, genie_pow_long_mp_int_int); a68_op (A68_STD, "^", m, genie_pow_long_mp_int_int); m = a68_proc (MODE (LONGLONG_COMPLEX), MODE (LONGLONG_INT), MODE (LONGLONG_INT), NO_MOID); a68_op (A68_STD, "I", m, genie_idle); a68_op (A68_STD, "+*", m, genie_idle); /* LONG LONG REAL */ m = a68_proc (MODE (LONGLONG_REAL), MODE (LONG_REAL), NO_MOID); a68_op (A68_STD, "LENG", m, genie_lengthen_long_mp_to_longlong_mp); m = a68_proc (MODE (LONG_REAL), MODE (LONGLONG_REAL), NO_MOID); a68_op (A68_STD, "SHORTEN", m, genie_shorten_longlong_mp_to_long_mp); m = a68_proc (MODE (LONGLONG_REAL), MODE (LONGLONG_REAL), NO_MOID); a68_op (A68_STD, "+", m, genie_idle); a68_op (A68_STD, "-", m, genie_minus_long_mp); a68_op (A68_STD, "ABS", m, genie_abs_long_mp); a68_idf (A68_STD, "longlongsqrt", m, genie_sqrt_long_mp); a68_idf (A68_EXT, "longlongcbrt", m, genie_curt_long_mp); a68_idf (A68_EXT, "longlongcurt", m, genie_curt_long_mp); a68_idf (A68_STD, "longlongexp", m, genie_exp_long_mp); a68_idf (A68_STD, "longlongln", m, genie_ln_long_mp); a68_idf (A68_STD, "longlonglog", m, genie_log_long_mp); a68_idf (A68_STD, "longlongsin", m, genie_sin_long_mp); a68_idf (A68_STD, "longlongcos", m, genie_cos_long_mp); a68_idf (A68_STD, "longlongtan", m, genie_tan_long_mp); a68_idf (A68_STD, "longlongasin", m, genie_asin_long_mp); a68_idf (A68_STD, "longlongacos", m, genie_acos_long_mp); a68_idf (A68_STD, "longlongatan", m, genie_atan_long_mp); a68_idf (A68_STD, "longlongarcsin", m, genie_asin_long_mp); a68_idf (A68_STD, "longlongarccos", m, genie_acos_long_mp); a68_idf (A68_STD, "longlongarctan", m, genie_atan_long_mp); a68_idf (A68_EXT, "longlongsinh", m, genie_sinh_long_mp); a68_idf (A68_EXT, "longlongcosh", m, genie_cosh_long_mp); a68_idf (A68_EXT, "longlongtanh", m, genie_tanh_long_mp); a68_idf (A68_EXT, "longlongasinh", m, genie_arcsinh_long_mp); a68_idf (A68_EXT, "longlongacosh", m, genie_arccosh_long_mp); a68_idf (A68_EXT, "longlongatanh", m, genie_arctanh_long_mp); a68_idf (A68_EXT, "longlongarcsinh", m, genie_arcsinh_long_mp); a68_idf (A68_EXT, "longlongarccosh", m, genie_arccosh_long_mp); a68_idf (A68_EXT, "longlongarctanh", m, genie_arctanh_long_mp); a68_idf (A68_EXT, "qsqrt", m, genie_sqrt_long_mp); a68_idf (A68_EXT, "qcbrt", m, genie_curt_long_mp); a68_idf (A68_EXT, "qcurt", m, genie_curt_long_mp); a68_idf (A68_EXT, "qexp", m, genie_exp_long_mp); a68_idf (A68_EXT, "qln", m, genie_ln_long_mp); a68_idf (A68_EXT, "qlog", m, genie_log_long_mp); a68_idf (A68_EXT, "qsin", m, genie_sin_long_mp); a68_idf (A68_EXT, "qcos", m, genie_cos_long_mp); a68_idf (A68_EXT, "qtan", m, genie_tan_long_mp); a68_idf (A68_EXT, "qasin", m, genie_asin_long_mp); a68_idf (A68_EXT, "qacos", m, genie_acos_long_mp); a68_idf (A68_EXT, "qatan", m, genie_atan_long_mp); a68_idf (A68_EXT, "qsinh", m, genie_sinh_long_mp); a68_idf (A68_EXT, "qcosh", m, genie_cosh_long_mp); a68_idf (A68_EXT, "qtanh", m, genie_tanh_long_mp); a68_idf (A68_EXT, "qasinh", m, genie_arcsinh_long_mp); a68_idf (A68_EXT, "qacosh", m, genie_arccosh_long_mp); a68_idf (A68_EXT, "qatanh", m, genie_arctanh_long_mp); m = a68_proc (MODE (LONGLONG_REAL), MODE (LONGLONG_REAL), MODE (LONGLONG_REAL), NO_MOID); a68_idf (A68_STD, "longarctan2", m, genie_atan2_long_mp); a68_idf (A68_STD, "qarctan2", m, genie_atan2_long_mp); m = a68_proc (MODE (LONGLONG_REAL), MODE (LONGLONG_REAL), MODE (LONGLONG_REAL), NO_MOID); a68_op (A68_STD, "+", m, genie_add_long_mp); a68_op (A68_STD, "-", m, genie_sub_long_mp); a68_op (A68_STD, "*", m, genie_mul_long_mp); a68_op (A68_STD, "/", m, genie_div_long_mp); a68_op (A68_STD, "**", m, genie_pow_long_mp); a68_op (A68_STD, "UP", m, genie_pow_long_mp); a68_op (A68_STD, "^", m, genie_pow_long_mp); m = a68_proc (MODE (REF_LONGLONG_REAL), MODE (REF_LONGLONG_REAL), MODE (LONGLONG_REAL), NO_MOID); a68_op (A68_STD, "+:=", m, genie_plusab_long_mp); a68_op (A68_STD, "-:=", m, genie_minusab_long_mp); a68_op (A68_STD, "*:=", m, genie_timesab_long_mp); a68_op (A68_STD, "/:=", m, genie_divab_long_mp); a68_op (A68_STD, "PLUSAB", m, genie_plusab_long_mp); a68_op (A68_STD, "MINUSAB", m, genie_minusab_long_mp); a68_op (A68_STD, "TIMESAB", m, genie_timesab_long_mp); a68_op (A68_STD, "DIVAB", m, genie_divab_long_mp); m = a68_proc (MODE (BOOL), MODE (LONGLONG_REAL), MODE (LONGLONG_REAL), NO_MOID); a68_op (A68_STD, "=", m, genie_eq_long_mp); a68_op (A68_STD, "EQ", m, genie_eq_long_mp); a68_op (A68_STD, "/=", m, genie_ne_long_mp); a68_op (A68_STD, "~=", m, genie_ne_long_mp); a68_op (A68_STD, "^=", m, genie_ne_long_mp); a68_op (A68_STD, "NE", m, genie_ne_long_mp); a68_op (A68_STD, "<", m, genie_lt_long_mp); a68_op (A68_STD, "LT", m, genie_lt_long_mp); a68_op (A68_STD, "<=", m, genie_le_long_mp); a68_op (A68_STD, "LE", m, genie_le_long_mp); a68_op (A68_STD, ">", m, genie_gt_long_mp); a68_op (A68_STD, "GT", m, genie_gt_long_mp); a68_op (A68_STD, ">=", m, genie_ge_long_mp); a68_op (A68_STD, "GE", m, genie_ge_long_mp); m = a68_proc (MODE (LONGLONG_REAL), MODE (LONGLONG_REAL), MODE (INT), NO_MOID); a68_op (A68_STD, "**", m, genie_pow_long_mp_int); a68_op (A68_STD, "UP", m, genie_pow_long_mp_int); a68_op (A68_STD, "^", m, genie_pow_long_mp_int); m = a68_proc (MODE (LONGLONG_COMPLEX), MODE (LONGLONG_REAL), MODE (LONGLONG_REAL), NO_MOID); a68_op (A68_STD, "I", m, genie_idle); a68_op (A68_STD, "+*", m, genie_idle); /* LONGLONG COMPLEX */ m = a68_proc (MODE (LONGLONG_COMPLEX), MODE (LONG_COMPLEX), NO_MOID); a68_op (A68_STD, "LENG", m, genie_lengthen_long_complex_to_longlong_complex); m = a68_proc (MODE (LONG_COMPLEX), MODE (LONGLONG_COMPLEX), NO_MOID); a68_op (A68_STD, "SHORTEN", m, genie_shorten_longlong_complex_to_long_complex); m = a68_proc (MODE (LONGLONG_REAL), MODE (LONGLONG_COMPLEX), NO_MOID); a68_op (A68_STD, "RE", m, genie_re_long_complex); a68_op (A68_STD, "IM", m, genie_im_long_complex); a68_op (A68_STD, "ARG", m, genie_arg_long_complex); a68_op (A68_STD, "ABS", m, genie_abs_long_complex); m = a68_proc (MODE (LONGLONG_COMPLEX), MODE (LONGLONG_COMPLEX), NO_MOID); a68_op (A68_STD, "+", m, genie_idle); a68_op (A68_STD, "-", m, genie_minus_long_complex); a68_op (A68_STD, "CONJ", m, genie_conj_long_complex); m = a68_proc (MODE (LONGLONG_COMPLEX), MODE (LONGLONG_COMPLEX), MODE (LONGLONG_COMPLEX), NO_MOID); a68_op (A68_STD, "+", m, genie_add_long_complex); a68_op (A68_STD, "-", m, genie_sub_long_complex); a68_op (A68_STD, "*", m, genie_mul_long_complex); a68_op (A68_STD, "/", m, genie_div_long_complex); m = a68_proc (MODE (LONGLONG_COMPLEX), MODE (LONGLONG_COMPLEX), MODE (INT), NO_MOID); a68_op (A68_STD, "**", m, genie_pow_long_complex_int); a68_op (A68_STD, "UP", m, genie_pow_long_complex_int); a68_op (A68_STD, "^", m, genie_pow_long_complex_int); m = a68_proc (MODE (BOOL), MODE (LONGLONG_COMPLEX), MODE (LONGLONG_COMPLEX), NO_MOID); a68_op (A68_STD, "=", m, genie_eq_long_complex); a68_op (A68_STD, "EQ", m, genie_eq_long_complex); a68_op (A68_STD, "/=", m, genie_ne_long_complex); a68_op (A68_STD, "~=", m, genie_ne_long_complex); a68_op (A68_STD, "^=", m, genie_ne_long_complex); a68_op (A68_STD, "NE", m, genie_ne_long_complex); m = a68_proc (MODE (REF_LONGLONG_COMPLEX), MODE (REF_LONGLONG_COMPLEX), MODE (LONGLONG_COMPLEX), NO_MOID); a68_op (A68_STD, "+:=", m, genie_plusab_long_complex); a68_op (A68_STD, "-:=", m, genie_minusab_long_complex); a68_op (A68_STD, "*:=", m, genie_timesab_long_complex); a68_op (A68_STD, "/:=", m, genie_divab_long_complex); a68_op (A68_STD, "PLUSAB", m, genie_plusab_long_complex); a68_op (A68_STD, "MINUSAB", m, genie_minusab_long_complex); a68_op (A68_STD, "TIMESAB", m, genie_timesab_long_complex); a68_op (A68_STD, "DIVAB", m, genie_divab_long_complex); /* LONG LONG BITS */ m = a68_proc (MODE (LONGLONG_INT), MODE (LONGLONG_BITS), NO_MOID); a68_op (A68_STD, "ABS", m, genie_idle); m = a68_proc (MODE (LONGLONG_BITS), MODE (LONGLONG_INT), NO_MOID); a68_op (A68_STD, "BIN", m, genie_bin_long_mp); m = a68_proc (MODE (LONGLONG_BITS), MODE (LONGLONG_BITS), NO_MOID); a68_op (A68_STD, "NOT", m, genie_not_long_mp); a68_op (A68_STD, "~", m, genie_not_long_mp); m = a68_proc (MODE (LONG_BITS), MODE (LONGLONG_BITS), NO_MOID); a68_op (A68_STD, "SHORTEN", m, genie_shorten_longlong_mp_to_long_mp); m = a68_proc (MODE (BOOL), MODE (LONGLONG_BITS), MODE (LONGLONG_BITS), NO_MOID); a68_op (A68_STD, "=", m, genie_eq_long_mp); a68_op (A68_STD, "EQ", m, genie_eq_long_mp); a68_op (A68_STD, "/=", m, genie_ne_long_mp); a68_op (A68_STD, "~=", m, genie_ne_long_mp); a68_op (A68_STD, "^=", m, genie_ne_long_mp); a68_op (A68_STD, "NE", m, genie_ne_long_mp); a68_op (A68_STD, "<=", m, genie_le_long_mp); a68_op (A68_STD, "LE", m, genie_le_long_mp); a68_op (A68_STD, ">=", m, genie_ge_long_mp); a68_op (A68_STD, "GE", m, genie_ge_long_mp); m = a68_proc (MODE (LONGLONG_BITS), MODE (LONGLONG_BITS), MODE (LONGLONG_BITS), NO_MOID); a68_op (A68_STD, "AND", m, genie_and_long_mp); a68_op (A68_STD, "&", m, genie_and_long_mp); a68_op (A68_STD, "OR", m, genie_or_long_mp); a68_op (A68_EXT, "XOR", m, genie_xor_long_mp); m = a68_proc (MODE (LONGLONG_BITS), MODE (LONGLONG_BITS), MODE (INT), NO_MOID); a68_op (A68_STD, "SHL", m, genie_shl_long_mp); a68_op (A68_STD, "UP", m, genie_shl_long_mp); a68_op (A68_STD, "SHR", m, genie_shr_long_mp); a68_op (A68_STD, "DOWN", m, genie_shr_long_mp); m = a68_proc (MODE (BOOL), MODE (INT), MODE (LONGLONG_BITS), NO_MOID); a68_op (A68_STD, "ELEM", m, genie_elem_longlong_bits); m = a68_proc (MODE (LONGLONG_BITS), MODE (INT), MODE (LONGLONG_BITS), NO_MOID); a68_op (A68_STD, "SET", m, genie_set_longlong_bits); a68_op (A68_STD, "CLEAR", m, genie_clear_longlong_bits); /* Some "terminators" to handle the mapping of very short or very long modes. This allows you to write SHORT REAL z = SHORTEN pi while everything is silently mapped onto REAL */ m = a68_proc (MODE (LONGLONG_INT), MODE (LONGLONG_INT), NO_MOID); a68_op (A68_STD, "LENG", m, genie_idle); m = a68_proc (MODE (LONGLONG_REAL), MODE (LONGLONG_REAL), NO_MOID); a68_op (A68_STD, "LENG", m, genie_idle); m = a68_proc (MODE (LONGLONG_COMPLEX), MODE (LONGLONG_COMPLEX), NO_MOID); a68_op (A68_STD, "LENG", m, genie_idle); m = a68_proc (MODE (LONGLONG_BITS), MODE (LONGLONG_BITS), NO_MOID); a68_op (A68_STD, "LENG", m, genie_idle); m = a68_proc (MODE (INT), MODE (INT), NO_MOID); a68_op (A68_STD, "SHORTEN", m, genie_idle); m = a68_proc (MODE (REAL), MODE (REAL), NO_MOID); a68_op (A68_STD, "SHORTEN", m, genie_idle); m = a68_proc (MODE (COMPLEX), MODE (COMPLEX), NO_MOID); a68_op (A68_STD, "SHORTEN", m, genie_idle); m = a68_proc (MODE (BITS), MODE (BITS), NO_MOID); a68_op (A68_STD, "SHORTEN", m, genie_idle); m = proc_complex_complex; a68_idf (A68_EXT, "complexsqrt", m, genie_sqrt_complex); a68_idf (A68_EXT, "csqrt", m, genie_sqrt_complex); a68_idf (A68_EXT, "complexexp", m, genie_exp_complex); a68_idf (A68_EXT, "cexp", m, genie_exp_complex); a68_idf (A68_EXT, "complexln", m, genie_ln_complex); a68_idf (A68_EXT, "cln", m, genie_ln_complex); a68_idf (A68_EXT, "complexsin", m, genie_sin_complex); a68_idf (A68_EXT, "csin", m, genie_sin_complex); a68_idf (A68_EXT, "complexcos", m, genie_cos_complex); a68_idf (A68_EXT, "ccos", m, genie_cos_complex); a68_idf (A68_EXT, "complextan", m, genie_tan_complex); a68_idf (A68_EXT, "ctan", m, genie_tan_complex); a68_idf (A68_EXT, "complexasin", m, genie_arcsin_complex); a68_idf (A68_EXT, "casin", m, genie_arcsin_complex); a68_idf (A68_EXT, "complexacos", m, genie_arccos_complex); a68_idf (A68_EXT, "cacos", m, genie_arccos_complex); a68_idf (A68_EXT, "complexatan", m, genie_arctan_complex); a68_idf (A68_EXT, "catan", m, genie_arctan_complex); a68_idf (A68_EXT, "complexarcsin", m, genie_arcsin_complex); a68_idf (A68_EXT, "carcsin", m, genie_arcsin_complex); a68_idf (A68_EXT, "complexarccos", m, genie_arccos_complex); a68_idf (A68_EXT, "carccos", m, genie_arccos_complex); a68_idf (A68_EXT, "complexarctan", m, genie_arctan_complex); a68_idf (A68_EXT, "carctan", m, genie_arctan_complex); #if defined HAVE_GNU_GSL a68_idf (A68_EXT, "complexsinh", m, genie_sinh_complex); a68_idf (A68_EXT, "csinh", m, genie_sinh_complex); a68_idf (A68_EXT, "complexcosh", m, genie_cosh_complex); a68_idf (A68_EXT, "ccosh", m, genie_cosh_complex); a68_idf (A68_EXT, "complextanh", m, genie_tanh_complex); a68_idf (A68_EXT, "ctanh", m, genie_tanh_complex); a68_idf (A68_EXT, "complexasinh", m, genie_arcsinh_complex); a68_idf (A68_EXT, "casinh", m, genie_arcsinh_complex); a68_idf (A68_EXT, "complexacosh", m, genie_arccosh_complex); a68_idf (A68_EXT, "cacosh", m, genie_arccosh_complex); a68_idf (A68_EXT, "complexatanh", m, genie_arctanh_complex); a68_idf (A68_EXT, "catanh", m, genie_arctanh_complex); a68_idf (A68_EXT, "complexarcsinh", m, genie_arcsinh_complex); a68_idf (A68_EXT, "carcsinh", m, genie_arcsinh_complex); a68_idf (A68_EXT, "complexarccosh", m, genie_arccosh_complex); a68_idf (A68_EXT, "carccosh", m, genie_arccosh_complex); a68_idf (A68_EXT, "complexarctanh", m, genie_arctanh_complex); a68_idf (A68_EXT, "carctanh", m, genie_arctanh_complex); m = a68_proc (MODE (REAL), proc_real_real, MODE (REAL), MODE (REF_REAL), NO_MOID); a68_idf (A68_EXT, "laplace", m, genie_laplace); #endif m = a68_proc (MODE (LONG_COMPLEX), MODE (LONG_COMPLEX), NO_MOID); a68_idf (A68_EXT, "longcomplexsqrt", m, genie_sqrt_long_complex); a68_idf (A68_EXT, "dcsqrt", m, genie_sqrt_long_complex); a68_idf (A68_EXT, "longcomplexexp", m, genie_exp_long_complex); a68_idf (A68_EXT, "dcexp", m, genie_exp_long_complex); a68_idf (A68_EXT, "longcomplexln", m, genie_ln_long_complex); a68_idf (A68_EXT, "dcln", m, genie_ln_long_complex); a68_idf (A68_EXT, "longcomplexsin", m, genie_sin_long_complex); a68_idf (A68_EXT, "dcsin", m, genie_sin_long_complex); a68_idf (A68_EXT, "longcomplexcos", m, genie_cos_long_complex); a68_idf (A68_EXT, "dccos", m, genie_cos_long_complex); a68_idf (A68_EXT, "longcomplextan", m, genie_tan_long_complex); a68_idf (A68_EXT, "dctan", m, genie_tan_long_complex); a68_idf (A68_EXT, "longcomplexarcsin", m, genie_asin_long_complex); a68_idf (A68_EXT, "dcasin", m, genie_asin_long_complex); a68_idf (A68_EXT, "longcomplexarccos", m, genie_acos_long_complex); a68_idf (A68_EXT, "dcacos", m, genie_acos_long_complex); a68_idf (A68_EXT, "longcomplexarctan", m, genie_atan_long_complex); a68_idf (A68_EXT, "dcatan", m, genie_atan_long_complex); m = a68_proc (MODE (LONGLONG_COMPLEX), MODE (LONGLONG_COMPLEX), NO_MOID); a68_idf (A68_EXT, "longlongcomplexsqrt", m, genie_sqrt_long_complex); a68_idf (A68_EXT, "qcsqrt", m, genie_sqrt_long_complex); a68_idf (A68_EXT, "longlongcomplexexp", m, genie_exp_long_complex); a68_idf (A68_EXT, "qcexp", m, genie_exp_long_complex); a68_idf (A68_EXT, "longlongcomplexln", m, genie_ln_long_complex); a68_idf (A68_EXT, "qcln", m, genie_ln_long_complex); a68_idf (A68_EXT, "longlongcomplexsin", m, genie_sin_long_complex); a68_idf (A68_EXT, "qcsin", m, genie_sin_long_complex); a68_idf (A68_EXT, "longlongcomplexcos", m, genie_cos_long_complex); a68_idf (A68_EXT, "qccos", m, genie_cos_long_complex); a68_idf (A68_EXT, "longlongcomplextan", m, genie_tan_long_complex); a68_idf (A68_EXT, "qctan", m, genie_tan_long_complex); a68_idf (A68_EXT, "longlongcomplexarcsin", m, genie_asin_long_complex); a68_idf (A68_EXT, "qcasin", m, genie_asin_long_complex); a68_idf (A68_EXT, "longlongcomplexarccos", m, genie_acos_long_complex); a68_idf (A68_EXT, "qcacos", m, genie_acos_long_complex); a68_idf (A68_EXT, "longlongcomplexarctan", m, genie_atan_long_complex); a68_idf (A68_EXT, "qcatan", m, genie_atan_long_complex); /* SOUND/RIFF procs */ m = a68_proc (MODE (SOUND), MODE (INT), MODE (INT), MODE (INT), MODE (INT), NO_MOID); a68_idf (A68_EXT, "newsound", m, genie_new_sound); m = a68_proc (MODE (INT), MODE (SOUND), MODE (INT), MODE (INT), NO_MOID); a68_idf (A68_EXT, "getsound", m, genie_get_sound); m = a68_proc (MODE (VOID), MODE (SOUND), MODE (INT), MODE (INT), MODE (INT), NO_MOID); a68_idf (A68_EXT, "setsound", m, genie_set_sound); m = a68_proc (MODE (INT), MODE (SOUND), NO_MOID); a68_op (A68_EXT, "RESOLUTION", m, genie_sound_resolution); a68_op (A68_EXT, "CHANNELS", m, genie_sound_channels); a68_op (A68_EXT, "RATE", m, genie_sound_rate); a68_op (A68_EXT, "SAMPLES", m, genie_sound_samples); } /*! \brief set up standenv - transput **/ static void stand_transput (void) { MOID_T *m; a68_idf (A68_STD, "errorchar", MODE (CHAR), genie_error_char); a68_idf (A68_STD, "expchar", MODE (CHAR), genie_exp_char); a68_idf (A68_STD, "flip", MODE (CHAR), genie_flip_char); a68_idf (A68_STD, "flop", MODE (CHAR), genie_flop_char); a68_idf (A68_EXT, "blankcharacter", MODE (CHAR), genie_blank_char); a68_idf (A68_STD, "blankchar", MODE (CHAR), genie_blank_char); a68_idf (A68_STD, "blank", MODE (CHAR), genie_blank_char); a68_idf (A68_EXT, "nullcharacter", MODE (CHAR), genie_null_char); a68_idf (A68_STD, "nullchar", MODE (CHAR), genie_null_char); a68_idf (A68_EXT, "newlinecharacter", MODE (CHAR), genie_newline_char); a68_idf (A68_EXT, "newlinechar", MODE (CHAR), genie_newline_char); a68_idf (A68_EXT, "formfeedcharacter", MODE (CHAR), genie_formfeed_char); a68_idf (A68_EXT, "formfeedchar", MODE (CHAR), genie_formfeed_char); a68_idf (A68_EXT, "tabcharacter", MODE (CHAR), genie_tab_char); a68_idf (A68_EXT, "tabchar", MODE (CHAR), genie_tab_char); m = a68_proc (MODE (STRING), MODE (NUMBER), MODE (INT), NO_MOID); a68_idf (A68_STD, "whole", m, genie_whole); m = a68_proc (MODE (STRING), MODE (NUMBER), MODE (INT), MODE (INT), NO_MOID); a68_idf (A68_STD, "fixed", m, genie_fixed); m = a68_proc (MODE (STRING), MODE (NUMBER), MODE (INT), MODE (INT), MODE (INT), NO_MOID); a68_idf (A68_STD, "float", m, genie_float); m = a68_proc (MODE (STRING), MODE (NUMBER), MODE (INT), MODE (INT), MODE (INT), MODE (INT), NO_MOID); a68_idf (A68_STD, "real", m, genie_real); a68_idf (A68_STD, "standin", MODE (REF_FILE), genie_stand_in); a68_idf (A68_STD, "standout", MODE (REF_FILE), genie_stand_out); a68_idf (A68_STD, "standback", MODE (REF_FILE), genie_stand_back); a68_idf (A68_EXT, "standerror", MODE (REF_FILE), genie_stand_error); a68_idf (A68_STD, "standinchannel", MODE (CHANNEL), genie_stand_in_channel); a68_idf (A68_STD, "standoutchannel", MODE (CHANNEL), genie_stand_out_channel); a68_idf (A68_EXT, "standdrawchannel", MODE (CHANNEL), genie_stand_draw_channel); a68_idf (A68_STD, "standbackchannel", MODE (CHANNEL), genie_stand_back_channel); a68_idf (A68_EXT, "standerrorchannel", MODE (CHANNEL), genie_stand_error_channel); m = a68_proc (MODE (VOID), MODE (REF_FILE), MODE (STRING), NO_MOID); a68_idf (A68_STD, "maketerm", m, genie_make_term); m = a68_proc (MODE (BOOL), MODE (CHAR), MODE (REF_INT), MODE (STRING), NO_MOID); a68_idf (A68_STD, "charinstring", m, genie_char_in_string); a68_idf (A68_EXT, "lastcharinstring", m, genie_last_char_in_string); m = a68_proc (MODE (BOOL), MODE (STRING), MODE (REF_INT), MODE (STRING), NO_MOID); a68_idf (A68_EXT, "stringinstring", m, genie_string_in_string); m = a68_proc (MODE (STRING), MODE (REF_FILE), NO_MOID); a68_idf (A68_EXT, "idf", m, genie_idf); a68_idf (A68_EXT, "term", m, genie_term); m = a68_proc (MODE (STRING), NO_MOID); a68_idf (A68_EXT, "programidf", m, genie_program_idf); /* Event routines */ m = a68_proc (MODE (VOID), MODE (REF_FILE), MODE (PROC_REF_FILE_BOOL), NO_MOID); a68_idf (A68_STD, "onfileend", m, genie_on_file_end); a68_idf (A68_STD, "onpageend", m, genie_on_page_end); a68_idf (A68_STD, "onlineend", m, genie_on_line_end); a68_idf (A68_STD, "onlogicalfileend", m, genie_on_file_end); a68_idf (A68_STD, "onphysicalfileend", m, genie_on_file_end); a68_idf (A68_STD, "onformatend", m, genie_on_format_end); a68_idf (A68_STD, "onformaterror", m, genie_on_format_error); a68_idf (A68_STD, "onvalueerror", m, genie_on_value_error); a68_idf (A68_STD, "onopenerror", m, genie_on_open_error); a68_idf (A68_EXT, "ontransputerror", m, genie_on_transput_error); /* Enquiries on files */ a68_idf (A68_STD, "putpossible", MODE (PROC_REF_FILE_BOOL), genie_put_possible); a68_idf (A68_STD, "getpossible", MODE (PROC_REF_FILE_BOOL), genie_get_possible); a68_idf (A68_STD, "binpossible", MODE (PROC_REF_FILE_BOOL), genie_bin_possible); a68_idf (A68_STD, "setpossible", MODE (PROC_REF_FILE_BOOL), genie_set_possible); a68_idf (A68_STD, "resetpossible", MODE (PROC_REF_FILE_BOOL), genie_reset_possible); a68_idf (A68_EXT, "rewindpossible", MODE (PROC_REF_FILE_BOOL), genie_reset_possible); a68_idf (A68_STD, "reidfpossible", MODE (PROC_REF_FILE_BOOL), genie_reidf_possible); a68_idf (A68_EXT, "drawpossible", MODE (PROC_REF_FILE_BOOL), genie_draw_possible); a68_idf (A68_STD, "compressible", MODE (PROC_REF_FILE_BOOL), genie_compressible); a68_idf (A68_EXT, "endoffile", MODE (PROC_REF_FILE_BOOL), genie_eof); a68_idf (A68_EXT, "eof", MODE (PROC_REF_FILE_BOOL), genie_eof); a68_idf (A68_EXT, "endofline", MODE (PROC_REF_FILE_BOOL), genie_eoln); a68_idf (A68_EXT, "eoln", MODE (PROC_REF_FILE_BOOL), genie_eoln); /* Handling of files */ m = a68_proc (MODE (INT), MODE (REF_FILE), MODE (STRING), MODE (CHANNEL), NO_MOID); a68_idf (A68_STD, "open", m, genie_open); a68_idf (A68_STD, "establish", m, genie_establish); m = a68_proc (MODE (VOID), MODE (REF_FILE), MODE (REF_STRING), NO_MOID); a68_idf (A68_STD, "associate", m, genie_associate); m = a68_proc (MODE (INT), MODE (REF_FILE), MODE (CHANNEL), NO_MOID); a68_idf (A68_STD, "create", m, genie_create); a68_idf (A68_STD, "close", MODE (PROC_REF_FILE_VOID), genie_close); a68_idf (A68_STD, "lock", MODE (PROC_REF_FILE_VOID), genie_lock); a68_idf (A68_STD, "scratch", MODE (PROC_REF_FILE_VOID), genie_erase); a68_idf (A68_STD, "erase", MODE (PROC_REF_FILE_VOID), genie_erase); a68_idf (A68_STD, "reset", MODE (PROC_REF_FILE_VOID), genie_reset); a68_idf (A68_EXT, "rewind", MODE (PROC_REF_FILE_VOID), genie_reset); a68_idf (A68_STD, "scratch", MODE (PROC_REF_FILE_VOID), genie_erase); a68_idf (A68_STD, "newline", MODE (PROC_REF_FILE_VOID), genie_new_line); a68_idf (A68_STD, "newpage", MODE (PROC_REF_FILE_VOID), genie_new_page); a68_idf (A68_STD, "space", MODE (PROC_REF_FILE_VOID), genie_space); a68_idf (A68_STD, "backspace", MODE (PROC_REF_FILE_VOID), genie_backspace); m = a68_proc (MODE (INT), MODE (REF_FILE), MODE (INT), NO_MOID); a68_idf (A68_STD, "set", m, genie_set); a68_idf (A68_STD, "seek", m, genie_set); m = a68_proc (MODE (VOID), MODE (ROW_SIMPLIN), NO_MOID); a68_idf (A68_STD, "read", m, genie_read); a68_idf (A68_STD, "readbin", m, genie_read_bin); a68_idf (A68_STD, "readf", m, genie_read_format); m = a68_proc (MODE (VOID), MODE (ROW_SIMPLOUT), NO_MOID); a68_idf (A68_STD, "print", m, genie_write); a68_idf (A68_STD, "write", m, genie_write); a68_idf (A68_STD, "printbin", m, genie_write_bin); a68_idf (A68_STD, "writebin", m, genie_write_bin); a68_idf (A68_STD, "printf", m, genie_write_format); a68_idf (A68_STD, "writef", m, genie_write_format); m = a68_proc (MODE (VOID), MODE (REF_FILE), MODE (ROW_SIMPLIN), NO_MOID); a68_idf (A68_STD, "get", m, genie_read_file); a68_idf (A68_STD, "getf", m, genie_read_file_format); a68_idf (A68_STD, "getbin", m, genie_read_bin_file); m = a68_proc (MODE (VOID), MODE (REF_FILE), MODE (ROW_SIMPLOUT), NO_MOID); a68_idf (A68_STD, "put", m, genie_write_file); a68_idf (A68_STD, "putf", m, genie_write_file_format); a68_idf (A68_STD, "putbin", m, genie_write_bin_file); /* ALGOL68C type procs */ m = proc_int; a68_idf (A68_EXT, "readint", m, genie_read_int); m = a68_proc (MODE (VOID), MODE (INT), NO_MOID); a68_idf (A68_EXT, "printint", m, genie_print_int); m = a68_proc (MODE (LONG_INT), NO_MOID); a68_idf (A68_EXT, "readlongint", m, genie_read_long_int); m = a68_proc (MODE (VOID), MODE (LONG_INT), NO_MOID); a68_idf (A68_EXT, "printlongint", m, genie_print_long_int); m = a68_proc (MODE (LONGLONG_INT), NO_MOID); a68_idf (A68_EXT, "readlonglongint", m, genie_read_longlong_int); m = a68_proc (MODE (VOID), MODE (LONGLONG_INT), NO_MOID); a68_idf (A68_EXT, "printlonglongint", m, genie_print_longlong_int); m = proc_real; a68_idf (A68_EXT, "readreal", m, genie_read_real); m = a68_proc (MODE (VOID), MODE (REAL), NO_MOID); a68_idf (A68_EXT, "printreal", m, genie_print_real); m = a68_proc (MODE (LONG_REAL), NO_MOID); a68_idf (A68_EXT, "readlongreal", m, genie_read_long_real); a68_idf (A68_EXT, "readdouble", m, genie_read_long_real); m = a68_proc (MODE (VOID), MODE (LONG_REAL), NO_MOID); a68_idf (A68_EXT, "printlongreal", m, genie_print_long_real); a68_idf (A68_EXT, "printdouble", m, genie_print_long_real); m = a68_proc (MODE (LONGLONG_REAL), NO_MOID); a68_idf (A68_EXT, "readlonglongreal", m, genie_read_longlong_real); a68_idf (A68_EXT, "readquad", m, genie_read_longlong_real); m = a68_proc (MODE (VOID), MODE (LONGLONG_REAL), NO_MOID); a68_idf (A68_EXT, "printlonglongreal", m, genie_print_longlong_real); a68_idf (A68_EXT, "printquad", m, genie_print_longlong_real); m = a68_proc (MODE (COMPLEX), NO_MOID); a68_idf (A68_EXT, "readcompl", m, genie_read_complex); a68_idf (A68_EXT, "readcomplex", m, genie_read_complex); m = a68_proc (MODE (VOID), MODE (COMPLEX), NO_MOID); a68_idf (A68_EXT, "printcompl", m, genie_print_complex); a68_idf (A68_EXT, "printcomplex", m, genie_print_complex); m = a68_proc (MODE (LONG_COMPLEX), NO_MOID); a68_idf (A68_EXT, "readlongcompl", m, genie_read_long_complex); a68_idf (A68_EXT, "readlongcomplex", m, genie_read_long_complex); m = a68_proc (MODE (VOID), MODE (LONG_COMPLEX), NO_MOID); a68_idf (A68_EXT, "printlongcompl", m, genie_print_long_complex); a68_idf (A68_EXT, "printlongcomplex", m, genie_print_long_complex); m = a68_proc (MODE (LONGLONG_COMPLEX), NO_MOID); a68_idf (A68_EXT, "readlonglongcompl", m, genie_read_longlong_complex); a68_idf (A68_EXT, "readlonglongcomplex", m, genie_read_longlong_complex); m = a68_proc (MODE (VOID), MODE (LONGLONG_COMPLEX), NO_MOID); a68_idf (A68_EXT, "printlonglongcompl", m, genie_print_longlong_complex); a68_idf (A68_EXT, "printlonglongcomplex", m, genie_print_longlong_complex); m = proc_bool; a68_idf (A68_EXT, "readbool", m, genie_read_bool); m = a68_proc (MODE (VOID), MODE (BOOL), NO_MOID); a68_idf (A68_EXT, "printbool", m, genie_print_bool); m = a68_proc (MODE (BITS), NO_MOID); a68_idf (A68_EXT, "readbits", m, genie_read_bits); m = a68_proc (MODE (LONG_BITS), NO_MOID); a68_idf (A68_EXT, "readlongbits", m, genie_read_long_bits); m = a68_proc (MODE (LONGLONG_BITS), NO_MOID); a68_idf (A68_EXT, "readlonglongbits", m, genie_read_longlong_bits); m = a68_proc (MODE (VOID), MODE (BITS), NO_MOID); a68_idf (A68_EXT, "printbits", m, genie_print_bits); m = a68_proc (MODE (VOID), MODE (LONG_BITS), NO_MOID); a68_idf (A68_EXT, "printlongbits", m, genie_print_long_bits); m = a68_proc (MODE (VOID), MODE (LONGLONG_BITS), NO_MOID); a68_idf (A68_EXT, "printlonglongbits", m, genie_print_longlong_bits); m = proc_char; a68_idf (A68_EXT, "readchar", m, genie_read_char); m = a68_proc (MODE (VOID), MODE (CHAR), NO_MOID); a68_idf (A68_EXT, "printchar", m, genie_print_char); a68_idf (A68_EXT, "readstring", MODE (PROC_STRING), genie_read_string); a68_idf (A68_EXT, "readline", MODE (PROC_STRING), genie_read_line); m = a68_proc (MODE (VOID), MODE (STRING), NO_MOID); a68_idf (A68_EXT, "printstring", m, genie_print_string); /* Constants ex GSL */ a68_idf (A68_EXT, "cgsspeedoflight", MODE (REAL), genie_cgs_speed_of_light); a68_idf (A68_EXT, "cgsgravitationalconstant", MODE (REAL), genie_cgs_gravitational_constant); a68_idf (A68_EXT, "cgsplanckconstant", MODE (REAL), genie_cgs_planck_constant_h); a68_idf (A68_EXT, "cgsplanckconstantbar", MODE (REAL), genie_cgs_planck_constant_hbar); a68_idf (A68_EXT, "cgsastronomicalunit", MODE (REAL), genie_cgs_astronomical_unit); a68_idf (A68_EXT, "cgslightyear", MODE (REAL), genie_cgs_light_year); a68_idf (A68_EXT, "cgsparsec", MODE (REAL), genie_cgs_parsec); a68_idf (A68_EXT, "cgsgravaccel", MODE (REAL), genie_cgs_grav_accel); a68_idf (A68_EXT, "cgselectronvolt", MODE (REAL), genie_cgs_electron_volt); a68_idf (A68_EXT, "cgsmasselectron", MODE (REAL), genie_cgs_mass_electron); a68_idf (A68_EXT, "cgsmassmuon", MODE (REAL), genie_cgs_mass_muon); a68_idf (A68_EXT, "cgsmassproton", MODE (REAL), genie_cgs_mass_proton); a68_idf (A68_EXT, "cgsmassneutron", MODE (REAL), genie_cgs_mass_neutron); a68_idf (A68_EXT, "cgsrydberg", MODE (REAL), genie_cgs_rydberg); a68_idf (A68_EXT, "cgsboltzmann", MODE (REAL), genie_cgs_boltzmann); a68_idf (A68_EXT, "cgsbohrmagneton", MODE (REAL), genie_cgs_bohr_magneton); a68_idf (A68_EXT, "cgsnuclearmagneton", MODE (REAL), genie_cgs_nuclear_magneton); a68_idf (A68_EXT, "cgselectronmagneticmoment", MODE (REAL), genie_cgs_electron_magnetic_moment); a68_idf (A68_EXT, "cgsprotonmagneticmoment", MODE (REAL), genie_cgs_proton_magnetic_moment); a68_idf (A68_EXT, "cgsmolargas", MODE (REAL), genie_cgs_molar_gas); a68_idf (A68_EXT, "cgsstandardgasvolume", MODE (REAL), genie_cgs_standard_gas_volume); a68_idf (A68_EXT, "cgsminute", MODE (REAL), genie_cgs_minute); a68_idf (A68_EXT, "cgshour", MODE (REAL), genie_cgs_hour); a68_idf (A68_EXT, "cgsday", MODE (REAL), genie_cgs_day); a68_idf (A68_EXT, "cgsweek", MODE (REAL), genie_cgs_week); a68_idf (A68_EXT, "cgsinch", MODE (REAL), genie_cgs_inch); a68_idf (A68_EXT, "cgsfoot", MODE (REAL), genie_cgs_foot); a68_idf (A68_EXT, "cgsyard", MODE (REAL), genie_cgs_yard); a68_idf (A68_EXT, "cgsmile", MODE (REAL), genie_cgs_mile); a68_idf (A68_EXT, "cgsnauticalmile", MODE (REAL), genie_cgs_nautical_mile); a68_idf (A68_EXT, "cgsfathom", MODE (REAL), genie_cgs_fathom); a68_idf (A68_EXT, "cgsmil", MODE (REAL), genie_cgs_mil); a68_idf (A68_EXT, "cgspoint", MODE (REAL), genie_cgs_point); a68_idf (A68_EXT, "cgstexpoint", MODE (REAL), genie_cgs_texpoint); a68_idf (A68_EXT, "cgsmicron", MODE (REAL), genie_cgs_micron); a68_idf (A68_EXT, "cgsangstrom", MODE (REAL), genie_cgs_angstrom); a68_idf (A68_EXT, "cgshectare", MODE (REAL), genie_cgs_hectare); a68_idf (A68_EXT, "cgsacre", MODE (REAL), genie_cgs_acre); a68_idf (A68_EXT, "cgsbarn", MODE (REAL), genie_cgs_barn); a68_idf (A68_EXT, "cgsliter", MODE (REAL), genie_cgs_liter); a68_idf (A68_EXT, "cgsusgallon", MODE (REAL), genie_cgs_us_gallon); a68_idf (A68_EXT, "cgsquart", MODE (REAL), genie_cgs_quart); a68_idf (A68_EXT, "cgspint", MODE (REAL), genie_cgs_pint); a68_idf (A68_EXT, "cgscup", MODE (REAL), genie_cgs_cup); a68_idf (A68_EXT, "cgsfluidounce", MODE (REAL), genie_cgs_fluid_ounce); a68_idf (A68_EXT, "cgstablespoon", MODE (REAL), genie_cgs_tablespoon); a68_idf (A68_EXT, "cgsteaspoon", MODE (REAL), genie_cgs_teaspoon); a68_idf (A68_EXT, "cgscanadiangallon", MODE (REAL), genie_cgs_canadian_gallon); a68_idf (A68_EXT, "cgsukgallon", MODE (REAL), genie_cgs_uk_gallon); a68_idf (A68_EXT, "cgsmilesperhour", MODE (REAL), genie_cgs_miles_per_hour); a68_idf (A68_EXT, "cgskilometersperhour", MODE (REAL), genie_cgs_kilometers_per_hour); a68_idf (A68_EXT, "cgsknot", MODE (REAL), genie_cgs_knot); a68_idf (A68_EXT, "cgspoundmass", MODE (REAL), genie_cgs_pound_mass); a68_idf (A68_EXT, "cgsouncemass", MODE (REAL), genie_cgs_ounce_mass); a68_idf (A68_EXT, "cgston", MODE (REAL), genie_cgs_ton); a68_idf (A68_EXT, "cgsmetricton", MODE (REAL), genie_cgs_metric_ton); a68_idf (A68_EXT, "cgsukton", MODE (REAL), genie_cgs_uk_ton); a68_idf (A68_EXT, "cgstroyounce", MODE (REAL), genie_cgs_troy_ounce); a68_idf (A68_EXT, "cgscarat", MODE (REAL), genie_cgs_carat); a68_idf (A68_EXT, "cgsunifiedatomicmass", MODE (REAL), genie_cgs_unified_atomic_mass); a68_idf (A68_EXT, "cgsgramforce", MODE (REAL), genie_cgs_gram_force); a68_idf (A68_EXT, "cgspoundforce", MODE (REAL), genie_cgs_pound_force); a68_idf (A68_EXT, "cgskilopoundforce", MODE (REAL), genie_cgs_kilopound_force); a68_idf (A68_EXT, "cgspoundal", MODE (REAL), genie_cgs_poundal); a68_idf (A68_EXT, "cgscalorie", MODE (REAL), genie_cgs_calorie); a68_idf (A68_EXT, "cgsbtu", MODE (REAL), genie_cgs_btu); a68_idf (A68_EXT, "cgstherm", MODE (REAL), genie_cgs_therm); a68_idf (A68_EXT, "cgshorsepower", MODE (REAL), genie_cgs_horsepower); a68_idf (A68_EXT, "cgsbar", MODE (REAL), genie_cgs_bar); a68_idf (A68_EXT, "cgsstdatmosphere", MODE (REAL), genie_cgs_std_atmosphere); a68_idf (A68_EXT, "cgstorr", MODE (REAL), genie_cgs_torr); a68_idf (A68_EXT, "cgsmeterofmercury", MODE (REAL), genie_cgs_meter_of_mercury); a68_idf (A68_EXT, "cgsinchofmercury", MODE (REAL), genie_cgs_inch_of_mercury); a68_idf (A68_EXT, "cgsinchofwater", MODE (REAL), genie_cgs_inch_of_water); a68_idf (A68_EXT, "cgspsi", MODE (REAL), genie_cgs_psi); a68_idf (A68_EXT, "cgspoise", MODE (REAL), genie_cgs_poise); a68_idf (A68_EXT, "cgsstokes", MODE (REAL), genie_cgs_stokes); a68_idf (A68_EXT, "cgsfaraday", MODE (REAL), genie_cgs_faraday); a68_idf (A68_EXT, "cgselectroncharge", MODE (REAL), genie_cgs_electron_charge); a68_idf (A68_EXT, "cgsgauss", MODE (REAL), genie_cgs_gauss); a68_idf (A68_EXT, "cgsstilb", MODE (REAL), genie_cgs_stilb); a68_idf (A68_EXT, "cgslumen", MODE (REAL), genie_cgs_lumen); a68_idf (A68_EXT, "cgslux", MODE (REAL), genie_cgs_lux); a68_idf (A68_EXT, "cgsphot", MODE (REAL), genie_cgs_phot); a68_idf (A68_EXT, "cgsfootcandle", MODE (REAL), genie_cgs_footcandle); a68_idf (A68_EXT, "cgslambert", MODE (REAL), genie_cgs_lambert); a68_idf (A68_EXT, "cgsfootlambert", MODE (REAL), genie_cgs_footlambert); a68_idf (A68_EXT, "cgscurie", MODE (REAL), genie_cgs_curie); a68_idf (A68_EXT, "cgsroentgen", MODE (REAL), genie_cgs_roentgen); a68_idf (A68_EXT, "cgsrad", MODE (REAL), genie_cgs_rad); a68_idf (A68_EXT, "cgssolarmass", MODE (REAL), genie_cgs_solar_mass); a68_idf (A68_EXT, "cgsbohrradius", MODE (REAL), genie_cgs_bohr_radius); a68_idf (A68_EXT, "cgsnewton", MODE (REAL), genie_cgs_newton); a68_idf (A68_EXT, "cgsdyne", MODE (REAL), genie_cgs_dyne); a68_idf (A68_EXT, "cgsjoule", MODE (REAL), genie_cgs_joule); a68_idf (A68_EXT, "cgserg", MODE (REAL), genie_cgs_erg); a68_idf (A68_EXT, "mksaspeedoflight", MODE (REAL), genie_mks_speed_of_light); a68_idf (A68_EXT, "mksagravitationalconstant", MODE (REAL), genie_mks_gravitational_constant); a68_idf (A68_EXT, "mksaplanckconstant", MODE (REAL), genie_mks_planck_constant_h); a68_idf (A68_EXT, "mksaplanckconstantbar", MODE (REAL), genie_mks_planck_constant_hbar); a68_idf (A68_EXT, "mksavacuumpermeability", MODE (REAL), genie_mks_vacuum_permeability); a68_idf (A68_EXT, "mksaastronomicalunit", MODE (REAL), genie_mks_astronomical_unit); a68_idf (A68_EXT, "mksalightyear", MODE (REAL), genie_mks_light_year); a68_idf (A68_EXT, "mksaparsec", MODE (REAL), genie_mks_parsec); a68_idf (A68_EXT, "mksagravaccel", MODE (REAL), genie_mks_grav_accel); a68_idf (A68_EXT, "mksaelectronvolt", MODE (REAL), genie_mks_electron_volt); a68_idf (A68_EXT, "mksamasselectron", MODE (REAL), genie_mks_mass_electron); a68_idf (A68_EXT, "mksamassmuon", MODE (REAL), genie_mks_mass_muon); a68_idf (A68_EXT, "mksamassproton", MODE (REAL), genie_mks_mass_proton); a68_idf (A68_EXT, "mksamassneutron", MODE (REAL), genie_mks_mass_neutron); a68_idf (A68_EXT, "mksarydberg", MODE (REAL), genie_mks_rydberg); a68_idf (A68_EXT, "mksaboltzmann", MODE (REAL), genie_mks_boltzmann); a68_idf (A68_EXT, "mksabohrmagneton", MODE (REAL), genie_mks_bohr_magneton); a68_idf (A68_EXT, "mksanuclearmagneton", MODE (REAL), genie_mks_nuclear_magneton); a68_idf (A68_EXT, "mksaelectronmagneticmoment", MODE (REAL), genie_mks_electron_magnetic_moment); a68_idf (A68_EXT, "mksaprotonmagneticmoment", MODE (REAL), genie_mks_proton_magnetic_moment); a68_idf (A68_EXT, "mksamolargas", MODE (REAL), genie_mks_molar_gas); a68_idf (A68_EXT, "mksastandardgasvolume", MODE (REAL), genie_mks_standard_gas_volume); a68_idf (A68_EXT, "mksaminute", MODE (REAL), genie_mks_minute); a68_idf (A68_EXT, "mksahour", MODE (REAL), genie_mks_hour); a68_idf (A68_EXT, "mksaday", MODE (REAL), genie_mks_day); a68_idf (A68_EXT, "mksaweek", MODE (REAL), genie_mks_week); a68_idf (A68_EXT, "mksainch", MODE (REAL), genie_mks_inch); a68_idf (A68_EXT, "mksafoot", MODE (REAL), genie_mks_foot); a68_idf (A68_EXT, "mksayard", MODE (REAL), genie_mks_yard); a68_idf (A68_EXT, "mksamile", MODE (REAL), genie_mks_mile); a68_idf (A68_EXT, "mksanauticalmile", MODE (REAL), genie_mks_nautical_mile); a68_idf (A68_EXT, "mksafathom", MODE (REAL), genie_mks_fathom); a68_idf (A68_EXT, "mksamil", MODE (REAL), genie_mks_mil); a68_idf (A68_EXT, "mksapoint", MODE (REAL), genie_mks_point); a68_idf (A68_EXT, "mksatexpoint", MODE (REAL), genie_mks_texpoint); a68_idf (A68_EXT, "mksamicron", MODE (REAL), genie_mks_micron); a68_idf (A68_EXT, "mksaangstrom", MODE (REAL), genie_mks_angstrom); a68_idf (A68_EXT, "mksahectare", MODE (REAL), genie_mks_hectare); a68_idf (A68_EXT, "mksaacre", MODE (REAL), genie_mks_acre); a68_idf (A68_EXT, "mksabarn", MODE (REAL), genie_mks_barn); a68_idf (A68_EXT, "mksaliter", MODE (REAL), genie_mks_liter); a68_idf (A68_EXT, "mksausgallon", MODE (REAL), genie_mks_us_gallon); a68_idf (A68_EXT, "mksaquart", MODE (REAL), genie_mks_quart); a68_idf (A68_EXT, "mksapint", MODE (REAL), genie_mks_pint); a68_idf (A68_EXT, "mksacup", MODE (REAL), genie_mks_cup); a68_idf (A68_EXT, "mksafluidounce", MODE (REAL), genie_mks_fluid_ounce); a68_idf (A68_EXT, "mksatablespoon", MODE (REAL), genie_mks_tablespoon); a68_idf (A68_EXT, "mksateaspoon", MODE (REAL), genie_mks_teaspoon); a68_idf (A68_EXT, "mksacanadiangallon", MODE (REAL), genie_mks_canadian_gallon); a68_idf (A68_EXT, "mksaukgallon", MODE (REAL), genie_mks_uk_gallon); a68_idf (A68_EXT, "mksamilesperhour", MODE (REAL), genie_mks_miles_per_hour); a68_idf (A68_EXT, "mksakilometersperhour", MODE (REAL), genie_mks_kilometers_per_hour); a68_idf (A68_EXT, "mksaknot", MODE (REAL), genie_mks_knot); a68_idf (A68_EXT, "mksapoundmass", MODE (REAL), genie_mks_pound_mass); a68_idf (A68_EXT, "mksaouncemass", MODE (REAL), genie_mks_ounce_mass); a68_idf (A68_EXT, "mksaton", MODE (REAL), genie_mks_ton); a68_idf (A68_EXT, "mksametricton", MODE (REAL), genie_mks_metric_ton); a68_idf (A68_EXT, "mksaukton", MODE (REAL), genie_mks_uk_ton); a68_idf (A68_EXT, "mksatroyounce", MODE (REAL), genie_mks_troy_ounce); a68_idf (A68_EXT, "mksacarat", MODE (REAL), genie_mks_carat); a68_idf (A68_EXT, "mksaunifiedatomicmass", MODE (REAL), genie_mks_unified_atomic_mass); a68_idf (A68_EXT, "mksagramforce", MODE (REAL), genie_mks_gram_force); a68_idf (A68_EXT, "mksapoundforce", MODE (REAL), genie_mks_pound_force); a68_idf (A68_EXT, "mksakilopoundforce", MODE (REAL), genie_mks_kilopound_force); a68_idf (A68_EXT, "mksapoundal", MODE (REAL), genie_mks_poundal); a68_idf (A68_EXT, "mksacalorie", MODE (REAL), genie_mks_calorie); a68_idf (A68_EXT, "mksabtu", MODE (REAL), genie_mks_btu); a68_idf (A68_EXT, "mksatherm", MODE (REAL), genie_mks_therm); a68_idf (A68_EXT, "mksahorsepower", MODE (REAL), genie_mks_horsepower); a68_idf (A68_EXT, "mksabar", MODE (REAL), genie_mks_bar); a68_idf (A68_EXT, "mksastdatmosphere", MODE (REAL), genie_mks_std_atmosphere); a68_idf (A68_EXT, "mksatorr", MODE (REAL), genie_mks_torr); a68_idf (A68_EXT, "mksameterofmercury", MODE (REAL), genie_mks_meter_of_mercury); a68_idf (A68_EXT, "mksainchofmercury", MODE (REAL), genie_mks_inch_of_mercury); a68_idf (A68_EXT, "mksainchofwater", MODE (REAL), genie_mks_inch_of_water); a68_idf (A68_EXT, "mksapsi", MODE (REAL), genie_mks_psi); a68_idf (A68_EXT, "mksapoise", MODE (REAL), genie_mks_poise); a68_idf (A68_EXT, "mksastokes", MODE (REAL), genie_mks_stokes); a68_idf (A68_EXT, "mksafaraday", MODE (REAL), genie_mks_faraday); a68_idf (A68_EXT, "mksaelectroncharge", MODE (REAL), genie_mks_electron_charge); a68_idf (A68_EXT, "mksagauss", MODE (REAL), genie_mks_gauss); a68_idf (A68_EXT, "mksastilb", MODE (REAL), genie_mks_stilb); a68_idf (A68_EXT, "mksalumen", MODE (REAL), genie_mks_lumen); a68_idf (A68_EXT, "mksalux", MODE (REAL), genie_mks_lux); a68_idf (A68_EXT, "mksaphot", MODE (REAL), genie_mks_phot); a68_idf (A68_EXT, "mksafootcandle", MODE (REAL), genie_mks_footcandle); a68_idf (A68_EXT, "mksalambert", MODE (REAL), genie_mks_lambert); a68_idf (A68_EXT, "mksafootlambert", MODE (REAL), genie_mks_footlambert); a68_idf (A68_EXT, "mksacurie", MODE (REAL), genie_mks_curie); a68_idf (A68_EXT, "mksaroentgen", MODE (REAL), genie_mks_roentgen); a68_idf (A68_EXT, "mksarad", MODE (REAL), genie_mks_rad); a68_idf (A68_EXT, "mksasolarmass", MODE (REAL), genie_mks_solar_mass); a68_idf (A68_EXT, "mksabohrradius", MODE (REAL), genie_mks_bohr_radius); a68_idf (A68_EXT, "mksavacuumpermittivity", MODE (REAL), genie_mks_vacuum_permittivity); a68_idf (A68_EXT, "mksanewton", MODE (REAL), genie_mks_newton); a68_idf (A68_EXT, "mksadyne", MODE (REAL), genie_mks_dyne); a68_idf (A68_EXT, "mksajoule", MODE (REAL), genie_mks_joule); a68_idf (A68_EXT, "mksaerg", MODE (REAL), genie_mks_erg); a68_idf (A68_EXT, "numfinestructure", MODE (REAL), genie_num_fine_structure); a68_idf (A68_EXT, "numavogadro", MODE (REAL), genie_num_avogadro); a68_idf (A68_EXT, "numyotta", MODE (REAL), genie_num_yotta); a68_idf (A68_EXT, "numzetta", MODE (REAL), genie_num_zetta); a68_idf (A68_EXT, "numexa", MODE (REAL), genie_num_exa); a68_idf (A68_EXT, "numpeta", MODE (REAL), genie_num_peta); a68_idf (A68_EXT, "numtera", MODE (REAL), genie_num_tera); a68_idf (A68_EXT, "numgiga", MODE (REAL), genie_num_giga); a68_idf (A68_EXT, "nummega", MODE (REAL), genie_num_mega); a68_idf (A68_EXT, "numkilo", MODE (REAL), genie_num_kilo); a68_idf (A68_EXT, "nummilli", MODE (REAL), genie_num_milli); a68_idf (A68_EXT, "nummicro", MODE (REAL), genie_num_micro); a68_idf (A68_EXT, "numnano", MODE (REAL), genie_num_nano); a68_idf (A68_EXT, "numpico", MODE (REAL), genie_num_pico); a68_idf (A68_EXT, "numfemto", MODE (REAL), genie_num_femto); a68_idf (A68_EXT, "numatto", MODE (REAL), genie_num_atto); a68_idf (A68_EXT, "numzepto", MODE (REAL), genie_num_zepto); a68_idf (A68_EXT, "numyocto", MODE (REAL), genie_num_yocto); } /*! \brief set up standenv - extensions **/ static void stand_extensions (void) { MOID_T *m = NO_MOID; (void) m; /* To fool cc in case we have none of the libraries */ #if defined HAVE_GNU_PLOTUTILS /* Drawing */ m = a68_proc (MODE (BOOL), MODE (REF_FILE), MODE (STRING), MODE (STRING), NO_MOID); a68_idf (A68_EXT, "drawdevice", m, genie_make_device); a68_idf (A68_EXT, "makedevice", m, genie_make_device); m = a68_proc (MODE (REAL), MODE (REF_FILE), NO_MOID); a68_idf (A68_EXT, "drawaspect", m, genie_draw_aspect); m = a68_proc (MODE (VOID), MODE (REF_FILE), NO_MOID); a68_idf (A68_EXT, "drawclear", m, genie_draw_clear); a68_idf (A68_EXT, "drawerase", m, genie_draw_clear); a68_idf (A68_EXT, "drawflush", m, genie_draw_show); a68_idf (A68_EXT, "drawshow", m, genie_draw_show); m = a68_proc (MODE (VOID), MODE (REF_FILE), MODE (INT), NO_MOID); a68_idf (A68_EXT, "drawfillstyle", m, genie_draw_fillstyle); m = a68_proc (MODE (STRING), MODE (INT), NO_MOID); a68_idf (A68_EXT, "drawgetcolourname", m, genie_draw_get_colour_name); a68_idf (A68_EXT, "drawgetcolorname", m, genie_draw_get_colour_name); m = a68_proc (MODE (VOID), MODE (REF_FILE), MODE (REAL), MODE (REAL), MODE (REAL), NO_MOID); a68_idf (A68_EXT, "drawcolor", m, genie_draw_colour); a68_idf (A68_EXT, "drawcolour", m, genie_draw_colour); a68_idf (A68_EXT, "drawbackgroundcolor", m, genie_draw_background_colour); a68_idf (A68_EXT, "drawbackgroundcolour", m, genie_draw_background_colour); a68_idf (A68_EXT, "drawcircle", m, genie_draw_circle); a68_idf (A68_EXT, "drawball", m, genie_draw_atom); a68_idf (A68_EXT, "drawstar", m, genie_draw_star); m = a68_proc (MODE (VOID), MODE (REF_FILE), MODE (REAL), MODE (REAL), NO_MOID); a68_idf (A68_EXT, "drawpoint", m, genie_draw_point); a68_idf (A68_EXT, "drawline", m, genie_draw_line); a68_idf (A68_EXT, "drawmove", m, genie_draw_move); a68_idf (A68_EXT, "drawrect", m, genie_draw_rect); m = a68_proc (MODE (VOID), MODE (REF_FILE), MODE (CHAR), MODE (CHAR), MODE (ROW_CHAR), NO_MOID); a68_idf (A68_EXT, "drawtext", m, genie_draw_text); m = a68_proc (MODE (VOID), MODE (REF_FILE), MODE (ROW_CHAR), NO_MOID); a68_idf (A68_EXT, "drawlinestyle", m, genie_draw_linestyle); a68_idf (A68_EXT, "drawfontname", m, genie_draw_fontname); m = a68_proc (MODE (VOID), MODE (REF_FILE), MODE (REAL), NO_MOID); a68_idf (A68_EXT, "drawlinewidth", m, genie_draw_linewidth); m = a68_proc (MODE (VOID), MODE (REF_FILE), MODE (INT), NO_MOID); a68_idf (A68_EXT, "drawfontsize", m, genie_draw_fontsize); a68_idf (A68_EXT, "drawtextangle", m, genie_draw_textangle); m = a68_proc (MODE (VOID), MODE (REF_FILE), MODE (STRING), NO_MOID); a68_idf (A68_EXT, "drawcolorname", m, genie_draw_colour_name); a68_idf (A68_EXT, "drawcolourname", m, genie_draw_colour_name); a68_idf (A68_EXT, "drawbackgroundcolorname", m, genie_draw_background_colour_name); a68_idf (A68_EXT, "drawbackgroundcolourname", m, genie_draw_background_colour_name); #endif #if defined HAVE_GNU_GSL m = proc_real_real; a68_idf (A68_EXT, "erf", m, genie_erf_real); a68_idf (A68_EXT, "erfc", m, genie_erfc_real); a68_idf (A68_EXT, "gamma", m, genie_gamma_real); a68_idf (A68_EXT, "lngamma", m, genie_lngamma_real); a68_idf (A68_EXT, "factorial", m, genie_factorial_real); a68_idf (A68_EXT, "airyai", m, genie_airy_ai_real); a68_idf (A68_EXT, "airybi", m, genie_airy_bi_real); a68_idf (A68_EXT, "airyaiderivative", m, genie_airy_ai_deriv_real); a68_idf (A68_EXT, "airybiderivative", m, genie_airy_bi_deriv_real); a68_idf (A68_EXT, "ellipticintegralk", m, genie_elliptic_integral_k_real); a68_idf (A68_EXT, "ellipticintegrale", m, genie_elliptic_integral_e_real); m = proc_real_real_real; a68_idf (A68_EXT, "beta", m, genie_beta_real); a68_idf (A68_EXT, "besseljn", m, genie_bessel_jn_real); a68_idf (A68_EXT, "besselyn", m, genie_bessel_yn_real); a68_idf (A68_EXT, "besselin", m, genie_bessel_in_real); a68_idf (A68_EXT, "besselexpin", m, genie_bessel_exp_in_real); a68_idf (A68_EXT, "besselkn", m, genie_bessel_kn_real); a68_idf (A68_EXT, "besselexpkn", m, genie_bessel_exp_kn_real); a68_idf (A68_EXT, "besseljl", m, genie_bessel_jl_real); a68_idf (A68_EXT, "besselyl", m, genie_bessel_yl_real); a68_idf (A68_EXT, "besselexpil", m, genie_bessel_exp_il_real); a68_idf (A68_EXT, "besselexpkl", m, genie_bessel_exp_kl_real); a68_idf (A68_EXT, "besseljnu", m, genie_bessel_jnu_real); a68_idf (A68_EXT, "besselynu", m, genie_bessel_ynu_real); a68_idf (A68_EXT, "besselinu", m, genie_bessel_inu_real); a68_idf (A68_EXT, "besselexpinu", m, genie_bessel_exp_inu_real); a68_idf (A68_EXT, "besselknu", m, genie_bessel_knu_real); a68_idf (A68_EXT, "besselexpknu", m, genie_bessel_exp_knu_real); a68_idf (A68_EXT, "ellipticintegralrc", m, genie_elliptic_integral_rc_real); a68_idf (A68_EXT, "incompletegamma", m, genie_gamma_inc_real); m = a68_proc (MODE (REAL), MODE (REAL), MODE (REAL), MODE (REAL), NO_MOID); a68_idf (A68_EXT, "incompletebeta", m, genie_beta_inc_real); a68_idf (A68_EXT, "ellipticintegralrf", m, genie_elliptic_integral_rf_real); a68_idf (A68_EXT, "ellipticintegralrd", m, genie_elliptic_integral_rd_real); m = a68_proc (MODE (REAL), MODE (REAL), MODE (REAL), MODE (REAL), MODE (REAL), NO_MOID); a68_idf (A68_EXT, "ellipticintegralrj", m, genie_elliptic_integral_rj_real); /* Vector and matrix monadic */ m = a68_proc (MODE (ROW_REAL), MODE (ROW_REAL), NO_MOID); a68_op (A68_EXT, "+", m, genie_idle); a68_op (A68_EXT, "-", m, genie_vector_minus); m = a68_proc (MODE (ROWROW_REAL), MODE (ROWROW_REAL), NO_MOID); a68_op (A68_EXT, "+", m, genie_idle); a68_op (A68_EXT, "-", m, genie_matrix_minus); a68_op (A68_EXT, "T", m, genie_matrix_transpose); a68_op (A68_EXT, "INV", m, genie_matrix_inv); m = a68_proc (MODE (REAL), MODE (ROWROW_REAL), NO_MOID); a68_op (A68_EXT, "DET", m, genie_matrix_det); a68_op (A68_EXT, "TRACE", m, genie_matrix_trace); m = a68_proc (MODE (ROW_COMPLEX), MODE (ROW_COMPLEX), NO_MOID); a68_op (A68_EXT, "+", m, genie_idle); a68_op (A68_EXT, "-", m, genie_vector_complex_minus); m = a68_proc (MODE (ROWROW_COMPLEX), MODE (ROWROW_COMPLEX), NO_MOID); a68_op (A68_EXT, "+", m, genie_idle); a68_op (A68_EXT, "-", m, genie_matrix_complex_minus); a68_op (A68_EXT, "T", m, genie_matrix_complex_transpose); a68_op (A68_EXT, "INV", m, genie_matrix_complex_inv); m = a68_proc (MODE (COMPLEX), MODE (ROWROW_COMPLEX), NO_MOID); a68_op (A68_EXT, "DET", m, genie_matrix_complex_det); a68_op (A68_EXT, "TRACE", m, genie_matrix_complex_trace); /* Vector and matrix dyadic */ m = a68_proc (MODE (BOOL), MODE (ROW_REAL), MODE (ROW_REAL), NO_MOID); a68_op (A68_EXT, "=", m, genie_vector_eq); a68_op (A68_EXT, "/=", m, genie_vector_ne); m = a68_proc (MODE (ROW_REAL), MODE (ROW_REAL), MODE (ROW_REAL), NO_MOID); a68_op (A68_EXT, "+", m, genie_vector_add); a68_op (A68_EXT, "-", m, genie_vector_sub); m = a68_proc (MODE (REF_ROW_REAL), MODE (REF_ROW_REAL), MODE (ROW_REAL), NO_MOID); a68_op (A68_EXT, "+:=", m, genie_vector_plusab); a68_op (A68_EXT, "PLUSAB", m, genie_vector_plusab); a68_op (A68_EXT, "-:=", m, genie_vector_minusab); a68_op (A68_EXT, "MINUSAB", m, genie_vector_minusab); m = a68_proc (MODE (BOOL), MODE (ROWROW_REAL), MODE (ROWROW_REAL), NO_MOID); a68_op (A68_EXT, "=", m, genie_matrix_eq); a68_op (A68_EXT, "/-", m, genie_matrix_ne); m = a68_proc (MODE (ROWROW_REAL), MODE (ROWROW_REAL), MODE (ROWROW_REAL), NO_MOID); a68_op (A68_EXT, "+", m, genie_matrix_add); a68_op (A68_EXT, "-", m, genie_matrix_sub); m = a68_proc (MODE (REF_ROWROW_REAL), MODE (REF_ROWROW_REAL), MODE (ROWROW_REAL), NO_MOID); a68_op (A68_EXT, "+:=", m, genie_matrix_plusab); a68_op (A68_EXT, "PLUSAB", m, genie_matrix_plusab); a68_op (A68_EXT, "-:=", m, genie_matrix_minusab); a68_op (A68_EXT, "MINUSAB", m, genie_matrix_minusab); m = a68_proc (MODE (BOOL), MODE (ROW_COMPLEX), MODE (ROW_COMPLEX), NO_MOID); a68_op (A68_EXT, "=", m, genie_vector_complex_eq); a68_op (A68_EXT, "/=", m, genie_vector_complex_ne); m = a68_proc (MODE (ROW_COMPLEX), MODE (ROW_COMPLEX), MODE (ROW_COMPLEX), NO_MOID); a68_op (A68_EXT, "+", m, genie_vector_complex_add); a68_op (A68_EXT, "-", m, genie_vector_complex_sub); m = a68_proc (MODE (REF_ROW_COMPLEX), MODE (REF_ROW_COMPLEX), MODE (ROW_COMPLEX), NO_MOID); a68_op (A68_EXT, "+:=", m, genie_vector_complex_plusab); a68_op (A68_EXT, "PLUSAB", m, genie_vector_complex_plusab); a68_op (A68_EXT, "-:=", m, genie_vector_complex_minusab); a68_op (A68_EXT, "MINUSAB", m, genie_vector_complex_minusab); m = a68_proc (MODE (BOOL), MODE (ROWROW_COMPLEX), MODE (ROWROW_COMPLEX), NO_MOID); a68_op (A68_EXT, "=", m, genie_matrix_complex_eq); a68_op (A68_EXT, "/=", m, genie_matrix_complex_ne); m = a68_proc (MODE (ROWROW_COMPLEX), MODE (ROWROW_COMPLEX), MODE (ROWROW_COMPLEX), NO_MOID); a68_op (A68_EXT, "+", m, genie_matrix_complex_add); a68_op (A68_EXT, "-", m, genie_matrix_complex_sub); m = a68_proc (MODE (REF_ROWROW_COMPLEX), MODE (REF_ROWROW_COMPLEX), MODE (ROWROW_COMPLEX), NO_MOID); a68_op (A68_EXT, "+:=", m, genie_matrix_complex_plusab); a68_op (A68_EXT, "PLUSAB", m, genie_matrix_complex_plusab); a68_op (A68_EXT, "-:=", m, genie_matrix_complex_minusab); a68_op (A68_EXT, "MINUSAB", m, genie_matrix_complex_minusab); /* Vector and matrix scaling */ m = a68_proc (MODE (ROW_REAL), MODE (REAL), MODE (ROW_REAL), NO_MOID); a68_op (A68_EXT, "*", m, genie_real_scale_vector); m = a68_proc (MODE (ROW_REAL), MODE (ROW_REAL), MODE (REAL), NO_MOID); a68_op (A68_EXT, "*", m, genie_vector_scale_real); a68_op (A68_EXT, "/", m, genie_vector_div_real); m = a68_proc (MODE (ROWROW_REAL), MODE (REAL), MODE (ROWROW_REAL), NO_MOID); a68_op (A68_EXT, "*", m, genie_real_scale_matrix); m = a68_proc (MODE (ROWROW_REAL), MODE (ROWROW_REAL), MODE (REAL), NO_MOID); a68_op (A68_EXT, "*", m, genie_matrix_scale_real); a68_op (A68_EXT, "/", m, genie_matrix_div_real); m = a68_proc (MODE (ROW_COMPLEX), MODE (COMPLEX), MODE (ROW_COMPLEX), NO_MOID); a68_op (A68_EXT, "*", m, genie_complex_scale_vector_complex); m = a68_proc (MODE (ROW_COMPLEX), MODE (ROW_COMPLEX), MODE (COMPLEX), NO_MOID); a68_op (A68_EXT, "*", m, genie_vector_complex_scale_complex); a68_op (A68_EXT, "/", m, genie_vector_complex_div_complex); m = a68_proc (MODE (ROWROW_COMPLEX), MODE (COMPLEX), MODE (ROWROW_COMPLEX), NO_MOID); a68_op (A68_EXT, "*", m, genie_complex_scale_matrix_complex); m = a68_proc (MODE (ROWROW_COMPLEX), MODE (ROWROW_COMPLEX), MODE (COMPLEX), NO_MOID); a68_op (A68_EXT, "*", m, genie_matrix_complex_scale_complex); a68_op (A68_EXT, "/", m, genie_matrix_complex_div_complex); m = a68_proc (MODE (REF_ROW_REAL), MODE (REF_ROW_REAL), MODE (REAL), NO_MOID); a68_op (A68_EXT, "*:=", m, genie_vector_scale_real_ab); a68_op (A68_EXT, "/:=", m, genie_vector_div_real_ab); m = a68_proc (MODE (REF_ROWROW_REAL), MODE (REF_ROWROW_REAL), MODE (REAL), NO_MOID); a68_op (A68_EXT, "*:=", m, genie_matrix_scale_real_ab); a68_op (A68_EXT, "/:=", m, genie_matrix_div_real_ab); m = a68_proc (MODE (REF_ROW_COMPLEX), MODE (REF_ROW_COMPLEX), MODE (COMPLEX), NO_MOID); a68_op (A68_EXT, "*:=", m, genie_vector_complex_scale_complex_ab); a68_op (A68_EXT, "/:=", m, genie_vector_complex_div_complex_ab); m = a68_proc (MODE (REF_ROWROW_COMPLEX), MODE (REF_ROWROW_COMPLEX), MODE (COMPLEX), NO_MOID); a68_op (A68_EXT, "*:=", m, genie_matrix_complex_scale_complex_ab); a68_op (A68_EXT, "/:=", m, genie_matrix_complex_div_complex_ab); m = a68_proc (MODE (ROW_REAL), MODE (ROW_REAL), MODE (ROWROW_REAL), NO_MOID); a68_op (A68_EXT, "*", m, genie_vector_times_matrix); m = a68_proc (MODE (ROW_COMPLEX), MODE (ROW_COMPLEX), MODE (ROWROW_COMPLEX), NO_MOID); a68_op (A68_EXT, "*", m, genie_vector_complex_times_matrix); /* Matrix times vector or matrix */ m = a68_proc (MODE (ROW_REAL), MODE (ROWROW_REAL), MODE (ROW_REAL), NO_MOID); a68_op (A68_EXT, "*", m, genie_matrix_times_vector); m = a68_proc (MODE (ROWROW_REAL), MODE (ROWROW_REAL), MODE (ROWROW_REAL), NO_MOID); a68_op (A68_EXT, "*", m, genie_matrix_times_matrix); m = a68_proc (MODE (ROW_COMPLEX), MODE (ROWROW_COMPLEX), MODE (ROW_COMPLEX), NO_MOID); a68_op (A68_EXT, "*", m, genie_matrix_complex_times_vector); m = a68_proc (MODE (ROWROW_COMPLEX), MODE (ROWROW_COMPLEX), MODE (ROWROW_COMPLEX), NO_MOID); a68_op (A68_EXT, "*", m, genie_matrix_complex_times_matrix); /* Vector and matrix miscellaneous */ m = a68_proc (MODE (ROW_REAL), MODE (ROW_REAL), NO_MOID); a68_idf (A68_EXT, "vectorecho", m, genie_vector_echo); m = a68_proc (MODE (ROWROW_REAL), MODE (ROWROW_REAL), NO_MOID); a68_idf (A68_EXT, "matrixecho", m, genie_matrix_echo); m = a68_proc (MODE (ROW_COMPLEX), MODE (ROW_COMPLEX), NO_MOID); a68_idf (A68_EXT, "complvectorecho", m, genie_vector_complex_echo); m = a68_proc (MODE (ROWROW_COMPLEX), MODE (ROWROW_COMPLEX), NO_MOID); a68_idf (A68_EXT, "complmatrixecho", m, genie_matrix_complex_echo); /**/ m = a68_proc (MODE (REAL), MODE (ROW_REAL), MODE (ROW_REAL), NO_MOID); a68_op (A68_EXT, "*", m, genie_vector_dot); m = a68_proc (MODE (COMPLEX), MODE (ROW_COMPLEX), MODE (ROW_COMPLEX), NO_MOID); a68_op (A68_EXT, "*", m, genie_vector_complex_dot); m = a68_proc (MODE (REAL), MODE (ROW_REAL), NO_MOID); a68_op (A68_EXT, "NORM", m, genie_vector_norm); m = a68_proc (MODE (REAL), MODE (ROW_COMPLEX), NO_MOID); a68_op (A68_EXT, "NORM", m, genie_vector_complex_norm); m = a68_proc (MODE (ROWROW_REAL), MODE (ROW_REAL), MODE (ROW_REAL), NO_MOID); a68_op (A68_EXT, "DYAD", m, genie_vector_dyad); m = a68_proc (MODE (ROWROW_COMPLEX), MODE (ROW_COMPLEX), MODE (ROW_COMPLEX), NO_MOID); a68_op (A68_EXT, "DYAD", m, genie_vector_complex_dyad); a68_prio ("DYAD", 3); /* LU decomposition */ m = a68_proc (MODE (ROWROW_REAL), MODE (ROWROW_REAL), MODE (REF_ROW_INT), MODE (REF_INT), NO_MOID); a68_idf (A68_EXT, "ludecomp", m, genie_matrix_lu); m = a68_proc (MODE (REAL), MODE (ROWROW_REAL), MODE (INT), NO_MOID); a68_idf (A68_EXT, "ludet", m, genie_matrix_lu_det); m = a68_proc (MODE (ROWROW_REAL), MODE (ROWROW_REAL), MODE (ROW_INT), NO_MOID); a68_idf (A68_EXT, "luinv", m, genie_matrix_lu_inv); m = a68_proc (MODE (ROW_REAL), MODE (ROWROW_REAL), MODE (ROWROW_REAL), MODE (ROW_INT), MODE (ROW_REAL), NO_MOID); a68_idf (A68_EXT, "lusolve", m, genie_matrix_lu_solve); m = a68_proc (MODE (ROWROW_COMPLEX), MODE (ROWROW_COMPLEX), MODE (REF_ROW_INT), MODE (REF_INT), NO_MOID); a68_idf (A68_EXT, "complexludecomp", m, genie_matrix_complex_lu); m = a68_proc (MODE (COMPLEX), MODE (ROWROW_COMPLEX), MODE (INT), NO_MOID); a68_idf (A68_EXT, "complexludet", m, genie_matrix_complex_lu_det); m = a68_proc (MODE (ROWROW_COMPLEX), MODE (ROWROW_COMPLEX), MODE (ROW_INT), NO_MOID); a68_idf (A68_EXT, "complexluinv", m, genie_matrix_complex_lu_inv); m = a68_proc (MODE (ROW_COMPLEX), MODE (ROWROW_COMPLEX), MODE (ROWROW_COMPLEX), MODE (ROW_INT), MODE (ROW_COMPLEX), NO_MOID); a68_idf (A68_EXT, "complexlusolve", m, genie_matrix_complex_lu_solve); /* SVD decomposition */ m = a68_proc (MODE (ROWROW_REAL), MODE (ROWROW_REAL), MODE (REF_ROWROW_REAL), MODE (REF_ROW_REAL), NO_MOID); a68_idf (A68_EXT, "svdecomp", m, genie_matrix_svd); a68_idf (A68_EXT, "svddecomp", m, genie_matrix_svd); m = a68_proc (MODE (ROW_REAL), MODE (ROWROW_REAL), MODE (ROWROW_REAL), MODE (ROW_REAL), MODE (ROW_REAL), NO_MOID); a68_idf (A68_EXT, "svdsolve", m, genie_matrix_svd_solve); /* QR decomposition */ m = a68_proc (MODE (ROWROW_REAL), MODE (ROWROW_REAL), MODE (REF_ROW_REAL), NO_MOID); a68_idf (A68_EXT, "qrdecomp", m, genie_matrix_qr); m = a68_proc (MODE (ROW_REAL), MODE (ROWROW_REAL), MODE (ROW_REAL), MODE (ROW_REAL), NO_MOID); a68_idf (A68_EXT, "qrsolve", m, genie_matrix_qr_solve); a68_idf (A68_EXT, "qrlssolve", m, genie_matrix_qr_ls_solve); /* Cholesky decomposition */ m = a68_proc (MODE (ROWROW_REAL), MODE (ROWROW_REAL), NO_MOID); a68_idf (A68_EXT, "choleskydecomp", m, genie_matrix_ch); m = a68_proc (MODE (ROW_REAL), MODE (ROWROW_REAL), MODE (ROW_REAL), NO_MOID); a68_idf (A68_EXT, "choleskysolve", m, genie_matrix_ch_solve); /* FFT */ m = a68_proc (MODE (ROW_INT), MODE (INT), NO_MOID); a68_idf (A68_EXT, "primefactors", m, genie_prime_factors); m = a68_proc (MODE (ROW_COMPLEX), MODE (ROW_COMPLEX), NO_MOID); a68_idf (A68_EXT, "fftcomplexforward", m, genie_fft_complex_forward); a68_idf (A68_EXT, "fftcomplexbackward", m, genie_fft_complex_backward); a68_idf (A68_EXT, "fftcomplexinverse", m, genie_fft_complex_inverse); m = a68_proc (MODE (ROW_COMPLEX), MODE (ROW_REAL), NO_MOID); a68_idf (A68_EXT, "fftforward", m, genie_fft_forward); m = a68_proc (MODE (ROW_REAL), MODE (ROW_COMPLEX), NO_MOID); a68_idf (A68_EXT, "fftbackward", m, genie_fft_backward); a68_idf (A68_EXT, "fftinverse", m, genie_fft_inverse); #endif /* UNIX things */ m = proc_int; a68_idf (A68_EXT, "rows", m, genie_rows); a68_idf (A68_EXT, "columns", m, genie_columns); a68_idf (A68_EXT, "argc", m, genie_argc); a68_idf (A68_EXT, "errno", m, genie_errno); a68_idf (A68_EXT, "fork", m, genie_fork); m = a68_proc (MODE (STRING), NO_MOID); a68_idf (A68_EXT, "getpwd", m, genie_pwd); m = a68_proc (MODE (INT), MODE (STRING), NO_MOID); a68_idf (A68_EXT, "setpwd", m, genie_cd); m = a68_proc (MODE (BOOL), MODE (STRING), NO_MOID); a68_idf (A68_EXT, "fileisdirectory", m, genie_file_is_directory); a68_idf (A68_EXT, "fileisregular", m, genie_file_is_block_device); a68_idf (A68_EXT, "fileisregular", m, genie_file_is_char_device); a68_idf (A68_EXT, "fileisregular", m, genie_file_is_regular); #if defined __S_IFIFO a68_idf (A68_EXT, "fileisfifo", m, genie_file_is_fifo); #endif #if defined __S_IFLNK a68_idf (A68_EXT, "fileislink", m, genie_file_is_link); #endif m = a68_proc (MODE (BITS), MODE (STRING), NO_MOID); a68_idf (A68_EXT, "filemode", m, genie_file_mode); m = a68_proc (MODE (STRING), MODE (INT), NO_MOID); a68_idf (A68_EXT, "argv", m, genie_argv); m = proc_void; a68_idf (A68_EXT, "reseterrno", m, genie_reset_errno); m = a68_proc (MODE (STRING), MODE (INT), NO_MOID); a68_idf (A68_EXT, "strerror", m, genie_strerror); m = a68_proc (MODE (INT), MODE (STRING), MODE (ROW_STRING), MODE (ROW_STRING), NO_MOID); a68_idf (A68_EXT, "execve", m, genie_execve); m = a68_proc (MODE (PIPE), NO_MOID); a68_idf (A68_EXT, "createpipe", m, genie_create_pipe); m = a68_proc (MODE (INT), MODE (STRING), MODE (ROW_STRING), MODE (ROW_STRING), NO_MOID); a68_idf (A68_EXT, "execvechild", m, genie_execve_child); m = a68_proc (MODE (PIPE), MODE (STRING), MODE (ROW_STRING), MODE (ROW_STRING), NO_MOID); a68_idf (A68_EXT, "execvechildpipe", m, genie_execve_child_pipe); m = a68_proc (MODE (INT), MODE (STRING), MODE (ROW_STRING), MODE (ROW_STRING), MODE (REF_STRING), NO_MOID); a68_idf (A68_EXT, "execveoutput", m, genie_execve_output); m = a68_proc (MODE (STRING), MODE (STRING), NO_MOID); a68_idf (A68_EXT, "getenv", m, genie_getenv); m = a68_proc (MODE (VOID), MODE (INT), NO_MOID); a68_idf (A68_EXT, "waitpid", m, genie_waitpid); m = a68_proc (MODE (ROW_INT), NO_MOID); a68_idf (A68_EXT, "utctime", m, genie_utctime); a68_idf (A68_EXT, "localtime", m, genie_localtime); #if defined HAVE_DIRENT_H m = a68_proc (MODE (ROW_STRING), MODE (STRING), NO_MOID); a68_idf (A68_EXT, "getdirectory", m, genie_directory); #endif #if defined HAVE_HTTP m = a68_proc (MODE (INT), MODE (REF_STRING), MODE (STRING), MODE (STRING), MODE (INT), NO_MOID); a68_idf (A68_EXT, "httpcontent", m, genie_http_content); a68_idf (A68_EXT, "tcprequest", m, genie_tcp_request); #endif #if defined HAVE_REGEX_H m = a68_proc (MODE (INT), MODE (STRING), MODE (STRING), MODE (REF_INT), MODE (REF_INT), NO_MOID); a68_idf (A68_EXT, "grepinstring", m, genie_grep_in_string); a68_idf (A68_EXT, "grepinsubstring", m, genie_grep_in_substring); m = a68_proc (MODE (INT), MODE (STRING), MODE (STRING), MODE (REF_STRING), NO_MOID); a68_idf (A68_EXT, "subinstring", m, genie_sub_in_string); #endif #if defined HAVE_CURSES m = proc_void; a68_idf (A68_EXT, "cursesstart", m, genie_curses_start); a68_idf (A68_EXT, "cursesend", m, genie_curses_end); a68_idf (A68_EXT, "cursesclear", m, genie_curses_clear); a68_idf (A68_EXT, "cursesrefresh", m, genie_curses_refresh); a68_idf (A68_EXT, "cursesgreen", m, genie_curses_green); a68_idf (A68_EXT, "cursescyan", m, genie_curses_cyan); a68_idf (A68_EXT, "cursesred", m, genie_curses_red); a68_idf (A68_EXT, "cursesyellow", m, genie_curses_yellow); a68_idf (A68_EXT, "cursesmagenta", m, genie_curses_magenta); a68_idf (A68_EXT, "cursesblue", m, genie_curses_blue); a68_idf (A68_EXT, "curseswhite", m, genie_curses_white); a68_idf (A68_EXT, "cursesgreeninverse", m, genie_curses_green_inverse); a68_idf (A68_EXT, "cursescyaninverse", m, genie_curses_cyan_inverse); a68_idf (A68_EXT, "cursesredinverse", m, genie_curses_red_inverse); a68_idf (A68_EXT, "cursesyellowinverse", m, genie_curses_yellow_inverse); a68_idf (A68_EXT, "cursesmagentainverse", m, genie_curses_magenta_inverse); a68_idf (A68_EXT, "cursesblueinverse", m, genie_curses_blue_inverse); a68_idf (A68_EXT, "curseswhiteinverse", m, genie_curses_white_inverse); m = proc_char; a68_idf (A68_EXT, "cursesgetchar", m, genie_curses_getchar); m = a68_proc (MODE (VOID), MODE (CHAR), NO_MOID); a68_idf (A68_EXT, "cursesputchar", m, genie_curses_putchar); m = a68_proc (MODE (VOID), MODE (INT), MODE (INT), NO_MOID); a68_idf (A68_EXT, "cursesmove", m, genie_curses_move); m = proc_int; a68_idf (A68_EXT, "curseslines", m, genie_curses_lines); a68_idf (A68_EXT, "cursescolumns", m, genie_curses_columns); m = a68_proc (MODE (BOOL), MODE (CHAR), NO_MOID); a68_idf (A68_EXT, "cursesdelchar", m, genie_curses_del_char); #endif #if HAVE_POSTGRESQL m = a68_proc (MODE (INT), MODE (REF_FILE), MODE (STRING), MODE (REF_STRING), NO_MOID); a68_idf (A68_EXT, "pqconnectdb", m, genie_pq_connectdb); m = a68_proc (MODE (INT), MODE (REF_FILE), NO_MOID); a68_idf (A68_EXT, "pqfinish", m, genie_pq_finish); a68_idf (A68_EXT, "pqreset", m, genie_pq_reset); m = a68_proc (MODE (INT), MODE (REF_FILE), MODE (STRING), NO_MOID); a68_idf (A68_EXT, "pqparameterstatus", m, genie_pq_parameterstatus); a68_idf (A68_EXT, "pqexec", m, genie_pq_exec); a68_idf (A68_EXT, "pqfnumber", m, genie_pq_fnumber); m = a68_proc (MODE (INT), MODE (REF_FILE), NO_MOID); a68_idf (A68_EXT, "pqntuples", m, genie_pq_ntuples); a68_idf (A68_EXT, "pqnfields", m, genie_pq_nfields); a68_idf (A68_EXT, "pqcmdstatus", m, genie_pq_cmdstatus); a68_idf (A68_EXT, "pqcmdtuples", m, genie_pq_cmdtuples); a68_idf (A68_EXT, "pqerrormessage", m, genie_pq_errormessage); a68_idf (A68_EXT, "pqresulterrormessage", m, genie_pq_resulterrormessage); a68_idf (A68_EXT, "pqdb", m, genie_pq_db); a68_idf (A68_EXT, "pquser", m, genie_pq_user); a68_idf (A68_EXT, "pqpass", m, genie_pq_pass); a68_idf (A68_EXT, "pqhost", m, genie_pq_host); a68_idf (A68_EXT, "pqport", m, genie_pq_port); a68_idf (A68_EXT, "pqtty", m, genie_pq_tty); a68_idf (A68_EXT, "pqoptions", m, genie_pq_options); a68_idf (A68_EXT, "pqprotocolversion", m, genie_pq_protocolversion); a68_idf (A68_EXT, "pqserverversion", m, genie_pq_serverversion); a68_idf (A68_EXT, "pqsocket", m, genie_pq_socket); a68_idf (A68_EXT, "pqbackendpid", m, genie_pq_backendpid); m = a68_proc (MODE (INT), MODE (REF_FILE), MODE (INT), NO_MOID); a68_idf (A68_EXT, "pqfname", m, genie_pq_fname); a68_idf (A68_EXT, "pqfformat", m, genie_pq_fformat); m = a68_proc (MODE (INT), MODE (REF_FILE), MODE (INT), MODE (INT), NO_MOID); a68_idf (A68_EXT, "pqgetvalue", m, genie_pq_getvalue); a68_idf (A68_EXT, "pqgetisnull", m, genie_pq_getisnull); #endif } /*! \brief build the standard environ symbol table **/ void make_standard_environ (void) { stand_moids (); proc_int = a68_proc (MODE (INT), NO_MOID); proc_real = a68_proc (MODE (REAL), NO_MOID); proc_real_real = MODE (PROC_REAL_REAL); proc_real_real_real = a68_proc (MODE (REAL), MODE (REAL), MODE (REAL), NO_MOID); proc_real_real_real_real = a68_proc (MODE (REAL), MODE (REAL), MODE (REAL), MODE (REAL), NO_MOID); proc_complex_complex = a68_proc (MODE (COMPLEX), MODE (COMPLEX), NO_MOID); proc_bool = a68_proc (MODE (BOOL), NO_MOID); proc_char = a68_proc (MODE (CHAR), NO_MOID); proc_void = a68_proc (MODE (VOID), NO_MOID); stand_prelude (); stand_transput (); stand_extensions (); } /*! Standard prelude implementation, except transput. */ /* This file contains Algol68G's standard environ. Transput routines are not here. Some of the LONG operations are generic for LONG and LONG LONG. This file contains calculus related routines from the C library and GNU scientific library. When GNU scientific library is not installed then the routines in this file will give a runtime error when called. You can also choose to not have them defined in "prelude.c". */ double inverf (double); double inverfc (double); double cputime_0; #define A68_MONAD(n, MODE, OP)\ void n (NODE_T * p) {\ MODE *i;\ POP_OPERAND_ADDRESS (p, i, MODE);\ VALUE (i) = OP (VALUE (i));\ } /*! \brief PROC (PROC VOID) VOID on gc event \param p position in tree **/ void genie_on_gc_event (NODE_T * p) { POP_PROCEDURE (p, &on_gc_event); } /*! \brief generic procedure for OP AND BECOMES (+:=, -:=, ...) \param p position in tree \param ref mode of destination \param f pointer to function that performs operation **/ void genie_f_and_becomes (NODE_T * p, MOID_T * ref, GPROC * f) { MOID_T *mode = SUB (ref); int size = MOID_SIZE (mode); BYTE_T *src = STACK_OFFSET (-size), *addr; A68_REF *dst = (A68_REF *) STACK_OFFSET (-size - A68_REF_SIZE); CHECK_REF (p, *dst, ref); addr = ADDRESS (dst); PUSH (p, addr, size); genie_check_initialisation (p, STACK_OFFSET (-size), mode); PUSH (p, src, size); (*f) (p); POP (p, addr, size); DECREMENT_STACK_POINTER (p, size); } /* Environment enquiries */ A68_ENV_INT (genie_int_lengths, 3) A68_ENV_INT (genie_int_shorths, 1) A68_ENV_INT (genie_real_lengths, 3) A68_ENV_INT (genie_real_shorths, 1) A68_ENV_INT (genie_complex_lengths, 3) A68_ENV_INT (genie_complex_shorths, 1) A68_ENV_INT (genie_bits_lengths, 3) A68_ENV_INT (genie_bits_shorths, 1) A68_ENV_INT (genie_bytes_lengths, 2) A68_ENV_INT (genie_bytes_shorths, 1) A68_ENV_INT (genie_int_width, INT_WIDTH) A68_ENV_INT (genie_long_int_width, LONG_INT_WIDTH) A68_ENV_INT (genie_longlong_int_width, LONGLONG_INT_WIDTH) A68_ENV_INT (genie_real_width, REAL_WIDTH) A68_ENV_INT (genie_long_real_width, LONG_REAL_WIDTH) A68_ENV_INT (genie_longlong_real_width, LONGLONG_REAL_WIDTH) A68_ENV_INT (genie_exp_width, EXP_WIDTH) A68_ENV_INT (genie_long_exp_width, LONG_EXP_WIDTH) A68_ENV_INT (genie_longlong_exp_width, LONGLONG_EXP_WIDTH) A68_ENV_INT (genie_bits_width, BITS_WIDTH) A68_ENV_INT (genie_long_bits_width, get_mp_bits_width (MODE (LONG_BITS))) A68_ENV_INT (genie_longlong_bits_width, get_mp_bits_width (MODE (LONGLONG_BITS))) A68_ENV_INT (genie_bytes_width, BYTES_WIDTH) A68_ENV_INT (genie_long_bytes_width, LONG_BYTES_WIDTH) A68_ENV_INT (genie_max_abs_char, UCHAR_MAX) A68_ENV_INT (genie_max_int, A68_MAX_INT) A68_ENV_REAL (genie_max_real, DBL_MAX) A68_ENV_REAL (genie_min_real, DBL_MIN) A68_ENV_REAL (genie_small_real, DBL_EPSILON) A68_ENV_REAL (genie_pi, A68_PI) A68_ENV_REAL (genie_cputime, seconds () - cputime_0) A68_ENV_INT (genie_stack_pointer, stack_pointer) A68_ENV_INT (genie_system_stack_size, stack_size) /*! \brief INT system stack pointer \param p position in tree **/ void genie_system_stack_pointer (NODE_T * p) { BYTE_T stack_offset; PUSH_PRIMITIVE (p, (int) (system_stack_offset - &stack_offset), A68_INT); } /*! \brief LONG INT max long int \param p position in tree **/ void genie_long_max_int (NODE_T * p) { int digits = get_mp_digits (MODE (LONG_INT)); MP_T *z; int k, j = 1 + digits; STACK_MP (z, p, digits); MP_STATUS (z) = (MP_T) INIT_MASK; MP_EXPONENT (z) = (MP_T) (digits - 1); for (k = 2; k <= j; k++) { z[k] = (MP_T) (MP_RADIX - 1); } } /*! \brief LONG LONG INT max long long int \param p position in tree **/ void genie_longlong_max_int (NODE_T * p) { int digits = get_mp_digits (MODE (LONGLONG_INT)); MP_T *z; int k, j = 1 + digits; STACK_MP (z, p, digits); MP_STATUS (z) = (MP_T) INIT_MASK; MP_EXPONENT (z) = (MP_T) (digits - 1); for (k = 2; k <= j; k++) { z[k] = (MP_T) (MP_RADIX - 1); } } /*! \brief LONG REAL max long real \param p position in tree **/ void genie_long_max_real (NODE_T * p) { int j, digits = get_mp_digits (MODE (LONG_REAL)); MP_T *z; STACK_MP (z, p, digits); MP_STATUS (z) = (MP_T) INIT_MASK; MP_EXPONENT (z) = (MP_T) (MAX_MP_EXPONENT - 1); for (j = 2; j <= 1 + digits; j++) { z[j] = (MP_T) (MP_RADIX - 1); } } /*! \brief LONG LONG REAL max long long real \param p position in tree **/ void genie_longlong_max_real (NODE_T * p) { int j, digits = get_mp_digits (MODE (LONGLONG_REAL)); MP_T *z; STACK_MP (z, p, digits); MP_STATUS (z) = (MP_T) INIT_MASK; MP_EXPONENT (z) = (MP_T) (MAX_MP_EXPONENT - 1); for (j = 2; j <= 1 + digits; j++) { z[j] = (MP_T) (MP_RADIX - 1); } } /*! \brief LONG REAL min long real \param p position in tree **/ void genie_long_min_real (NODE_T * p) { int digits = get_mp_digits (MODE (LONG_REAL)); MP_T *z; STACK_MP (z, p, digits); SET_MP_ZERO (z, digits); MP_STATUS (z) = (MP_T) INIT_MASK; MP_EXPONENT (z) = (MP_T) -(MAX_MP_EXPONENT); MP_DIGIT (z, 1) = (MP_T) 1; } /*! \brief LONG LONG REAL min long long real \param p position in tree **/ void genie_longlong_min_real (NODE_T * p) { int digits = get_mp_digits (MODE (LONGLONG_REAL)); MP_T *z; STACK_MP (z, p, digits); SET_MP_ZERO (z, digits); MP_STATUS (z) = (MP_T) INIT_MASK; MP_EXPONENT (z) = (MP_T) -(MAX_MP_EXPONENT); MP_DIGIT (z, 1) = (MP_T) 1; } /*! \brief LONG REAL small long real \param p position in tree **/ void genie_long_small_real (NODE_T * p) { int j, digits = get_mp_digits (MODE (LONG_REAL)); MP_T *z; STACK_MP (z, p, digits); MP_STATUS (z) = (MP_T) INIT_MASK; MP_EXPONENT (z) = (MP_T) -(digits - 1); MP_DIGIT (z, 1) = (MP_T) 1; for (j = 3; j <= 1 + digits; j++) { z[j] = (MP_T) 0; } } /*! \brief LONG LONG REAL small long long real \param p position in tree **/ void genie_longlong_small_real (NODE_T * p) { int j, digits = get_mp_digits (MODE (LONGLONG_REAL)); MP_T *z; STACK_MP (z, p, digits); MP_STATUS (z) = (MP_T) INIT_MASK; MP_EXPONENT (z) = (MP_T) -(digits - 1); MP_DIGIT (z, 1) = (MP_T) 1; for (j = 3; j <= 1 + digits; j++) { z[j] = (MP_T) 0; } } /*! \brief BITS max bits \param p position in tree **/ void genie_max_bits (NODE_T * p) { PUSH_PRIMITIVE (p, A68_MAX_BITS, A68_BITS); } /*! \brief LONG BITS long max bits \param p position in tree **/ void genie_long_max_bits (NODE_T * p) { int digits = get_mp_digits (MODE (LONG_BITS)); int width = get_mp_bits_width (MODE (LONG_BITS)); ADDR_T pop_sp; MP_T *z, *one; STACK_MP (z, p, digits); pop_sp = stack_pointer; STACK_MP (one, p, digits); (void) set_mp_short (z, (MP_T) 2, 0, digits); (void) set_mp_short (one, (MP_T) 1, 0, digits); (void) pow_mp_int (p, z, z, width, digits); (void) sub_mp (p, z, z, one, digits); stack_pointer = pop_sp; } /*! \brief LONG LONG BITS long long max bits \param p position in tree **/ void genie_longlong_max_bits (NODE_T * p) { int digits = get_mp_digits (MODE (LONGLONG_BITS)); int width = get_mp_bits_width (MODE (LONGLONG_BITS)); ADDR_T pop_sp; MP_T *z, *one; STACK_MP (z, p, digits); pop_sp = stack_pointer; STACK_MP (one, p, digits); (void) set_mp_short (z, (MP_T) 2, 0, digits); (void) set_mp_short (one, (MP_T) 1, 0, digits); (void) pow_mp_int (p, z, z, width, digits); (void) sub_mp (p, z, z, one, digits); stack_pointer = pop_sp; } /*! \brief LONG REAL long pi \param p position in tree **/ void genie_pi_long_mp (NODE_T * p) { int digits = get_mp_digits (MOID (p)); MP_T *z; STACK_MP (z, p, digits); (void) mp_pi (p, z, MP_PI, digits); MP_STATUS (z) = (MP_T) INIT_MASK; } /* BOOL operations */ /* OP NOT = (BOOL) BOOL */ A68_MONAD (genie_not_bool, A68_BOOL, (BOOL_T) !) /*! \brief OP ABS = (BOOL) INT \param p position in tree **/ void genie_abs_bool (NODE_T * p) { A68_BOOL j; POP_OBJECT (p, &j, A68_BOOL); PUSH_PRIMITIVE (p, (VALUE (&j) ? 1 : 0), A68_INT); } #define A68_BOOL_DYAD(n, OP)\ void n (NODE_T * p) {\ A68_BOOL *i, *j;\ POP_OPERAND_ADDRESSES (p, i, j, A68_BOOL);\ VALUE (i) = (BOOL_T) (VALUE (i) OP VALUE (j));\ } A68_BOOL_DYAD (genie_and_bool, &) A68_BOOL_DYAD (genie_or_bool, |) A68_BOOL_DYAD (genie_xor_bool, ^) A68_BOOL_DYAD (genie_eq_bool, ==) A68_BOOL_DYAD (genie_ne_bool, !=) /* INT operations */ /* OP - = (INT) INT */ A68_MONAD (genie_minus_int, A68_INT, -) /*! \brief OP ABS = (INT) INT \param p position in tree **/ void genie_abs_int (NODE_T * p) { A68_INT *j; POP_OPERAND_ADDRESS (p, j, A68_INT); VALUE (j) = ABS (VALUE (j)); } /*! \brief OP SIGN = (INT) INT \param p position in tree **/ void genie_sign_int (NODE_T * p) { A68_INT *j; POP_OPERAND_ADDRESS (p, j, A68_INT); VALUE (j) = SIGN (VALUE (j)); } /*! \brief OP ODD = (INT) INT \param p position in tree **/ void genie_odd_int (NODE_T * p) { A68_INT j; POP_OBJECT (p, &j, A68_INT); PUSH_PRIMITIVE (p, (BOOL_T) ((VALUE (&j) >= 0 ? VALUE (&j) : -VALUE (&j)) % 2 == 1), A68_BOOL); } /*! \brief OP + = (INT, INT) INT \param p position in tree **/ void genie_add_int (NODE_T * p) { A68_INT *i, *j; POP_OPERAND_ADDRESSES (p, i, j, A68_INT); CHECK_INT_ADDITION (p, VALUE (i), VALUE (j)); VALUE (i) += VALUE (j); } /*! \brief OP - = (INT, INT) INT \param p position in tree **/ void genie_sub_int (NODE_T * p) { A68_INT *i, *j; POP_OPERAND_ADDRESSES (p, i, j, A68_INT); CHECK_INT_SUBTRACTION (p, VALUE (i), VALUE (j)); VALUE (i) -= VALUE (j); } /*! \brief OP * = (INT, INT) INT \param p position in tree **/ void genie_mul_int (NODE_T * p) { A68_INT *i, *j; POP_OPERAND_ADDRESSES (p, i, j, A68_INT); CHECK_INT_MULTIPLICATION (p, VALUE (i), VALUE (j)); VALUE (i) *= VALUE (j); } /*! \brief OP OVER = (INT, INT) INT \param p position in tree **/ void genie_over_int (NODE_T * p) { A68_INT *i, *j; POP_OPERAND_ADDRESSES (p, i, j, A68_INT); PRELUDE_ERROR (VALUE (j) == 0, p, ERROR_DIVISION_BY_ZERO, MODE (INT)); VALUE (i) /= VALUE (j); } /*! \brief OP MOD = (INT, INT) INT \param p position in tree **/ void genie_mod_int (NODE_T * p) { A68_INT *i, *j; int k; POP_OPERAND_ADDRESSES (p, i, j, A68_INT); PRELUDE_ERROR (VALUE (j) == 0, p, ERROR_DIVISION_BY_ZERO, MODE (INT)); k = VALUE (i) % VALUE (j); if (k < 0) { k += (VALUE (j) >= 0 ? VALUE (j) : -VALUE (j)); } VALUE (i) = k; } /*! \brief OP / = (INT, INT) REAL \param p position in tree **/ void genie_div_int (NODE_T * p) { A68_INT i, j; POP_OBJECT (p, &j, A68_INT); POP_OBJECT (p, &i, A68_INT); PRELUDE_ERROR (VALUE (&j) == 0, p, ERROR_DIVISION_BY_ZERO, MODE (INT)); PUSH_PRIMITIVE (p, (double) (VALUE (&i)) / (double) (VALUE (&j)), A68_REAL); } /*! \brief OP ** = (INT, INT) INT \param p position in tree **/ void genie_pow_int (NODE_T * p) { A68_INT i, j; int expo, mult, prod; POP_OBJECT (p, &j, A68_INT); PRELUDE_ERROR (VALUE (&j) < 0, p, ERROR_EXPONENT_INVALID, MODE (INT)); POP_OBJECT (p, &i, A68_INT); prod = 1; mult = VALUE (&i); expo = 1; while ((unsigned) expo <= (unsigned) (VALUE (&j))) { if (VALUE (&j) & expo) { CHECK_INT_MULTIPLICATION (p, prod, mult); prod *= mult; } expo <<= 1; if (expo <= VALUE (&j)) { CHECK_INT_MULTIPLICATION (p, mult, mult); mult *= mult; } } PUSH_PRIMITIVE (p, prod, A68_INT); } /* OP (INT, INT) BOOL */ #define A68_CMP_INT(n, OP)\ void n (NODE_T * p) {\ A68_INT i, j;\ POP_OBJECT (p, &j, A68_INT);\ POP_OBJECT (p, &i, A68_INT);\ PUSH_PRIMITIVE (p, (BOOL_T) (VALUE (&i) OP VALUE (&j)), A68_BOOL);\ } A68_CMP_INT (genie_eq_int, ==) A68_CMP_INT (genie_ne_int, !=) A68_CMP_INT (genie_lt_int, <) A68_CMP_INT (genie_gt_int, >) A68_CMP_INT (genie_le_int, <=) A68_CMP_INT (genie_ge_int, >=) /*! \brief OP +:= = (REF INT, INT) REF INT \param p position in tree **/ void genie_plusab_int (NODE_T * p) { genie_f_and_becomes (p, MODE (REF_INT), genie_add_int); } /*! \brief OP -:= = (REF INT, INT) REF INT \param p position in tree **/ void genie_minusab_int (NODE_T * p) { genie_f_and_becomes (p, MODE (REF_INT), genie_sub_int); } /*! \brief OP *:= = (REF INT, INT) REF INT \param p position in tree **/ void genie_timesab_int (NODE_T * p) { genie_f_and_becomes (p, MODE (REF_INT), genie_mul_int); } /*! \brief OP %:= = (REF INT, INT) REF INT \param p position in tree **/ void genie_overab_int (NODE_T * p) { genie_f_and_becomes (p, MODE (REF_INT), genie_over_int); } /*! \brief OP %*:= = (REF INT, INT) REF INT \param p position in tree **/ void genie_modab_int (NODE_T * p) { genie_f_and_becomes (p, MODE (REF_INT), genie_mod_int); } /*! \brief OP LENG = (INT) LONG INT \param p position in tree **/ void genie_lengthen_int_to_long_mp (NODE_T * p) { int digits = get_mp_digits (MODE (LONG_INT)); MP_T *z; A68_INT k; POP_OBJECT (p, &k, A68_INT); STACK_MP (z, p, digits); (void) int_to_mp (p, z, VALUE (&k), digits); MP_STATUS (z) = (MP_T) INIT_MASK; } /*! \brief OP LENG = (BITS) LONG BITS \param p position in tree **/ void genie_lengthen_unsigned_to_long_mp (NODE_T * p) { int digits = get_mp_digits (MODE (LONG_INT)); MP_T *z; A68_BITS k; POP_OBJECT (p, &k, A68_BITS); STACK_MP (z, p, digits); (void) unsigned_to_mp (p, z, (unsigned) VALUE (&k), digits); MP_STATUS (z) = (MP_T) INIT_MASK; } /*! \brief OP SHORTEN = (LONG INT) INT \param p position in tree **/ void genie_shorten_long_mp_to_int (NODE_T * p) { MOID_T *mode = LHS_MODE (p); int digits = get_mp_digits (mode), size = get_mp_size (mode); MP_T *z; DECREMENT_STACK_POINTER (p, size); z = (MP_T *) STACK_TOP; MP_STATUS (z) = (MP_T) INIT_MASK; PUSH_PRIMITIVE (p, mp_to_int (p, z, digits), A68_INT); } /*! \brief OP ODD = (LONG INT) BOOL \param p position in tree **/ void genie_odd_long_mp (NODE_T * p) { MOID_T *mode = LHS_MODE (p); int digits = get_mp_digits (mode), size = get_mp_size (mode); MP_T *z = (MP_T *) STACK_OFFSET (-size); DECREMENT_STACK_POINTER (p, size); if (MP_EXPONENT (z) <= (MP_T) (digits - 1)) { PUSH_PRIMITIVE (p, (BOOL_T) ((int) (z[(int) (2 + MP_EXPONENT (z))]) % 2 != 0), A68_BOOL); } else { PUSH_PRIMITIVE (p, A68_FALSE, A68_BOOL); } } /*! \brief test whether z is a valid LONG INT \param p position in tree \param z mp number \param m mode associated with z **/ void test_long_int_range (NODE_T * p, MP_T * z, MOID_T * m) { PRELUDE_ERROR (!check_mp_int (z, m), p, ERROR_OUT_OF_BOUNDS, m); } /*! \brief OP + = (LONG INT, LONG INT) LONG INT \param p position in tree **/ void genie_add_long_int (NODE_T * p) { MOID_T *m = RHS_MODE (p); int digits = get_mp_digits (m), size = get_mp_size (m); MP_T *x = (MP_T *) STACK_OFFSET (-2 * size); MP_T *y = (MP_T *) STACK_OFFSET (-size); (void) add_mp (p, x, x, y, digits); test_long_int_range (p, x, m); MP_STATUS (x) = (MP_T) INIT_MASK; DECREMENT_STACK_POINTER (p, size); } /*! \brief OP - = (LONG INT, LONG INT) LONG INT \param p position in tree **/ void genie_sub_long_int (NODE_T * p) { MOID_T *m = RHS_MODE (p); int digits = get_mp_digits (m), size = get_mp_size (m); MP_T *x = (MP_T *) STACK_OFFSET (-2 * size); MP_T *y = (MP_T *) STACK_OFFSET (-size); (void) sub_mp (p, x, x, y, digits); test_long_int_range (p, x, m); MP_STATUS (x) = (MP_T) INIT_MASK; DECREMENT_STACK_POINTER (p, size); } /*! \brief OP * = (LONG INT, LONG INT) LONG INT \param p position in tree **/ void genie_mul_long_int (NODE_T * p) { MOID_T *m = RHS_MODE (p); int digits = get_mp_digits (m), size = get_mp_size (m); MP_T *x = (MP_T *) STACK_OFFSET (-2 * size); MP_T *y = (MP_T *) STACK_OFFSET (-size); (void) mul_mp (p, x, x, y, digits); test_long_int_range (p, x, m); MP_STATUS (x) = (MP_T) INIT_MASK; DECREMENT_STACK_POINTER (p, size); } /*! \brief OP ** = (LONG MODE, INT) LONG INT \param p position in tree **/ void genie_pow_long_mp_int_int (NODE_T * p) { MOID_T *m = LHS_MODE (p); int digits = get_mp_digits (m), size = get_mp_size (m); A68_INT k; MP_T *x; POP_OBJECT (p, &k, A68_INT); x = (MP_T *) STACK_OFFSET (-size); (void) pow_mp_int (p, x, x, VALUE (&k), digits); test_long_int_range (p, x, m); MP_STATUS (x) = (MP_T) INIT_MASK; } /*! \brief OP +:= = (REF LONG INT, LONG INT) REF LONG INT \param p position in tree **/ void genie_plusab_long_int (NODE_T * p) { MOID_T *mode = LHS_MODE (p); genie_f_and_becomes (p, mode, genie_add_long_int); } /*! \brief OP -:= = (REF LONG INT, LONG INT) REF LONG INT \param p position in tree **/ void genie_minusab_long_int (NODE_T * p) { MOID_T *mode = LHS_MODE (p); genie_f_and_becomes (p, mode, genie_sub_long_int); } /*! \brief OP *:= = (REF LONG INT, LONG INT) REF LONG INT \param p position in tree **/ void genie_timesab_long_int (NODE_T * p) { MOID_T *mode = LHS_MODE (p); genie_f_and_becomes (p, mode, genie_mul_long_int); } /* REAL operations. REAL math is in gsl.c */ /* OP - = (REAL) REAL */ A68_MONAD (genie_minus_real, A68_REAL, -) /*! \brief OP ABS = (REAL) REAL \param p position in tree **/ void genie_abs_real (NODE_T * p) { A68_REAL *x; POP_OPERAND_ADDRESS (p, x, A68_REAL); VALUE (x) = ABS (VALUE (x)); } /*! \brief OP ROUND = (REAL) INT \param p position in tree **/ void genie_round_real (NODE_T * p) { A68_REAL x; POP_OBJECT (p, &x, A68_REAL); PRELUDE_ERROR (VALUE (&x) < -(double) A68_MAX_INT || VALUE (&x) > (double) A68_MAX_INT, p, ERROR_OUT_OF_BOUNDS, MODE (INT)); PUSH_PRIMITIVE (p, a68g_round (VALUE (&x)), A68_INT); } /*! \brief OP ENTIER = (REAL) INT \param p position in tree **/ void genie_entier_real (NODE_T * p) { A68_REAL x; POP_OBJECT (p, &x, A68_REAL); PRELUDE_ERROR (VALUE (&x) < -(double) A68_MAX_INT || VALUE (&x) > (double)A68_MAX_INT, p, ERROR_OUT_OF_BOUNDS, MODE (INT)); PUSH_PRIMITIVE (p, (int) floor (VALUE (&x)), A68_INT); } /*! \brief OP SIGN = (REAL) INT \param p position in tree **/ void genie_sign_real (NODE_T * p) { A68_REAL x; POP_OBJECT (p, &x, A68_REAL); PUSH_PRIMITIVE (p, SIGN (VALUE (&x)), A68_INT); } /*! \brief OP + = (REAL, REAL) REAL \param p position in tree **/ void genie_add_real (NODE_T * p) { A68_REAL *x, *y; POP_OPERAND_ADDRESSES (p, x, y, A68_REAL); VALUE (x) += VALUE (y); CHECK_REAL_REPRESENTATION (p, VALUE (x)); } /*! \brief OP - = (REAL, REAL) REAL \param p position in tree **/ void genie_sub_real (NODE_T * p) { A68_REAL *x, *y; POP_OPERAND_ADDRESSES (p, x, y, A68_REAL); VALUE (x) -= VALUE (y); CHECK_REAL_REPRESENTATION (p, VALUE (x)); } /*! \brief OP * = (REAL, REAL) REAL \param p position in tree **/ void genie_mul_real (NODE_T * p) { A68_REAL *x, *y; POP_OPERAND_ADDRESSES (p, x, y, A68_REAL); VALUE (x) *= VALUE (y); CHECK_REAL_REPRESENTATION (p, VALUE (x)); } /*! \brief OP / = (REAL, REAL) REAL \param p position in tree **/ void genie_div_real (NODE_T * p) { A68_REAL *x, *y; POP_OPERAND_ADDRESSES (p, x, y, A68_REAL); PRELUDE_ERROR (VALUE (y) == 0.0, p, ERROR_DIVISION_BY_ZERO, MODE (REAL)); VALUE (x) /= VALUE (y); } /*! \brief OP ** = (REAL, INT) REAL \param p position in tree **/ void genie_pow_real_int (NODE_T * p) { A68_INT j; A68_REAL x; int expo; double mult, prod; BOOL_T negative; POP_OBJECT (p, &j, A68_INT); negative = (BOOL_T) (VALUE (&j) < 0); VALUE (&j) = (VALUE (&j) >= 0 ? VALUE (&j) : -VALUE (&j)); POP_OBJECT (p, &x, A68_REAL); prod = 1; mult = VALUE (&x); expo = 1; while ((unsigned) expo <= (unsigned) (VALUE (&j))) { if (VALUE (&j) & expo) { CHECK_REAL_MULTIPLICATION (p, prod, mult); prod *= mult; } expo <<= 1; if (expo <= VALUE (&j)) { CHECK_REAL_MULTIPLICATION (p, mult, mult); mult *= mult; } } CHECK_REAL_REPRESENTATION (p, prod); if (negative) { prod = 1.0 / prod; } PUSH_PRIMITIVE (p, prod, A68_REAL); } /*! \brief OP ** = (REAL, REAL) REAL \param p position in tree **/ void genie_pow_real (NODE_T * p) { A68_REAL x, y; double z = 0; POP_OBJECT (p, &y, A68_REAL); POP_OBJECT (p, &x, A68_REAL); RESET_ERRNO; PRELUDE_ERROR (VALUE (&x) < 0.0, p, ERROR_INVALID_ARGUMENT, MODE (REAL)); if (VALUE (&x) == 0.0) { if (VALUE (&y) < 0) { errno = ERANGE; MATH_RTE (p, errno != 0, MODE (REAL), NO_TEXT); } else { z = (VALUE (&y) == 0.0 ? 1.0 : 0.0); } } else { z = exp (VALUE (&y) * log (VALUE (&x))); MATH_RTE (p, errno != 0, MODE (REAL), NO_TEXT); } PUSH_PRIMITIVE (p, z, A68_REAL); } /* OP (REAL, REAL) BOOL */ #define A68_CMP_REAL(n, OP)\ void n (NODE_T * p) {\ A68_REAL i, j;\ POP_OBJECT (p, &j, A68_REAL);\ POP_OBJECT (p, &i, A68_REAL);\ PUSH_PRIMITIVE (p, (BOOL_T) (VALUE (&i) OP VALUE (&j)), A68_BOOL);\ } A68_CMP_REAL (genie_eq_real, ==) A68_CMP_REAL (genie_ne_real, !=) A68_CMP_REAL (genie_lt_real, <) A68_CMP_REAL (genie_gt_real, >) A68_CMP_REAL (genie_le_real, <=) A68_CMP_REAL (genie_ge_real, >=) /*! \brief OP +:= = (REF REAL, REAL) REF REAL \param p position in tree **/ void genie_plusab_real (NODE_T * p) { genie_f_and_becomes (p, MODE (REF_REAL), genie_add_real); } /*! \brief OP -:= = (REF REAL, REAL) REF REAL \param p position in tree **/ void genie_minusab_real (NODE_T * p) { genie_f_and_becomes (p, MODE (REF_REAL), genie_sub_real); } /*! \brief OP *:= = (REF REAL, REAL) REF REAL \param p position in tree **/ void genie_timesab_real (NODE_T * p) { genie_f_and_becomes (p, MODE (REF_REAL), genie_mul_real); } /*! \brief OP /:= = (REF REAL, REAL) REF REAL \param p position in tree **/ void genie_divab_real (NODE_T * p) { genie_f_and_becomes (p, MODE (REF_REAL), genie_div_real); } /*! \brief OP LENG = (REAL) LONG REAL \param p position in tree **/ void genie_lengthen_real_to_long_mp (NODE_T * p) { int digits = get_mp_digits (MODE (LONG_REAL)); MP_T *z; A68_REAL x; POP_OBJECT (p, &x, A68_REAL); STACK_MP (z, p, digits); (void) real_to_mp (p, z, VALUE (&x), digits); MP_STATUS (z) = (MP_T) INIT_MASK; } /*! \brief OP SHORTEN = (LONG REAL) REAL \param p position in tree **/ void genie_shorten_long_mp_to_real (NODE_T * p) { MOID_T *mode = LHS_MODE (p); int digits = get_mp_digits (mode), size = get_mp_size (mode); MP_T *z; DECREMENT_STACK_POINTER (p, size); z = (MP_T *) STACK_TOP; MP_STATUS (z) = (MP_T) INIT_MASK; PUSH_PRIMITIVE (p, mp_to_real (p, z, digits), A68_REAL); } /*! \brief OP ROUND = (LONG REAL) LONG INT \param p position in tree **/ void genie_round_long_mp (NODE_T * p) { MOID_T *mode = LHS_MODE (p); int digits = get_mp_digits (mode), size = get_mp_size (mode); ADDR_T pop_sp = stack_pointer; MP_T *z = (MP_T *) STACK_OFFSET (-size); (void) round_mp (p, z, z, digits); stack_pointer = pop_sp; } /*! \brief OP ENTIER = (LONG REAL) LONG INT \param p position in tree **/ void genie_entier_long_mp (NODE_T * p) { int digits = get_mp_digits (LHS_MODE (p)), size = get_mp_size (LHS_MODE (p)); ADDR_T pop_sp = stack_pointer; MP_T *z = (MP_T *) STACK_OFFSET (-size); (void) entier_mp (p, z, z, digits); stack_pointer = pop_sp; } /*! \brief PROC long sqrt = (LONG REAL) LONG REAL \param p position in tree **/ void genie_sqrt_long_mp (NODE_T * p) { int digits = get_mp_digits (MOID (p)), size = get_mp_size (MOID (p)); MP_T *x = (MP_T *) STACK_OFFSET (-size); PRELUDE_ERROR (sqrt_mp (p, x, x, digits) == NO_MP, p, ERROR_INVALID_ARGUMENT, MOID (p)); MP_STATUS (x) = (MP_T) INIT_MASK; } /*! \brief PROC long curt = (LONG REAL) LONG REAL \param p position in tree **/ void genie_curt_long_mp (NODE_T * p) { int digits = get_mp_digits (MOID (p)), size = get_mp_size (MOID (p)); MP_T *x = (MP_T *) STACK_OFFSET (-size); PRELUDE_ERROR (curt_mp (p, x, x, digits) == NO_MP, p, ERROR_INVALID_ARGUMENT, MOID (p)); MP_STATUS (x) = (MP_T) INIT_MASK; } /*! \brief PROC long exp = (LONG REAL) LONG REAL \param p position in tree **/ void genie_exp_long_mp (NODE_T * p) { int digits = get_mp_digits (MOID (p)), size = get_mp_size (MOID (p)); ADDR_T pop_sp = stack_pointer; MP_T *x = (MP_T *) STACK_OFFSET (-size); (void) exp_mp (p, x, x, digits); MP_STATUS (x) = (MP_T) INIT_MASK; stack_pointer = pop_sp; } /*! \brief PROC long ln = (LONG REAL) LONG REAL \param p position in tree **/ void genie_ln_long_mp (NODE_T * p) { int digits = get_mp_digits (MOID (p)), size = get_mp_size (MOID (p)); ADDR_T pop_sp = stack_pointer; MP_T *x = (MP_T *) STACK_OFFSET (-size); PRELUDE_ERROR (ln_mp (p, x, x, digits) == NO_MP, p, ERROR_INVALID_ARGUMENT, MOID (p)); MP_STATUS (x) = (MP_T) INIT_MASK; stack_pointer = pop_sp; } /*! \brief PROC long log = (LONG REAL) LONG REAL \param p position in tree **/ void genie_log_long_mp (NODE_T * p) { int digits = get_mp_digits (MOID (p)), size = get_mp_size (MOID (p)); ADDR_T pop_sp = stack_pointer; MP_T *x = (MP_T *) STACK_OFFSET (-size); PRELUDE_ERROR (log_mp (p, x, x, digits) == NO_MP, p, ERROR_INVALID_ARGUMENT, MOID (p)); MP_STATUS (x) = (MP_T) INIT_MASK; stack_pointer = pop_sp; } /*! \brief PROC long sinh = (LONG REAL) LONG REAL \param p position in tree **/ void genie_sinh_long_mp (NODE_T * p) { int digits = get_mp_digits (MOID (p)), size = get_mp_size (MOID (p)); MP_T *x = (MP_T *) STACK_OFFSET (-size); (void) sinh_mp (p, x, x, digits); MP_STATUS (x) = (MP_T) INIT_MASK; } /*! \brief PROC long cosh = (LONG REAL) LONG REAL \param p position in tree **/ void genie_cosh_long_mp (NODE_T * p) { int digits = get_mp_digits (MOID (p)), size = get_mp_size (MOID (p)); MP_T *x = (MP_T *) STACK_OFFSET (-size); (void) cosh_mp (p, x, x, digits); MP_STATUS (x) = (MP_T) INIT_MASK; } /*! \brief PROC long tanh = (LONG REAL) LONG REAL \param p position in tree **/ void genie_tanh_long_mp (NODE_T * p) { int digits = get_mp_digits (MOID (p)), size = get_mp_size (MOID (p)); MP_T *x = (MP_T *) STACK_OFFSET (-size); (void) tanh_mp (p, x, x, digits); MP_STATUS (x) = (MP_T) INIT_MASK; } /*! \brief PROC long arcsinh = (LONG REAL) LONG REAL \param p position in tree **/ void genie_arcsinh_long_mp (NODE_T * p) { int digits = get_mp_digits (MOID (p)), size = get_mp_size (MOID (p)); MP_T *x = (MP_T *) STACK_OFFSET (-size); (void) asinh_mp (p, x, x, digits); MP_STATUS (x) = (MP_T) INIT_MASK; } /*! \brief PROC long arccosh = (LONG REAL) LONG REAL \param p position in tree **/ void genie_arccosh_long_mp (NODE_T * p) { int digits = get_mp_digits (MOID (p)), size = get_mp_size (MOID (p)); MP_T *x = (MP_T *) STACK_OFFSET (-size); (void) acosh_mp (p, x, x, digits); MP_STATUS (x) = (MP_T) INIT_MASK; } /*! \brief PROC long arctanh = (LONG REAL) LONG REAL \param p position in tree **/ void genie_arctanh_long_mp (NODE_T * p) { int digits = get_mp_digits (MOID (p)), size = get_mp_size (MOID (p)); MP_T *x = (MP_T *) STACK_OFFSET (-size); (void) atanh_mp (p, x, x, digits); MP_STATUS (x) = (MP_T) INIT_MASK; } /*! \brief PROC long sin = (LONG REAL) LONG REAL \param p position in tree **/ void genie_sin_long_mp (NODE_T * p) { int digits = get_mp_digits (MOID (p)), size = get_mp_size (MOID (p)); MP_T *x = (MP_T *) STACK_OFFSET (-size); (void) sin_mp (p, x, x, digits); MP_STATUS (x) = (MP_T) INIT_MASK; } /*! \brief PROC long cos = (LONG REAL) LONG REAL \param p position in tree **/ void genie_cos_long_mp (NODE_T * p) { int digits = get_mp_digits (MOID (p)), size = get_mp_size (MOID (p)); MP_T *x = (MP_T *) STACK_OFFSET (-size); (void) cos_mp (p, x, x, digits); MP_STATUS (x) = (MP_T) INIT_MASK; } /*! \brief PROC long tan = (LONG REAL) LONG REAL \param p position in tree **/ void genie_tan_long_mp (NODE_T * p) { int digits = get_mp_digits (MOID (p)), size = get_mp_size (MOID (p)); MP_T *x = (MP_T *) STACK_OFFSET (-size); PRELUDE_ERROR (tan_mp (p, x, x, digits) == NO_MP, p, ERROR_INVALID_ARGUMENT, MOID (p)); MP_STATUS (x) = (MP_T) INIT_MASK; } /*! \brief PROC long arcsin = (LONG REAL) LONG REAL \param p position in tree **/ void genie_asin_long_mp (NODE_T * p) { int digits = get_mp_digits (MOID (p)), size = get_mp_size (MOID (p)); MP_T *x = (MP_T *) STACK_OFFSET (-size); PRELUDE_ERROR (asin_mp (p, x, x, digits) == NO_MP, p, ERROR_INVALID_ARGUMENT, MOID (p)); MP_STATUS (x) = (MP_T) INIT_MASK; } /*! \brief PROC long arccos = (LONG REAL) LONG REAL \param p position in tree **/ void genie_acos_long_mp (NODE_T * p) { int digits = get_mp_digits (MOID (p)), size = get_mp_size (MOID (p)); MP_T *x = (MP_T *) STACK_OFFSET (-size); PRELUDE_ERROR (acos_mp (p, x, x, digits) == NO_MP, p, ERROR_INVALID_ARGUMENT, MOID (p)); MP_STATUS (x) = (MP_T) INIT_MASK; } /*! \brief PROC long arctan = (LONG REAL) LONG REAL \param p position in tree **/ void genie_atan_long_mp (NODE_T * p) { int digits = get_mp_digits (MOID (p)), size = get_mp_size (MOID (p)); MP_T *x = (MP_T *) STACK_OFFSET (-size); (void) atan_mp (p, x, x, digits); MP_STATUS (x) = (MP_T) INIT_MASK; } /*! \brief PROC long arctan2 = (LONG REAL, LONG REAL) LONG REAL \param p position in tree **/ void genie_atan2_long_mp (NODE_T * p) { int digits = get_mp_digits (MOID (p)), size = get_mp_size (MOID (p)); MP_T *y = (MP_T *) STACK_OFFSET (-size); MP_T *x = (MP_T *) STACK_OFFSET (-2 * size); stack_pointer -= size; PRELUDE_ERROR (atan2_mp (p, x, y, x, digits) == NO_MP, p, ERROR_INVALID_ARGUMENT, MOID (p)); MP_STATUS (x) = (MP_T) INIT_MASK; } /* Arithmetic operations */ /*! \brief OP LENG = (LONG MODE) LONG LONG MODE \param p position in tree **/ void genie_lengthen_long_mp_to_longlong_mp (NODE_T * p) { MP_T *z; DECREMENT_STACK_POINTER (p, (int) size_long_mp ()); STACK_MP (z, p, longlong_mp_digits ()); (void) lengthen_mp (p, z, longlong_mp_digits (), z, long_mp_digits ()); MP_STATUS (z) = (MP_T) INIT_MASK; } /*! \brief OP SHORTEN = (LONG LONG MODE) LONG MODE \param p position in tree **/ void genie_shorten_longlong_mp_to_long_mp (NODE_T * p) { MP_T *z; MOID_T *m = SUB_MOID (p); DECREMENT_STACK_POINTER (p, (int) size_longlong_mp ()); STACK_MP (z, p, long_mp_digits ()); if (m == MODE (LONG_INT)) { PRELUDE_ERROR (MP_EXPONENT (z) > LONG_MP_DIGITS - 1, p, ERROR_OUT_OF_BOUNDS, m); } (void) shorten_mp (p, z, long_mp_digits (), z, longlong_mp_digits ()); MP_STATUS (z) = (MP_T) INIT_MASK; } /*! \brief OP - = (LONG MODE) LONG MODE \param p position in tree **/ void genie_minus_long_mp (NODE_T * p) { int size = get_mp_size (LHS_MODE (p)); MP_T *z = (MP_T *) STACK_OFFSET (-size); MP_STATUS (z) = (MP_T) INIT_MASK; MP_DIGIT (z, 1) = -MP_DIGIT (z, 1); } /*! \brief OP ABS = (LONG MODE) LONG MODE \param p position in tree **/ void genie_abs_long_mp (NODE_T * p) { int size = get_mp_size (LHS_MODE (p)); MP_T *z = (MP_T *) STACK_OFFSET (-size); MP_STATUS (z) = (MP_T) INIT_MASK; MP_DIGIT (z, 1) = ABS (MP_DIGIT (z, 1)); } /*! \brief OP SIGN = (LONG MODE) INT \param p position in tree **/ void genie_sign_long_mp (NODE_T * p) { int size = get_mp_size (LHS_MODE (p)); MP_T *z = (MP_T *) STACK_OFFSET (-size); DECREMENT_STACK_POINTER (p, size); PUSH_PRIMITIVE (p, SIGN (MP_DIGIT (z, 1)), A68_INT); } /*! \brief OP + = (LONG MODE, LONG MODE) LONG MODE \param p position in tree **/ void genie_add_long_mp (NODE_T * p) { MOID_T *mode = RHS_MODE (p); int digits = get_mp_digits (mode), size = get_mp_size (mode); MP_T *x = (MP_T *) STACK_OFFSET (-2 * size); MP_T *y = (MP_T *) STACK_OFFSET (-size); (void) add_mp (p, x, x, y, digits); MP_STATUS (x) = (MP_T) INIT_MASK; DECREMENT_STACK_POINTER (p, size); } /*! \brief OP - = (LONG MODE, LONG MODE) LONG MODE \param p position in tree **/ void genie_sub_long_mp (NODE_T * p) { MOID_T *mode = RHS_MODE (p); int digits = get_mp_digits (mode), size = get_mp_size (mode); MP_T *x = (MP_T *) STACK_OFFSET (-2 * size); MP_T *y = (MP_T *) STACK_OFFSET (-size); (void) sub_mp (p, x, x, y, digits); MP_STATUS (x) = (MP_T) INIT_MASK; DECREMENT_STACK_POINTER (p, size); } /*! \brief OP * = (LONG MODE, LONG MODE) LONG MODE \param p position in tree **/ void genie_mul_long_mp (NODE_T * p) { MOID_T *mode = RHS_MODE (p); int digits = get_mp_digits (mode), size = get_mp_size (mode); MP_T *x = (MP_T *) STACK_OFFSET (-2 * size); MP_T *y = (MP_T *) STACK_OFFSET (-size); (void) mul_mp (p, x, x, y, digits); MP_STATUS (x) = (MP_T) INIT_MASK; DECREMENT_STACK_POINTER (p, size); } /*! \brief OP / = (LONG MODE, LONG MODE) LONG MODE \param p position in tree **/ void genie_div_long_mp (NODE_T * p) { MOID_T *mode = RHS_MODE (p); int digits = get_mp_digits (mode), size = get_mp_size (mode); MP_T *x = (MP_T *) STACK_OFFSET (-2 * size); MP_T *y = (MP_T *) STACK_OFFSET (-size); PRELUDE_ERROR (div_mp (p, x, x, y, digits) == NO_MP, p, ERROR_DIVISION_BY_ZERO, MODE (LONG_REAL)); MP_STATUS (x) = (MP_T) INIT_MASK; DECREMENT_STACK_POINTER (p, size); } /*! \brief OP % = (LONG MODE, LONG MODE) LONG MODE \param p position in tree **/ void genie_over_long_mp (NODE_T * p) { MOID_T *mode = RHS_MODE (p); int digits = get_mp_digits (mode), size = get_mp_size (mode); MP_T *x = (MP_T *) STACK_OFFSET (-2 * size); MP_T *y = (MP_T *) STACK_OFFSET (-size); PRELUDE_ERROR (over_mp (p, x, x, y, digits) == NO_MP, p, ERROR_DIVISION_BY_ZERO, MODE (LONG_INT)); MP_STATUS (x) = (MP_T) INIT_MASK; DECREMENT_STACK_POINTER (p, size); } /*! \brief OP %* = (LONG MODE, LONG MODE) LONG MODE \param p position in tree **/ void genie_mod_long_mp (NODE_T * p) { MOID_T *mode = RHS_MODE (p); int digits = get_mp_digits (mode), size = get_mp_size (mode); MP_T *x = (MP_T *) STACK_OFFSET (-2 * size); MP_T *y = (MP_T *) STACK_OFFSET (-size); PRELUDE_ERROR (mod_mp (p, x, x, y, digits) == NO_MP, p, ERROR_DIVISION_BY_ZERO, MODE (LONG_INT)); if (MP_DIGIT (x, 1) < 0) { MP_DIGIT (y, 1) = ABS (MP_DIGIT (y, 1)); (void) add_mp (p, x, x, y, digits); } MP_STATUS (x) = (MP_T) INIT_MASK; DECREMENT_STACK_POINTER (p, size); } /*! \brief OP +:= = (REF LONG MODE, LONG MODE) REF LONG MODE \param p position in tree **/ void genie_plusab_long_mp (NODE_T * p) { MOID_T *mode = LHS_MODE (p); genie_f_and_becomes (p, mode, genie_add_long_mp); } /*! \brief OP -:= = (REF LONG MODE, LONG MODE) REF LONG MODE \param p position in tree **/ void genie_minusab_long_mp (NODE_T * p) { MOID_T *mode = LHS_MODE (p); genie_f_and_becomes (p, mode, genie_sub_long_mp); } /*! \brief OP *:= = (REF LONG MODE, LONG MODE) REF LONG MODE \param p position in tree **/ void genie_timesab_long_mp (NODE_T * p) { MOID_T *mode = LHS_MODE (p); genie_f_and_becomes (p, mode, genie_mul_long_mp); } /*! \brief OP /:= = (REF LONG MODE, LONG MODE) REF LONG MODE \param p position in tree **/ void genie_divab_long_mp (NODE_T * p) { MOID_T *mode = LHS_MODE (p); genie_f_and_becomes (p, mode, genie_div_long_mp); } /*! \brief OP %:= = (REF LONG MODE, LONG MODE) REF LONG MODE \param p position in tree **/ void genie_overab_long_mp (NODE_T * p) { MOID_T *mode = LHS_MODE (p); genie_f_and_becomes (p, mode, genie_over_long_mp); } /*! \brief OP %*:= = (REF LONG MODE, LONG MODE) REF LONG MODE \param p position in tree **/ void genie_modab_long_mp (NODE_T * p) { MOID_T *mode = LHS_MODE (p); genie_f_and_becomes (p, mode, genie_mod_long_mp); } /* OP (LONG MODE, LONG MODE) BOOL */ #define A68_CMP_LONG(n, OP)\ void n (NODE_T * p) {\ MOID_T *mode = LHS_MODE (p);\ A68_BOOL z;\ int digits = get_mp_digits (mode), size = get_mp_size (mode);\ MP_T *x = (MP_T *) STACK_OFFSET (-2 * size);\ MP_T *y = (MP_T *) STACK_OFFSET (-size);\ OP (p, &z, x, y, digits);\ DECREMENT_STACK_POINTER (p, 2 * size);\ PUSH_PRIMITIVE (p, VALUE (&z), A68_BOOL);\ } A68_CMP_LONG (genie_eq_long_mp, eq_mp) A68_CMP_LONG (genie_ne_long_mp, ne_mp) A68_CMP_LONG (genie_lt_long_mp, lt_mp) A68_CMP_LONG (genie_gt_long_mp, gt_mp) A68_CMP_LONG (genie_le_long_mp, le_mp) A68_CMP_LONG (genie_ge_long_mp, ge_mp) /*! \brief OP ** = (LONG MODE, INT) LONG MODE \param p position in tree **/ void genie_pow_long_mp_int (NODE_T * p) { MOID_T *mode = LHS_MODE (p); int digits = get_mp_digits (mode), size = get_mp_size (mode); A68_INT k; MP_T *x; POP_OBJECT (p, &k, A68_INT); x = (MP_T *) STACK_OFFSET (-size); (void) pow_mp_int (p, x, x, VALUE (&k), digits); MP_STATUS (x) = (MP_T) INIT_MASK; } /*! \brief OP ** = (LONG MODE, LONG MODE) LONG MODE \param p position in tree **/ void genie_pow_long_mp (NODE_T * p) { MOID_T *mode = LHS_MODE (p); int digits = get_mp_digits (mode), size = get_mp_size (mode); ADDR_T pop_sp = stack_pointer; MP_T *x = (MP_T *) STACK_OFFSET (-2 * size); MP_T *y = (MP_T *) STACK_OFFSET (-size); MP_T *z; STACK_MP (z, p, digits); if (IS_ZERO_MP (x)) { if (MP_DIGIT (y, 1) < (MP_T) 0) { PRELUDE_ERROR (A68_TRUE, p, ERROR_INVALID_ARGUMENT, MOID (p)); } else if (IS_ZERO_MP (y)) { (void) set_mp_short (x, (MP_T) 1, 0, digits); } } else { PRELUDE_ERROR (ln_mp (p, z, x, digits) == NO_MP, p, ERROR_INVALID_ARGUMENT, MOID (p)); (void) mul_mp (p, z, y, z, digits); (void) exp_mp (p, x, z, digits); } stack_pointer = pop_sp - size; MP_STATUS (x) = (MP_T) INIT_MASK; } /* Character operations */ /* OP (CHAR, CHAR) BOOL */ #define A68_CMP_CHAR(n, OP)\ void n (NODE_T * p) {\ A68_CHAR i, j;\ POP_OBJECT (p, &j, A68_CHAR);\ POP_OBJECT (p, &i, A68_CHAR);\ PUSH_PRIMITIVE (p, (BOOL_T) (TO_UCHAR (VALUE (&i)) OP TO_UCHAR (VALUE (&j))), A68_BOOL);\ } A68_CMP_CHAR (genie_eq_char, ==) A68_CMP_CHAR (genie_ne_char, !=) A68_CMP_CHAR (genie_lt_char, <) A68_CMP_CHAR (genie_gt_char, >) A68_CMP_CHAR (genie_le_char, <=) A68_CMP_CHAR (genie_ge_char, >=) /*! \brief OP ABS = (CHAR) INT \param p position in tree **/ void genie_abs_char (NODE_T * p) { A68_CHAR i; POP_OBJECT (p, &i, A68_CHAR); PUSH_PRIMITIVE (p, TO_UCHAR (VALUE (&i)), A68_INT); } /*! \brief OP REPR = (INT) CHAR \param p position in tree **/ void genie_repr_char (NODE_T * p) { A68_INT k; POP_OBJECT (p, &k, A68_INT); PRELUDE_ERROR (VALUE (&k) < 0 || VALUE (&k) > (int) UCHAR_MAX, p, ERROR_OUT_OF_BOUNDS, MODE (CHAR)); PUSH_PRIMITIVE (p, (char) (VALUE (&k)), A68_CHAR); } /* OP (CHAR) BOOL */ #define A68_CHAR_BOOL(n, OP)\ void n (NODE_T * p) {\ A68_CHAR ch;\ POP_OBJECT (p, &ch, A68_CHAR);\ PUSH_PRIMITIVE (p, (BOOL_T) (OP (VALUE (&ch)) == 0 ? A68_FALSE : A68_TRUE), A68_BOOL);\ } A68_CHAR_BOOL (genie_is_alnum, IS_ALNUM) A68_CHAR_BOOL (genie_is_alpha, IS_ALPHA) A68_CHAR_BOOL (genie_is_cntrl, IS_CNTRL) A68_CHAR_BOOL (genie_is_digit, IS_DIGIT) A68_CHAR_BOOL (genie_is_graph, IS_GRAPH) A68_CHAR_BOOL (genie_is_lower, IS_LOWER) A68_CHAR_BOOL (genie_is_print, IS_PRINT) A68_CHAR_BOOL (genie_is_punct, IS_PUNCT) A68_CHAR_BOOL (genie_is_space, IS_SPACE) A68_CHAR_BOOL (genie_is_upper, IS_UPPER) A68_CHAR_BOOL (genie_is_xdigit, IS_XDIGIT) #define A68_CHAR_CHAR(n, OP)\ void n (NODE_T * p) {\ A68_CHAR *ch;\ POP_OPERAND_ADDRESS (p, ch, A68_CHAR);\ VALUE (ch) = (char) (OP (TO_UCHAR (VALUE (ch))));\ } A68_CHAR_CHAR (genie_to_lower, TO_LOWER) A68_CHAR_CHAR (genie_to_upper, TO_UPPER) /*! \brief OP + = (CHAR, CHAR) STRING \param p position in tree **/ void genie_add_char (NODE_T * p) { A68_CHAR a, b; A68_REF c, d; A68_ARRAY *a_3; A68_TUPLE *t_3; BYTE_T *b_3; /* right part */ POP_OBJECT (p, &b, A68_CHAR); CHECK_INIT (p, INITIALISED (&b), MODE (CHAR)); /* left part */ POP_OBJECT (p, &a, A68_CHAR); CHECK_INIT (p, INITIALISED (&a), MODE (CHAR)); /* sum */ c = heap_generator (p, MODE (STRING), ALIGNED_SIZE_OF (A68_ARRAY) + ALIGNED_SIZE_OF (A68_TUPLE)); d = heap_generator (p, MODE (STRING), 2 * ALIGNED_SIZE_OF (A68_CHAR)); GET_DESCRIPTOR (a_3, t_3, &c); DIM (a_3) = 1; MOID (a_3) = MODE (CHAR); ELEM_SIZE (a_3) = ALIGNED_SIZE_OF (A68_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, ALIGNED_SIZE_OF (A68_CHAR)); MOVE ((BYTE_T *) & b_3[ALIGNED_SIZE_OF (A68_CHAR)], (BYTE_T *) & b, ALIGNED_SIZE_OF (A68_CHAR)); PUSH_REF (p, c); } /*! \brief OP ELEM = (INT, STRING) CHAR # ALGOL68C # \param p position in tree **/ void genie_elem_string (NODE_T * p) { A68_REF z; A68_ARRAY *a; A68_TUPLE *t; A68_INT k; BYTE_T *base; A68_CHAR *ch; POP_REF (p, &z); CHECK_REF (p, z, MODE (STRING)); POP_OBJECT (p, &k, A68_INT); GET_DESCRIPTOR (a, t, &z); PRELUDE_ERROR (VALUE (&k) < LWB (t), p, ERROR_INDEX_OUT_OF_BOUNDS, NO_TEXT); PRELUDE_ERROR (VALUE (&k) > UPB (t), p, ERROR_INDEX_OUT_OF_BOUNDS, NO_TEXT); base = DEREF (BYTE_T, &(ARRAY (a))); ch = (A68_CHAR *) & (base[INDEX_1_DIM (a, t, VALUE (&k))]); PUSH_PRIMITIVE (p, VALUE (ch), A68_CHAR); } /*! \brief OP + = (STRING, STRING) STRING \param p position in tree **/ void genie_add_string (NODE_T * p) { A68_REF a, b, c, d; A68_ARRAY *a_1, *a_2, *a_3; A68_TUPLE *t_1, *t_2, *t_3; int l_1, l_2, k, m; BYTE_T *b_1, *b_2, *b_3; /* right part */ POP_REF (p, &b); CHECK_INIT (p, INITIALISED (&b), MODE (STRING)); GET_DESCRIPTOR (a_2, t_2, &b); l_2 = ROW_SIZE (t_2); /* left part */ POP_REF (p, &a); CHECK_REF (p, a, MODE (STRING)); GET_DESCRIPTOR (a_1, t_1, &a); l_1 = ROW_SIZE (t_1); /* sum */ c = heap_generator (p, MODE (STRING), ALIGNED_SIZE_OF (A68_ARRAY) + ALIGNED_SIZE_OF (A68_TUPLE)); d = heap_generator (p, MODE (STRING), (l_1 + l_2) * ALIGNED_SIZE_OF (A68_CHAR)); /* Calculate again since garbage collector might have moved data */ GET_DESCRIPTOR (a_1, t_1, &a); GET_DESCRIPTOR (a_2, t_2, &b); GET_DESCRIPTOR (a_3, t_3, &c); DIM (a_3) = 1; MOID (a_3) = MODE (CHAR); ELEM_SIZE (a_3) = ALIGNED_SIZE_OF (A68_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)], ALIGNED_SIZE_OF (A68_CHAR)); m += ALIGNED_SIZE_OF (A68_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)], ALIGNED_SIZE_OF (A68_CHAR)); m += ALIGNED_SIZE_OF (A68_CHAR); } } PUSH_REF (p, c); } /*! \brief OP * = (INT, STRING) STRING \param p position in tree **/ void genie_times_int_string (NODE_T * p) { A68_INT k; A68_REF a; POP_REF (p, &a); POP_OBJECT (p, &k, A68_INT); PRELUDE_ERROR (VALUE (&k) < 0, p, ERROR_INVALID_ARGUMENT, MODE (INT)); PUSH_REF (p, empty_string (p)); while (VALUE (&k)--) { PUSH_REF (p, a); genie_add_string (p); } } /*! \brief OP * = (STRING, INT) STRING \param p position in tree **/ void genie_times_string_int (NODE_T * p) { A68_INT k; A68_REF a; POP_OBJECT (p, &k, A68_INT); POP_REF (p, &a); PUSH_PRIMITIVE (p, VALUE (&k), A68_INT); PUSH_REF (p, a); genie_times_int_string (p); } /*! \brief OP * = (INT, CHAR) STRING \param p position in tree **/ void genie_times_int_char (NODE_T * p) { A68_INT str_size; A68_CHAR a; A68_REF z, row; A68_ARRAY arr; A68_TUPLE tup; BYTE_T *base; int k; /* Pop operands */ POP_OBJECT (p, &a, A68_CHAR); POP_OBJECT (p, &str_size, A68_INT); PRELUDE_ERROR (VALUE (&str_size) < 0, p, ERROR_INVALID_ARGUMENT, MODE (INT)); /* Make new_one string */ z = heap_generator (p, MODE (ROW_CHAR), ALIGNED_SIZE_OF (A68_ARRAY) + ALIGNED_SIZE_OF (A68_TUPLE)); row = heap_generator (p, MODE (ROW_CHAR), (int) (VALUE (&str_size)) * ALIGNED_SIZE_OF (A68_CHAR)); DIM (&arr) = 1; MOID (&arr) = MODE (CHAR); ELEM_SIZE (&arr) = ALIGNED_SIZE_OF (A68_CHAR); SLICE_OFFSET (&arr) = 0; FIELD_OFFSET (&arr) = 0; ARRAY (&arr) = row; LWB (&tup) = 1; UPB (&tup) = VALUE (&str_size); SHIFT (&tup) = LWB (&tup); SPAN (&tup) = 1; K (&tup) = 0; PUT_DESCRIPTOR (arr, tup, &z); /* Copy */ base = ADDRESS (&row); for (k = 0; k < VALUE (&str_size); k++) { A68_CHAR ch; STATUS (&ch) = INIT_MASK; VALUE (&ch) = VALUE (&a); *(A68_CHAR *) & base[k * ALIGNED_SIZE_OF (A68_CHAR)] = ch; } PUSH_REF (p, z); } /*! \brief OP * = (CHAR, INT) STRING \param p position in tree **/ void genie_times_char_int (NODE_T * p) { A68_INT k; A68_CHAR a; POP_OBJECT (p, &k, A68_INT); POP_OBJECT (p, &a, A68_CHAR); PUSH_PRIMITIVE (p, VALUE (&k), A68_INT); PUSH_PRIMITIVE (p, VALUE (&a), A68_CHAR); genie_times_int_char (p); } /*! \brief OP +:= = (REF STRING, STRING) REF STRING \param p position in tree **/ void genie_plusab_string (NODE_T * p) { genie_f_and_becomes (p, MODE (REF_STRING), genie_add_string); } /*! \brief OP +=: = (STRING, REF STRING) REF STRING \param p position in tree **/ void genie_plusto_string (NODE_T * p) { A68_REF refa, a, b; POP_REF (p, &refa); CHECK_REF (p, refa, MODE (REF_STRING)); a = * DEREF (A68_REF, &refa); CHECK_INIT (p, INITIALISED (&a), MODE (STRING)); POP_REF (p, &b); PUSH_REF (p, b); PUSH_REF (p, a); genie_add_string (p); POP_REF (p, DEREF (A68_REF, &refa)); PUSH_REF (p, refa); } /*! \brief OP *:= = (REF STRING, INT) REF STRING \param p position in tree **/ void genie_timesab_string (NODE_T * p) { A68_INT k; A68_REF refa, a; int i; /* INT */ POP_OBJECT (p, &k, A68_INT); PRELUDE_ERROR (VALUE (&k) < 0, p, ERROR_INVALID_ARGUMENT, MODE (INT)); /* REF STRING */ POP_REF (p, &refa); CHECK_REF (p, refa, MODE (REF_STRING)); a = * DEREF (A68_REF, &refa); CHECK_INIT (p, INITIALISED (&a), MODE (STRING)); /* Multiplication as repeated addition */ PUSH_REF (p, empty_string (p)); for (i = 1; i <= VALUE (&k); i++) { PUSH_REF (p, a); genie_add_string (p); } /* The stack contains a STRING, promote to REF STRING */ POP_REF (p, DEREF (A68_REF, &refa)); PUSH_REF (p, refa); } /*! \brief difference between two STRINGs in the stack \param p position in tree \return -1 if a < b, 0 if a = b or -1 if a > b **/ static int string_difference (NODE_T * p) { A68_REF row1, row2; A68_ARRAY *a_1, *a_2; A68_TUPLE *t_1, *t_2; BYTE_T *b_1, *b_2; int size, s_1, s_2, k, diff; /* Pop operands */ POP_REF (p, &row2); CHECK_INIT (p, INITIALISED (&row2), MODE (STRING)); GET_DESCRIPTOR (a_2, t_2, &row2); s_2 = ROW_SIZE (t_2); POP_REF (p, &row1); CHECK_INIT (p, INITIALISED (&row1), MODE (STRING)); GET_DESCRIPTOR (a_1, t_1, &row1); s_1 = ROW_SIZE (t_1); /* Get difference */ size = (s_1 > s_2 ? s_1 : s_2); diff = 0; b_1 = (s_1 > 0 ? DEREF (BYTE_T, &ARRAY (a_1)) : NO_BYTE); b_2 = (s_2 > 0 ? DEREF (BYTE_T, &ARRAY (a_2)) : NO_BYTE); for (k = 0; k < size && diff == 0; k++) { int a, b; if (s_1 > 0 && k < s_1) { A68_CHAR *ch = (A68_CHAR *) & b_1[INDEX_1_DIM (a_1, t_1, LWB (t_1) + k)]; a = (int) VALUE (ch); } else { a = 0; } if (s_2 > 0 && k < s_2) { A68_CHAR *ch = (A68_CHAR *) & b_2[INDEX_1_DIM (a_2, t_2, LWB (t_2) + k)]; b = (int) VALUE (ch); } else { b = 0; } diff += (TO_UCHAR (a) - TO_UCHAR (b)); } return (diff); } /* OP (STRING, STRING) BOOL */ #define A68_CMP_STRING(n, OP)\ void n (NODE_T * p) {\ int k = string_difference (p);\ PUSH_PRIMITIVE (p, (BOOL_T) (k OP 0), A68_BOOL);\ } A68_CMP_STRING (genie_eq_string, ==) A68_CMP_STRING (genie_ne_string, !=) A68_CMP_STRING (genie_lt_string, <) A68_CMP_STRING (genie_gt_string, >) A68_CMP_STRING (genie_le_string, <=) A68_CMP_STRING (genie_ge_string, >=) /* RNG functions are in gsl.c.*/ /*! \brief PROC first random = (INT) VOID \param p position in tree **/ void genie_first_random (NODE_T * p) { A68_INT i; POP_OBJECT (p, &i, A68_INT); init_rng ((unsigned long) VALUE (&i)); } /*! \brief PROC next random = REAL \param p position in tree **/ void genie_next_random (NODE_T * p) { PUSH_PRIMITIVE (p, rng_53_bit (), A68_REAL); } /*! \brief PROC rnd = REAL \param p position in tree **/ void genie_next_rnd (NODE_T * p) { PUSH_PRIMITIVE (p, 2 * rng_53_bit () - 1, A68_REAL); } /*! \brief PROC next long random = LONG REAL \param p position in tree **/ void genie_long_next_random (NODE_T * p) { int digits = get_mp_digits (MOID (p)); MP_T *z; int k = 2 + digits; STACK_MP (z, p, digits); while (--k > 1) { z[k] = (MP_T) (int) (rng_53_bit () * MP_RADIX); } MP_EXPONENT (z) = (MP_T) (-1); MP_STATUS (z) = (MP_T) INIT_MASK; } /* BYTES operations */ /*! \brief OP ELEM = (INT, BYTES) CHAR \param p position in tree **/ void genie_elem_bytes (NODE_T * p) { A68_BYTES j; A68_INT i; POP_OBJECT (p, &j, A68_BYTES); POP_OBJECT (p, &i, A68_INT); PRELUDE_ERROR (VALUE (&i) < 1 || VALUE (&i) > BYTES_WIDTH, p, ERROR_OUT_OF_BOUNDS, MODE (INT)); if (VALUE (&i) > (int) strlen (VALUE (&j))) { genie_null_char (p); } else { PUSH_PRIMITIVE (p, VALUE (&j)[VALUE (&i) - 1], A68_CHAR); } } /*! \brief PROC bytes pack = (STRING) BYTES \param p position in tree **/ void genie_bytespack (NODE_T * p) { A68_REF z; A68_BYTES b; POP_REF (p, &z); CHECK_REF (p, z, MODE (STRING)); PRELUDE_ERROR (a68_string_size (p, z) > BYTES_WIDTH, p, ERROR_OUT_OF_BOUNDS, MODE (STRING)); STATUS (&b) = INIT_MASK; ASSERT (a_to_c_string (p, VALUE (&b), z) != NO_TEXT); PUSH_BYTES (p, VALUE (&b)); } /*! \brief PROC bytes pack = (STRING) BYTES \param p position in tree **/ void genie_add_bytes (NODE_T * p) { A68_BYTES *i, *j; POP_OPERAND_ADDRESSES (p, i, j, A68_BYTES); PRELUDE_ERROR (((int) strlen (VALUE (i)) + (int) strlen (VALUE (j))) > BYTES_WIDTH, p, ERROR_OUT_OF_BOUNDS, MODE (BYTES)); bufcat (VALUE (i), VALUE (j), BYTES_WIDTH); } /*! \brief OP +:= = (REF BYTES, BYTES) REF BYTES \param p position in tree **/ void genie_plusab_bytes (NODE_T * p) { genie_f_and_becomes (p, MODE (REF_BYTES), genie_add_bytes); } /*! \brief OP +=: = (BYTES, REF BYTES) REF BYTES \param p position in tree **/ void genie_plusto_bytes (NODE_T * p) { A68_BYTES i, *address, j; A68_REF z; POP_REF (p, &z); CHECK_REF (p, z, MODE (REF_BYTES)); address = DEREF (A68_BYTES, &z); CHECK_INIT (p, INITIALISED (address), MODE (BYTES)); POP_OBJECT (p, &i, A68_BYTES); PRELUDE_ERROR (((int) strlen (VALUE (address)) + (int) strlen (VALUE (&i))) > BYTES_WIDTH, p, ERROR_OUT_OF_BOUNDS, MODE (BYTES)); bufcpy (VALUE (&j), VALUE (&i), BYTES_WIDTH); bufcat (VALUE (&j), VALUE (address), BYTES_WIDTH); bufcpy (VALUE (address), VALUE (&j), BYTES_WIDTH); PUSH_REF (p, z); } /*! \brief difference between BYTE strings \param p position in tree \return difference between objects **/ static int compare_bytes (NODE_T * p) { A68_BYTES x, y; POP_OBJECT (p, &y, A68_BYTES); POP_OBJECT (p, &x, A68_BYTES); return (strcmp (VALUE (&x), VALUE (&y))); } /* OP (BYTES, BYTES) BOOL */ #define A68_CMP_BYTES(n, OP)\ void n (NODE_T * p) {\ int k = compare_bytes (p);\ PUSH_PRIMITIVE (p, (BOOL_T) (k OP 0), A68_BOOL);\ } A68_CMP_BYTES (genie_eq_bytes, ==) A68_CMP_BYTES (genie_ne_bytes, !=) A68_CMP_BYTES (genie_lt_bytes, <) A68_CMP_BYTES (genie_gt_bytes, >) A68_CMP_BYTES (genie_le_bytes, <=) A68_CMP_BYTES (genie_ge_bytes, >=) /*! \brief OP LENG = (BYTES) LONG BYTES \param p position in tree **/ void genie_leng_bytes (NODE_T * p) { A68_BYTES a; POP_OBJECT (p, &a, A68_BYTES); PUSH_LONG_BYTES (p, VALUE (&a)); } /*! \brief OP SHORTEN = (LONG BYTES) BYTES \param p position in tree **/ void genie_shorten_bytes (NODE_T * p) { A68_LONG_BYTES a; POP_OBJECT (p, &a, A68_LONG_BYTES); PRELUDE_ERROR (strlen (VALUE (&a)) >= BYTES_WIDTH, p, ERROR_OUT_OF_BOUNDS, MODE (BYTES)); PUSH_BYTES (p, VALUE (&a)); } /*! \brief OP ELEM = (INT, LONG BYTES) CHAR \param p position in tree **/ void genie_elem_long_bytes (NODE_T * p) { A68_LONG_BYTES j; A68_INT i; POP_OBJECT (p, &j, A68_LONG_BYTES); POP_OBJECT (p, &i, A68_INT); PRELUDE_ERROR (VALUE (&i) < 1 || VALUE (&i) > LONG_BYTES_WIDTH, p, ERROR_OUT_OF_BOUNDS, MODE (INT)); if (VALUE (&i) > (int) strlen (VALUE (&j))) { genie_null_char (p); } else { PUSH_PRIMITIVE (p, VALUE (&j)[VALUE (&i) - 1], A68_CHAR); } } /*! \brief PROC long bytes pack = (STRING) LONG BYTES \param p position in tree **/ void genie_long_bytespack (NODE_T * p) { A68_REF z; A68_LONG_BYTES b; POP_REF (p, &z); CHECK_REF (p, z, MODE (STRING)); PRELUDE_ERROR (a68_string_size (p, z) > LONG_BYTES_WIDTH, p, ERROR_OUT_OF_BOUNDS, MODE (STRING)); STATUS (&b) = INIT_MASK; ASSERT (a_to_c_string (p, VALUE (&b), z) != NO_TEXT); PUSH_LONG_BYTES (p, VALUE (&b)); } /*! \brief OP + = (LONG BYTES, LONG BYTES) LONG BYTES \param p position in tree **/ void genie_add_long_bytes (NODE_T * p) { A68_LONG_BYTES *i, *j; POP_OPERAND_ADDRESSES (p, i, j, A68_LONG_BYTES); PRELUDE_ERROR (((int) strlen (VALUE (i)) + (int) strlen (VALUE (j))) > LONG_BYTES_WIDTH, p, ERROR_OUT_OF_BOUNDS, MODE (LONG_BYTES)); bufcat (VALUE (i), VALUE (j), LONG_BYTES_WIDTH); } /*! \brief OP +:= = (REF LONG BYTES, LONG BYTES) REF LONG BYTES \param p position in tree **/ void genie_plusab_long_bytes (NODE_T * p) { genie_f_and_becomes (p, MODE (REF_LONG_BYTES), genie_add_long_bytes); } /*! \brief OP +=: = (LONG BYTES, REF LONG BYTES) REF LONG BYTES \param p position in tree **/ void genie_plusto_long_bytes (NODE_T * p) { A68_LONG_BYTES i, *address, j; A68_REF z; POP_REF (p, &z); CHECK_REF (p, z, MODE (REF_LONG_BYTES)); address = DEREF (A68_LONG_BYTES, &z); CHECK_INIT (p, INITIALISED (address), MODE (LONG_BYTES)); POP_OBJECT (p, &i, A68_LONG_BYTES); PRELUDE_ERROR (((int) strlen (VALUE (address)) + (int) strlen (VALUE (&i))) > LONG_BYTES_WIDTH, p, ERROR_OUT_OF_BOUNDS, MODE (LONG_BYTES)); bufcpy (VALUE (&j), VALUE (&i), LONG_BYTES_WIDTH); bufcat (VALUE (&j), VALUE (address), LONG_BYTES_WIDTH); bufcpy (VALUE (address), VALUE (&j), LONG_BYTES_WIDTH); PUSH_REF (p, z); } /*! \brief difference between LONG BYTE strings \param p position in tree \return difference between objects **/ static int compare_long_bytes (NODE_T * p) { A68_LONG_BYTES x, y; POP_OBJECT (p, &y, A68_LONG_BYTES); POP_OBJECT (p, &x, A68_LONG_BYTES); return (strcmp (VALUE (&x), VALUE (&y))); } /* OP (LONG BYTES, LONG BYTES) BOOL */ #define A68_CMP_LONG_BYTES(n, OP)\ void n (NODE_T * p) {\ int k = compare_long_bytes (p);\ PUSH_PRIMITIVE (p, (BOOL_T) (k OP 0), A68_BOOL);\ } A68_CMP_LONG_BYTES (genie_eq_long_bytes, ==) A68_CMP_LONG_BYTES (genie_ne_long_bytes, !=) A68_CMP_LONG_BYTES (genie_lt_long_bytes, <) A68_CMP_LONG_BYTES (genie_gt_long_bytes, >) A68_CMP_LONG_BYTES (genie_le_long_bytes, <=) A68_CMP_LONG_BYTES (genie_ge_long_bytes, >=) /* BITS operations */ /* OP NOT = (BITS) BITS */ A68_MONAD (genie_not_bits, A68_BITS, ~) /*! \brief OP AND = (BITS, BITS) BITS \param p position in tree **/ void genie_and_bits (NODE_T * p) { A68_BITS *i, *j; POP_OPERAND_ADDRESSES (p, i, j, A68_BITS); VALUE (i) = VALUE (i) & VALUE (j); } /*! \brief OP OR = (BITS, BITS) BITS \param p position in tree **/ void genie_or_bits (NODE_T * p) { A68_BITS *i, *j; POP_OPERAND_ADDRESSES (p, i, j, A68_BITS); VALUE (i) = VALUE (i) | VALUE (j); } /*! \brief OP XOR = (BITS, BITS) BITS \param p position in tree **/ void genie_xor_bits (NODE_T * p) { A68_BITS *i, *j; POP_OPERAND_ADDRESSES (p, i, j, A68_BITS); VALUE (i) = VALUE (i) ^ VALUE (j); } /* OP = = (BITS, BITS) BOOL */ #define A68_CMP_BITS(n, OP)\ void n (NODE_T * p) {\ A68_BITS i, j;\ POP_OBJECT (p, &j, A68_BITS);\ POP_OBJECT (p, &i, A68_BITS);\ PUSH_PRIMITIVE (p, (BOOL_T) (VALUE (&i) OP VALUE (&j)), A68_BOOL);\ } A68_CMP_BITS (genie_eq_bits, ==) A68_CMP_BITS (genie_ne_bits, !=) /*! \brief OP <= = (BITS, BITS) BOOL \param p position in tree **/ void genie_le_bits (NODE_T * p) { A68_BITS i, j; POP_OBJECT (p, &j, A68_BITS); POP_OBJECT (p, &i, A68_BITS); PUSH_PRIMITIVE (p, (BOOL_T) ((VALUE (&i) | VALUE (&j)) == VALUE (&j)), A68_BOOL); } /*! \brief OP >= = (BITS, BITS) BOOL \param p position in tree **/ void genie_ge_bits (NODE_T * p) { A68_BITS i, j; POP_OBJECT (p, &j, A68_BITS); POP_OBJECT (p, &i, A68_BITS); PUSH_PRIMITIVE (p, (BOOL_T) ((VALUE (&i) | VALUE (&j)) == VALUE (&i)), A68_BOOL); } /*! \brief OP SHL = (BITS, INT) BITS \param p position in tree **/ void genie_shl_bits (NODE_T * p) { A68_BITS i; A68_INT j; POP_OBJECT (p, &j, A68_INT); POP_OBJECT (p, &i, A68_BITS); if (VALUE (&j) >= 0) { PUSH_PRIMITIVE (p, VALUE (&i) << VALUE (&j), A68_BITS); } else { PUSH_PRIMITIVE (p, VALUE (&i) >> -VALUE (&j), A68_BITS); } } /*! \brief OP SHR = (BITS, INT) BITS \param p position in tree **/ void genie_shr_bits (NODE_T * p) { A68_INT *j; POP_OPERAND_ADDRESS (p, j, A68_INT); VALUE (j) = -VALUE (j); genie_shl_bits (p); /* Conform RR */ } /*! \brief OP ELEM = (INT, BITS) BOOL \param p position in tree **/ void genie_elem_bits (NODE_T * p) { A68_BITS j; A68_INT i; int n; unsigned mask = 0x1; POP_OBJECT (p, &j, A68_BITS); POP_OBJECT (p, &i, A68_INT); PRELUDE_ERROR (VALUE (&i) < 1 || VALUE (&i) > BITS_WIDTH, p, ERROR_OUT_OF_BOUNDS, MODE (INT)); for (n = 0; n < (BITS_WIDTH - VALUE (&i)); n++) { mask = mask << 1; } PUSH_PRIMITIVE (p, (BOOL_T) ((VALUE (&j) & mask) != 0 ? A68_TRUE : A68_FALSE), A68_BOOL); } /*! \brief OP SET = (INT, BITS) BITS \param p position in tree **/ void genie_set_bits (NODE_T * p) { A68_BITS j; A68_INT i; int n; unsigned mask = 0x1; POP_OBJECT (p, &j, A68_BITS); POP_OBJECT (p, &i, A68_INT); PRELUDE_ERROR (VALUE (&i) < 1 || VALUE (&i) > BITS_WIDTH, p, ERROR_OUT_OF_BOUNDS, MODE (INT)); for (n = 0; n < (BITS_WIDTH - VALUE (&i)); n++) { mask = mask << 1; } PUSH_PRIMITIVE (p, VALUE (&j) | mask, A68_BITS); } /*! \brief OP CLEAR = (INT, BITS) BITS \param p position in tree **/ void genie_clear_bits (NODE_T * p) { A68_BITS j; A68_INT i; int n; unsigned mask = 0x1; POP_OBJECT (p, &j, A68_BITS); POP_OBJECT (p, &i, A68_INT); PRELUDE_ERROR (VALUE (&i) < 1 || VALUE (&i) > BITS_WIDTH, p, ERROR_OUT_OF_BOUNDS, MODE (INT)); for (n = 0; n < (BITS_WIDTH - VALUE (&i)); n++) { mask = mask << 1; } PUSH_PRIMITIVE (p, VALUE (&j) & ~mask, A68_BITS); } /*! \brief OP ABS = (BITS) INT \param p position in tree **/ void genie_abs_bits (NODE_T * p) { A68_BITS i; POP_OBJECT (p, &i, A68_BITS); PUSH_PRIMITIVE (p, (int) (VALUE (&i)), A68_INT); } /*! \brief OP BIN = (INT) BITS \param p position in tree **/ void genie_bin_int (NODE_T * p) { A68_INT i; POP_OBJECT (p, &i, A68_INT); /* RR does not convert negative numbers. Algol68G does */ PUSH_PRIMITIVE (p, (unsigned) (VALUE (&i)), A68_BITS); } /*! \brief OP BIN = (LONG INT) LONG BITS \param p position in tree **/ void genie_bin_long_mp (NODE_T * p) { MOID_T *mode = SUB_MOID (p); int size = get_mp_size (mode); ADDR_T pop_sp = stack_pointer; MP_T *u = (MP_T *) STACK_OFFSET (-size); /* We convert just for the operand check */ (void) stack_mp_bits (p, u, mode); MP_STATUS (u) = (MP_T) INIT_MASK; stack_pointer = pop_sp; } /*! \brief OP NOT = (LONG BITS) LONG BITS \param p position in tree **/ void genie_not_long_mp (NODE_T * p) { MOID_T *mode = LHS_MODE (p); int size = get_mp_size (mode); ADDR_T pop_sp = stack_pointer; int k, words = get_mp_bits_words (mode); MP_T *u = (MP_T *) STACK_OFFSET (-size); unsigned *row = stack_mp_bits (p, u, mode); for (k = 0; k < words; k++) { row[k] = ~row[k]; } (void) pack_mp_bits (p, u, row, mode); stack_pointer = pop_sp; } /*! \brief OP SHORTEN = (LONG BITS) BITS \param p position in tree **/ void genie_shorten_long_mp_to_bits (NODE_T * p) { MOID_T *mode = LHS_MODE (p); int digits = get_mp_digits (mode), size = get_mp_size (mode); MP_T *z = (MP_T *) STACK_OFFSET (-size); DECREMENT_STACK_POINTER (p, size); PUSH_PRIMITIVE (p, mp_to_unsigned (p, z, digits), A68_BITS); } /*! \brief get bit from LONG BITS \param p position in tree \param k element number \param z mp number \param m mode associated with z \return same **/ unsigned elem_long_bits (NODE_T * p, ADDR_T k, MP_T * z, MOID_T * m) { int n; ADDR_T pop_sp = stack_pointer; unsigned *words = stack_mp_bits (p, z, m), mask = 0x1; k += (MP_BITS_BITS - get_mp_bits_width (m) % MP_BITS_BITS - 1); for (n = 0; n < MP_BITS_BITS - k % MP_BITS_BITS - 1; n++) { mask = mask << 1; } stack_pointer = pop_sp; return ((words[k / MP_BITS_BITS]) & mask); } /*! \brief OP ELEM = (INT, LONG BITS) BOOL \param p position in tree **/ void genie_elem_long_bits (NODE_T * p) { A68_INT *i; MP_T *z; unsigned w; int bits = get_mp_bits_width (MODE (LONG_BITS)), size = get_mp_size (MODE (LONG_BITS)); z = (MP_T *) STACK_OFFSET (-size); i = (A68_INT *) STACK_OFFSET (-(size + ALIGNED_SIZE_OF (A68_INT))); PRELUDE_ERROR (VALUE (i) < 1 || VALUE (i) > bits, p, ERROR_OUT_OF_BOUNDS, MODE (INT)); w = elem_long_bits (p, VALUE (i), z, MODE (LONG_BITS)); DECREMENT_STACK_POINTER (p, size + ALIGNED_SIZE_OF (A68_INT)); PUSH_PRIMITIVE (p, (BOOL_T) (w != 0), A68_BOOL); } /*! \brief OP ELEM = (INT, LONG LONG BITS) BOOL \param p position in tree **/ void genie_elem_longlong_bits (NODE_T * p) { A68_INT *i; MP_T *z; unsigned w; int bits = get_mp_bits_width (MODE (LONGLONG_BITS)), size = get_mp_size (MODE (LONGLONG_BITS)); z = (MP_T *) STACK_OFFSET (-size); i = (A68_INT *) STACK_OFFSET (-(size + ALIGNED_SIZE_OF (A68_INT))); PRELUDE_ERROR (VALUE (i) < 1 || VALUE (i) > bits, p, ERROR_OUT_OF_BOUNDS, MODE (INT)); w = elem_long_bits (p, VALUE (i), z, MODE (LONGLONG_BITS)); DECREMENT_STACK_POINTER (p, size + ALIGNED_SIZE_OF (A68_INT)); PUSH_PRIMITIVE (p, (BOOL_T) (w != 0), A68_BOOL); } /*! \brief set bit in LONG BITS \param p position in tree \param k bit index \param z mp number \param m mode associated with z **/ static unsigned *set_long_bits (NODE_T * p, int k, MP_T * z, MOID_T * m, unsigned bit) { int n; unsigned *words = stack_mp_bits (p, z, m), mask = 0x1; k += (MP_BITS_BITS - get_mp_bits_width (m) % MP_BITS_BITS - 1); for (n = 0; n < MP_BITS_BITS - k % MP_BITS_BITS - 1; n++) { mask = mask << 1; } if (bit == 0x1) { words[k / MP_BITS_BITS] = (words[k / MP_BITS_BITS]) | mask; } else { words[k / MP_BITS_BITS] = (words[k / MP_BITS_BITS]) & (~mask); } return (words); } /*! \brief OP SET = (INT, LONG BITS) VOID \param p position in tree **/ void genie_set_long_bits (NODE_T * p) { A68_INT *i; MP_T *z; unsigned *w; ADDR_T pop_sp = stack_pointer; int bits = get_mp_bits_width (MODE (LONG_BITS)), size = get_mp_size (MODE (LONG_BITS)); z = (MP_T *) STACK_OFFSET (-size); i = (A68_INT *) STACK_OFFSET (-(size + ALIGNED_SIZE_OF (A68_INT))); PRELUDE_ERROR (VALUE (i) < 1 || VALUE (i) > bits, p, ERROR_OUT_OF_BOUNDS, MODE (INT)); w = set_long_bits (p, VALUE (i), z, MODE (LONG_BITS), 0x1); (void) pack_mp_bits (p, (MP_T *) STACK_ADDRESS (pop_sp - size - ALIGNED_SIZE_OF (A68_INT)), w, MODE (LONG_BITS)); stack_pointer = pop_sp; DECREMENT_STACK_POINTER (p, ALIGNED_SIZE_OF (A68_INT)); } /*! \brief OP SET = (INT, LONG LONG BITS) BOOL \param p position in tree **/ void genie_set_longlong_bits (NODE_T * p) { A68_INT *i; MP_T *z; unsigned *w; ADDR_T pop_sp = stack_pointer; int bits = get_mp_bits_width (MODE (LONGLONG_BITS)), size = get_mp_size (MODE (LONGLONG_BITS)); z = (MP_T *) STACK_OFFSET (-size); i = (A68_INT *) STACK_OFFSET (-(size + ALIGNED_SIZE_OF (A68_INT))); PRELUDE_ERROR (VALUE (i) < 1 || VALUE (i) > bits, p, ERROR_OUT_OF_BOUNDS, MODE (INT)); w = set_long_bits (p, VALUE (i), z, MODE (LONGLONG_BITS), 0x1); (void) pack_mp_bits (p, (MP_T *) STACK_ADDRESS (pop_sp - size - ALIGNED_SIZE_OF (A68_INT)), w, MODE (LONGLONG_BITS)); stack_pointer = pop_sp; DECREMENT_STACK_POINTER (p, ALIGNED_SIZE_OF (A68_INT)); } /*! \brief OP CLEAR = (INT, LONG BITS) BOOL \param p position in tree **/ void genie_clear_long_bits (NODE_T * p) { A68_INT *i; MP_T *z; unsigned *w; ADDR_T pop_sp = stack_pointer; int bits = get_mp_bits_width (MODE (LONG_BITS)), size = get_mp_size (MODE (LONG_BITS)); z = (MP_T *) STACK_OFFSET (-size); i = (A68_INT *) STACK_OFFSET (-(size + ALIGNED_SIZE_OF (A68_INT))); PRELUDE_ERROR (VALUE (i) < 1 || VALUE (i) > bits, p, ERROR_OUT_OF_BOUNDS, MODE (INT)); w = set_long_bits (p, VALUE (i), z, MODE (LONG_BITS), 0x0); (void) pack_mp_bits (p, (MP_T *) STACK_ADDRESS (pop_sp - size - ALIGNED_SIZE_OF (A68_INT)), w, MODE (LONG_BITS)); stack_pointer = pop_sp; DECREMENT_STACK_POINTER (p, ALIGNED_SIZE_OF (A68_INT)); } /*! \brief OP CLEAR = (INT, LONG LONG BITS) BOOL \param p position in tree **/ void genie_clear_longlong_bits (NODE_T * p) { A68_INT *i; MP_T *z; unsigned *w; ADDR_T pop_sp = stack_pointer; int bits = get_mp_bits_width (MODE (LONGLONG_BITS)), size = get_mp_size (MODE (LONGLONG_BITS)); z = (MP_T *) STACK_OFFSET (-size); i = (A68_INT *) STACK_OFFSET (-(size + ALIGNED_SIZE_OF (A68_INT))); PRELUDE_ERROR (VALUE (i) < 1 || VALUE (i) > bits, p, ERROR_OUT_OF_BOUNDS, MODE (INT)); w = set_long_bits (p, VALUE (i), z, MODE (LONGLONG_BITS), 0x0); (void) pack_mp_bits (p, (MP_T *) STACK_ADDRESS (pop_sp - size - ALIGNED_SIZE_OF (A68_INT)), w, MODE (LONGLONG_BITS)); stack_pointer = pop_sp; DECREMENT_STACK_POINTER (p, ALIGNED_SIZE_OF (A68_INT)); } /*! \brief PROC bits pack = ([] BOOL) BITS \param p position in tree **/ void genie_bits_pack (NODE_T * p) { A68_REF z; A68_BITS b; A68_ARRAY *arr; A68_TUPLE *tup; BYTE_T *base; int size, k; unsigned bit; POP_REF (p, &z); CHECK_REF (p, z, MODE (ROW_BOOL)); GET_DESCRIPTOR (arr, tup, &z); size = ROW_SIZE (tup); PRELUDE_ERROR (size < 0 || size > BITS_WIDTH, p, ERROR_OUT_OF_BOUNDS, MODE (ROW_BOOL)); VALUE (&b) = 0x0; if (ROW_SIZE (tup) > 0) { base = DEREF (BYTE_T, &ARRAY (arr)); bit = 0x1; for (k = UPB (tup); k >= LWB (tup); k--) { int addr = INDEX_1_DIM (arr, tup, k); A68_BOOL *boo = (A68_BOOL *) & (base[addr]); CHECK_INIT (p, INITIALISED (boo), MODE (BOOL)); if (VALUE (boo)) { VALUE (&b) |= bit; } bit <<= 1; } } STATUS (&b) = INIT_MASK; PUSH_OBJECT (p, b, A68_BITS); } /*! \brief PROC long bits pack = ([] BOOL) LONG BITS \param p position in tree **/ void genie_long_bits_pack (NODE_T * p) { MOID_T *mode = MOID (p); A68_REF z; A68_ARRAY *arr; A68_TUPLE *tup; BYTE_T *base; int size, k, bits, digits; ADDR_T pop_sp; MP_T *sum, *fact; POP_REF (p, &z); CHECK_REF (p, z, MODE (ROW_BOOL)); GET_DESCRIPTOR (arr, tup, &z); size = ROW_SIZE (tup); bits = get_mp_bits_width (mode); digits = get_mp_digits (mode); PRELUDE_ERROR (size < 0 || size > bits, p, ERROR_OUT_OF_BOUNDS, MODE (ROW_BOOL)); /* Convert so that LWB goes to MSB, so ELEM gives same order as [] BOOL */ STACK_MP (sum, p, digits); SET_MP_ZERO (sum, digits); pop_sp = stack_pointer; STACK_MP (fact, p, digits); (void) set_mp_short (fact, (MP_T) 1, 0, digits); if (ROW_SIZE (tup) > 0) { base = DEREF (BYTE_T, &ARRAY (arr)); for (k = UPB (tup); k >= LWB (tup); k--) { int addr = INDEX_1_DIM (arr, tup, k); A68_BOOL *boo = (A68_BOOL *) & (base[addr]); CHECK_INIT (p, INITIALISED (boo), MODE (BOOL)); if (VALUE (boo)) { (void) add_mp (p, sum, sum, fact, digits); } (void) mul_mp_digit (p, fact, fact, (MP_T) 2, digits); } } stack_pointer = pop_sp; MP_STATUS (sum) = (MP_T) INIT_MASK; } /*! \brief OP SHL = (LONG BITS, INT) LONG BITS \param p position in tree **/ void genie_shl_long_mp (NODE_T * p) { MOID_T *mode = LHS_MODE (p); int i, k, size = get_mp_size (mode), words = get_mp_bits_words (mode); MP_T *u; unsigned *row_u; ADDR_T pop_sp; A68_INT j; /* Pop number of bits */ POP_OBJECT (p, &j, A68_INT); u = (MP_T *) STACK_OFFSET (-size); pop_sp = stack_pointer; row_u = stack_mp_bits (p, u, mode); if (VALUE (&j) >= 0) { for (i = 0; i < VALUE (&j); i++) { BOOL_T carry = A68_FALSE; for (k = words - 1; k >= 0; k--) { row_u[k] <<= 1; if (carry) { row_u[k] |= 0x1; } carry = (BOOL_T) ((row_u[k] & MP_BITS_RADIX) != 0); row_u[k] &= ~((unsigned) MP_BITS_RADIX); } } } else { for (i = 0; i < -VALUE (&j); i++) { BOOL_T carry = A68_FALSE; for (k = 0; k < words; k++) { if (carry) { row_u[k] |= MP_BITS_RADIX; } carry = (BOOL_T) ((row_u[k] & 0x1) != 0); row_u[k] >>= 1; } } } (void) pack_mp_bits (p, u, row_u, mode); stack_pointer = pop_sp; } /*! \brief OP SHR = (LONG BITS, INT) LONG BITS \param p position in tree **/ void genie_shr_long_mp (NODE_T * p) { A68_INT *j; POP_OPERAND_ADDRESS (p, j, A68_INT); VALUE (j) = -VALUE (j); (void) genie_shl_long_mp (p); /* Conform RR */ } /*! \brief OP <= = (LONG BITS, LONG BITS) BOOL \param p position in tree **/ void genie_le_long_bits (NODE_T * p) { MOID_T *mode = LHS_MODE (p); int k, size = get_mp_size (mode), words = get_mp_bits_words (mode); ADDR_T pop_sp = stack_pointer; BOOL_T result = A68_TRUE; MP_T *u = (MP_T *) STACK_OFFSET (-2 * size), *v = (MP_T *) STACK_OFFSET (-size); unsigned *row_u = stack_mp_bits (p, u, mode), *row_v = stack_mp_bits (p, v, mode); for (k = 0; (k < words) && result; k++) { result = (BOOL_T) (result & ((row_u[k] | row_v[k]) == row_v[k])); } stack_pointer = pop_sp; DECREMENT_STACK_POINTER (p, 2 * size); PUSH_PRIMITIVE (p, (BOOL_T) (result ? A68_TRUE : A68_FALSE), A68_BOOL); } /*! \brief OP >= = (LONG BITS, LONG BITS) BOOL \param p position in tree **/ void genie_ge_long_bits (NODE_T * p) { MOID_T *mode = LHS_MODE (p); int k, size = get_mp_size (mode), words = get_mp_bits_words (mode); ADDR_T pop_sp = stack_pointer; BOOL_T result = A68_TRUE; MP_T *u = (MP_T *) STACK_OFFSET (-2 * size), *v = (MP_T *) STACK_OFFSET (-size); unsigned *row_u = stack_mp_bits (p, u, mode), *row_v = stack_mp_bits (p, v, mode); for (k = 0; (k < words) && result; k++) { result = (BOOL_T) (result & ((row_u[k] | row_v[k]) == row_u[k])); } stack_pointer = pop_sp; DECREMENT_STACK_POINTER (p, 2 * size); PUSH_PRIMITIVE (p, (BOOL_T) (result ? A68_TRUE : A68_FALSE), A68_BOOL); } /*! \brief OP AND = (LONG BITS, LONG BITS) LONG BITS \param p position in tree **/ void genie_and_long_mp (NODE_T * p) { MOID_T *mode = LHS_MODE (p); int k, size = get_mp_size (mode), words = get_mp_bits_words (mode); ADDR_T pop_sp = stack_pointer; MP_T *u = (MP_T *) STACK_OFFSET (-2 * size), *v = (MP_T *) STACK_OFFSET (-size); unsigned *row_u = stack_mp_bits (p, u, mode), *row_v = stack_mp_bits (p, v, mode); for (k = 0; k < words; k++) { row_u[k] &= row_v[k]; } (void) pack_mp_bits (p, u, row_u, mode); stack_pointer = pop_sp; DECREMENT_STACK_POINTER (p, size); } /*! \brief OP OR = (LONG BITS, LONG BITS) LONG BITS \param p position in tree **/ void genie_or_long_mp (NODE_T * p) { MOID_T *mode = LHS_MODE (p); int k, size = get_mp_size (mode), words = get_mp_bits_words (mode); ADDR_T pop_sp = stack_pointer; MP_T *u = (MP_T *) STACK_OFFSET (-2 * size), *v = (MP_T *) STACK_OFFSET (-size); unsigned *row_u = stack_mp_bits (p, u, mode), *row_v = stack_mp_bits (p, v, mode); for (k = 0; k < words; k++) { row_u[k] |= row_v[k]; } (void) pack_mp_bits (p, u, row_u, mode); stack_pointer = pop_sp; DECREMENT_STACK_POINTER (p, size); } /*! \brief OP XOR = (LONG BITS, LONG BITS) LONG BITS \param p position in tree **/ void genie_xor_long_mp (NODE_T * p) { MOID_T *mode = LHS_MODE (p); int k, size = get_mp_size (mode), words = get_mp_bits_words (mode); ADDR_T pop_sp = stack_pointer; MP_T *u = (MP_T *) STACK_OFFSET (-2 * size), *v = (MP_T *) STACK_OFFSET (-size); unsigned *row_u = stack_mp_bits (p, u, mode), *row_v = stack_mp_bits (p, v, mode); for (k = 0; k < words; k++) { row_u[k] ^= row_v[k]; } (void) pack_mp_bits (p, u, row_u, mode); stack_pointer = pop_sp; DECREMENT_STACK_POINTER (p, size); } A68_ENV_REAL (genie_cgs_acre, GSL_CONST_CGSM_ACRE) A68_ENV_REAL (genie_cgs_angstrom, GSL_CONST_CGSM_ANGSTROM) A68_ENV_REAL (genie_cgs_astronomical_unit, GSL_CONST_CGSM_ASTRONOMICAL_UNIT) A68_ENV_REAL (genie_cgs_bar, GSL_CONST_CGSM_BAR) A68_ENV_REAL (genie_cgs_barn, GSL_CONST_CGSM_BARN) A68_ENV_REAL (genie_cgs_bohr_magneton, GSL_CONST_CGSM_BOHR_MAGNETON) A68_ENV_REAL (genie_cgs_bohr_radius, GSL_CONST_CGSM_BOHR_RADIUS) A68_ENV_REAL (genie_cgs_boltzmann, GSL_CONST_CGSM_BOLTZMANN) A68_ENV_REAL (genie_cgs_btu, GSL_CONST_CGSM_BTU) A68_ENV_REAL (genie_cgs_calorie, GSL_CONST_CGSM_CALORIE) A68_ENV_REAL (genie_cgs_canadian_gallon, GSL_CONST_CGSM_CANADIAN_GALLON) A68_ENV_REAL (genie_cgs_carat, GSL_CONST_CGSM_CARAT) A68_ENV_REAL (genie_cgs_cup, GSL_CONST_CGSM_CUP) A68_ENV_REAL (genie_cgs_curie, GSL_CONST_CGSM_CURIE) A68_ENV_REAL (genie_cgs_day, GSL_CONST_CGSM_DAY) A68_ENV_REAL (genie_cgs_dyne, GSL_CONST_CGSM_DYNE) A68_ENV_REAL (genie_cgs_electron_charge, GSL_CONST_CGSM_ELECTRON_CHARGE) A68_ENV_REAL (genie_cgs_electron_magnetic_moment, GSL_CONST_CGSM_ELECTRON_MAGNETIC_MOMENT) A68_ENV_REAL (genie_cgs_electron_volt, GSL_CONST_CGSM_ELECTRON_VOLT) A68_ENV_REAL (genie_cgs_erg, GSL_CONST_CGSM_ERG) A68_ENV_REAL (genie_cgs_faraday, GSL_CONST_CGSM_FARADAY) A68_ENV_REAL (genie_cgs_fathom, GSL_CONST_CGSM_FATHOM) A68_ENV_REAL (genie_cgs_fluid_ounce, GSL_CONST_CGSM_FLUID_OUNCE) A68_ENV_REAL (genie_cgs_foot, GSL_CONST_CGSM_FOOT) A68_ENV_REAL (genie_cgs_footcandle, GSL_CONST_CGSM_FOOTCANDLE) A68_ENV_REAL (genie_cgs_footlambert, GSL_CONST_CGSM_FOOTLAMBERT) A68_ENV_REAL (genie_cgs_gauss, GSL_CONST_CGSM_GAUSS) A68_ENV_REAL (genie_cgs_gram_force, GSL_CONST_CGSM_GRAM_FORCE) A68_ENV_REAL (genie_cgs_grav_accel, GSL_CONST_CGSM_GRAV_ACCEL) A68_ENV_REAL (genie_cgs_gravitational_constant, GSL_CONST_CGSM_GRAVITATIONAL_CONSTANT) A68_ENV_REAL (genie_cgs_hectare, GSL_CONST_CGSM_HECTARE) A68_ENV_REAL (genie_cgs_horsepower, GSL_CONST_CGSM_HORSEPOWER) A68_ENV_REAL (genie_cgs_hour, GSL_CONST_CGSM_HOUR) A68_ENV_REAL (genie_cgs_inch, GSL_CONST_CGSM_INCH) A68_ENV_REAL (genie_cgs_inch_of_mercury, GSL_CONST_CGSM_INCH_OF_MERCURY) A68_ENV_REAL (genie_cgs_inch_of_water, GSL_CONST_CGSM_INCH_OF_WATER) A68_ENV_REAL (genie_cgs_joule, GSL_CONST_CGSM_JOULE) A68_ENV_REAL (genie_cgs_kilometers_per_hour, GSL_CONST_CGSM_KILOMETERS_PER_HOUR) A68_ENV_REAL (genie_cgs_kilopound_force, GSL_CONST_CGSM_KILOPOUND_FORCE) A68_ENV_REAL (genie_cgs_knot, GSL_CONST_CGSM_KNOT) A68_ENV_REAL (genie_cgs_lambert, GSL_CONST_CGSM_LAMBERT) A68_ENV_REAL (genie_cgs_light_year, GSL_CONST_CGSM_LIGHT_YEAR) A68_ENV_REAL (genie_cgs_liter, GSL_CONST_CGSM_LITER) A68_ENV_REAL (genie_cgs_lumen, GSL_CONST_CGSM_LUMEN) A68_ENV_REAL (genie_cgs_lux, GSL_CONST_CGSM_LUX) A68_ENV_REAL (genie_cgs_mass_electron, GSL_CONST_CGSM_MASS_ELECTRON) A68_ENV_REAL (genie_cgs_mass_muon, GSL_CONST_CGSM_MASS_MUON) A68_ENV_REAL (genie_cgs_mass_neutron, GSL_CONST_CGSM_MASS_NEUTRON) A68_ENV_REAL (genie_cgs_mass_proton, GSL_CONST_CGSM_MASS_PROTON) A68_ENV_REAL (genie_cgs_meter_of_mercury, GSL_CONST_CGSM_METER_OF_MERCURY) A68_ENV_REAL (genie_cgs_metric_ton, GSL_CONST_CGSM_METRIC_TON) A68_ENV_REAL (genie_cgs_micron, GSL_CONST_CGSM_MICRON) A68_ENV_REAL (genie_cgs_mil, GSL_CONST_CGSM_MIL) A68_ENV_REAL (genie_cgs_mile, GSL_CONST_CGSM_MILE) A68_ENV_REAL (genie_cgs_miles_per_hour, GSL_CONST_CGSM_MILES_PER_HOUR) A68_ENV_REAL (genie_cgs_minute, GSL_CONST_CGSM_MINUTE) A68_ENV_REAL (genie_cgs_molar_gas, GSL_CONST_CGSM_MOLAR_GAS) A68_ENV_REAL (genie_cgs_nautical_mile, GSL_CONST_CGSM_NAUTICAL_MILE) A68_ENV_REAL (genie_cgs_newton, GSL_CONST_CGSM_NEWTON) A68_ENV_REAL (genie_cgs_nuclear_magneton, GSL_CONST_CGSM_NUCLEAR_MAGNETON) A68_ENV_REAL (genie_cgs_ounce_mass, GSL_CONST_CGSM_OUNCE_MASS) A68_ENV_REAL (genie_cgs_parsec, GSL_CONST_CGSM_PARSEC) A68_ENV_REAL (genie_cgs_phot, GSL_CONST_CGSM_PHOT) A68_ENV_REAL (genie_cgs_pint, GSL_CONST_CGSM_PINT) A68_ENV_REAL (genie_cgs_planck_constant_h, 6.6260693e-27) A68_ENV_REAL (genie_cgs_planck_constant_hbar, 6.6260693e-27 / (2 * A68_PI)) A68_ENV_REAL (genie_cgs_point, GSL_CONST_CGSM_POINT) A68_ENV_REAL (genie_cgs_poise, GSL_CONST_CGSM_POISE) A68_ENV_REAL (genie_cgs_pound_force, GSL_CONST_CGSM_POUND_FORCE) A68_ENV_REAL (genie_cgs_pound_mass, GSL_CONST_CGSM_POUND_MASS) A68_ENV_REAL (genie_cgs_poundal, GSL_CONST_CGSM_POUNDAL) A68_ENV_REAL (genie_cgs_proton_magnetic_moment, GSL_CONST_CGSM_PROTON_MAGNETIC_MOMENT) A68_ENV_REAL (genie_cgs_psi, GSL_CONST_CGSM_PSI) A68_ENV_REAL (genie_cgs_quart, GSL_CONST_CGSM_QUART) A68_ENV_REAL (genie_cgs_rad, GSL_CONST_CGSM_RAD) A68_ENV_REAL (genie_cgs_roentgen, GSL_CONST_CGSM_ROENTGEN) A68_ENV_REAL (genie_cgs_rydberg, GSL_CONST_CGSM_RYDBERG) A68_ENV_REAL (genie_cgs_solar_mass, GSL_CONST_CGSM_SOLAR_MASS) A68_ENV_REAL (genie_cgs_speed_of_light, GSL_CONST_CGSM_SPEED_OF_LIGHT) A68_ENV_REAL (genie_cgs_standard_gas_volume, GSL_CONST_CGSM_STANDARD_GAS_VOLUME) A68_ENV_REAL (genie_cgs_std_atmosphere, GSL_CONST_CGSM_STD_ATMOSPHERE) A68_ENV_REAL (genie_cgs_stilb, GSL_CONST_CGSM_STILB) A68_ENV_REAL (genie_cgs_stokes, GSL_CONST_CGSM_STOKES) A68_ENV_REAL (genie_cgs_tablespoon, GSL_CONST_CGSM_TABLESPOON) A68_ENV_REAL (genie_cgs_teaspoon, GSL_CONST_CGSM_TEASPOON) A68_ENV_REAL (genie_cgs_texpoint, GSL_CONST_CGSM_TEXPOINT) A68_ENV_REAL (genie_cgs_therm, GSL_CONST_CGSM_THERM) A68_ENV_REAL (genie_cgs_ton, GSL_CONST_CGSM_TON) A68_ENV_REAL (genie_cgs_torr, GSL_CONST_CGSM_TORR) A68_ENV_REAL (genie_cgs_troy_ounce, GSL_CONST_CGSM_TROY_OUNCE) A68_ENV_REAL (genie_cgs_uk_gallon, GSL_CONST_CGSM_UK_GALLON) A68_ENV_REAL (genie_cgs_uk_ton, GSL_CONST_CGSM_UK_TON) A68_ENV_REAL (genie_cgs_unified_atomic_mass, GSL_CONST_CGSM_UNIFIED_ATOMIC_MASS) A68_ENV_REAL (genie_cgs_us_gallon, GSL_CONST_CGSM_US_GALLON) A68_ENV_REAL (genie_cgs_week, GSL_CONST_CGSM_WEEK) A68_ENV_REAL (genie_cgs_yard, GSL_CONST_CGSM_YARD) A68_ENV_REAL (genie_mks_acre, GSL_CONST_MKS_ACRE) A68_ENV_REAL (genie_mks_angstrom, GSL_CONST_MKS_ANGSTROM) A68_ENV_REAL (genie_mks_astronomical_unit, GSL_CONST_MKS_ASTRONOMICAL_UNIT) A68_ENV_REAL (genie_mks_bar, GSL_CONST_MKS_BAR) A68_ENV_REAL (genie_mks_barn, GSL_CONST_MKS_BARN) A68_ENV_REAL (genie_mks_bohr_magneton, GSL_CONST_MKS_BOHR_MAGNETON) A68_ENV_REAL (genie_mks_bohr_radius, GSL_CONST_MKS_BOHR_RADIUS) A68_ENV_REAL (genie_mks_boltzmann, GSL_CONST_MKS_BOLTZMANN) A68_ENV_REAL (genie_mks_btu, GSL_CONST_MKS_BTU) A68_ENV_REAL (genie_mks_calorie, GSL_CONST_MKS_CALORIE) A68_ENV_REAL (genie_mks_canadian_gallon, GSL_CONST_MKS_CANADIAN_GALLON) A68_ENV_REAL (genie_mks_carat, GSL_CONST_MKS_CARAT) A68_ENV_REAL (genie_mks_cup, GSL_CONST_MKS_CUP) A68_ENV_REAL (genie_mks_curie, GSL_CONST_MKS_CURIE) A68_ENV_REAL (genie_mks_day, GSL_CONST_MKS_DAY) A68_ENV_REAL (genie_mks_dyne, GSL_CONST_MKS_DYNE) A68_ENV_REAL (genie_mks_electron_charge, GSL_CONST_MKS_ELECTRON_CHARGE) A68_ENV_REAL (genie_mks_electron_magnetic_moment, GSL_CONST_MKS_ELECTRON_MAGNETIC_MOMENT) A68_ENV_REAL (genie_mks_electron_volt, GSL_CONST_MKS_ELECTRON_VOLT) A68_ENV_REAL (genie_mks_erg, GSL_CONST_MKS_ERG) A68_ENV_REAL (genie_mks_faraday, GSL_CONST_MKS_FARADAY) A68_ENV_REAL (genie_mks_fathom, GSL_CONST_MKS_FATHOM) A68_ENV_REAL (genie_mks_fluid_ounce, GSL_CONST_MKS_FLUID_OUNCE) A68_ENV_REAL (genie_mks_foot, GSL_CONST_MKS_FOOT) A68_ENV_REAL (genie_mks_footcandle, GSL_CONST_MKS_FOOTCANDLE) A68_ENV_REAL (genie_mks_footlambert, GSL_CONST_MKS_FOOTLAMBERT) A68_ENV_REAL (genie_mks_gauss, GSL_CONST_MKS_GAUSS) A68_ENV_REAL (genie_mks_gram_force, GSL_CONST_MKS_GRAM_FORCE) A68_ENV_REAL (genie_mks_grav_accel, GSL_CONST_MKS_GRAV_ACCEL) A68_ENV_REAL (genie_mks_gravitational_constant, GSL_CONST_MKS_GRAVITATIONAL_CONSTANT) A68_ENV_REAL (genie_mks_hectare, GSL_CONST_MKS_HECTARE) A68_ENV_REAL (genie_mks_horsepower, GSL_CONST_MKS_HORSEPOWER) A68_ENV_REAL (genie_mks_hour, GSL_CONST_MKS_HOUR) A68_ENV_REAL (genie_mks_inch, GSL_CONST_MKS_INCH) A68_ENV_REAL (genie_mks_inch_of_mercury, GSL_CONST_MKS_INCH_OF_MERCURY) A68_ENV_REAL (genie_mks_inch_of_water, GSL_CONST_MKS_INCH_OF_WATER) A68_ENV_REAL (genie_mks_joule, GSL_CONST_MKS_JOULE) A68_ENV_REAL (genie_mks_kilometers_per_hour, GSL_CONST_MKS_KILOMETERS_PER_HOUR) A68_ENV_REAL (genie_mks_kilopound_force, GSL_CONST_MKS_KILOPOUND_FORCE) A68_ENV_REAL (genie_mks_knot, GSL_CONST_MKS_KNOT) A68_ENV_REAL (genie_mks_lambert, GSL_CONST_MKS_LAMBERT) A68_ENV_REAL (genie_mks_light_year, GSL_CONST_MKS_LIGHT_YEAR) A68_ENV_REAL (genie_mks_liter, GSL_CONST_MKS_LITER) A68_ENV_REAL (genie_mks_lumen, GSL_CONST_MKS_LUMEN) A68_ENV_REAL (genie_mks_lux, GSL_CONST_MKS_LUX) A68_ENV_REAL (genie_mks_mass_electron, GSL_CONST_MKS_MASS_ELECTRON) A68_ENV_REAL (genie_mks_mass_muon, GSL_CONST_MKS_MASS_MUON) A68_ENV_REAL (genie_mks_mass_neutron, GSL_CONST_MKS_MASS_NEUTRON) A68_ENV_REAL (genie_mks_mass_proton, GSL_CONST_MKS_MASS_PROTON) A68_ENV_REAL (genie_mks_meter_of_mercury, GSL_CONST_MKS_METER_OF_MERCURY) A68_ENV_REAL (genie_mks_metric_ton, GSL_CONST_MKS_METRIC_TON) A68_ENV_REAL (genie_mks_micron, GSL_CONST_MKS_MICRON) A68_ENV_REAL (genie_mks_mil, GSL_CONST_MKS_MIL) A68_ENV_REAL (genie_mks_mile, GSL_CONST_MKS_MILE) A68_ENV_REAL (genie_mks_miles_per_hour, GSL_CONST_MKS_MILES_PER_HOUR) A68_ENV_REAL (genie_mks_minute, GSL_CONST_MKS_MINUTE) A68_ENV_REAL (genie_mks_molar_gas, GSL_CONST_MKS_MOLAR_GAS) A68_ENV_REAL (genie_mks_nautical_mile, GSL_CONST_MKS_NAUTICAL_MILE) A68_ENV_REAL (genie_mks_newton, GSL_CONST_MKS_NEWTON) A68_ENV_REAL (genie_mks_nuclear_magneton, GSL_CONST_MKS_NUCLEAR_MAGNETON) A68_ENV_REAL (genie_mks_ounce_mass, GSL_CONST_MKS_OUNCE_MASS) A68_ENV_REAL (genie_mks_parsec, GSL_CONST_MKS_PARSEC) A68_ENV_REAL (genie_mks_phot, GSL_CONST_MKS_PHOT) A68_ENV_REAL (genie_mks_pint, GSL_CONST_MKS_PINT) A68_ENV_REAL (genie_mks_planck_constant_h, 6.6260693e-34) A68_ENV_REAL (genie_mks_planck_constant_hbar, 6.6260693e-34 / (2 * A68_PI)) A68_ENV_REAL (genie_mks_point, GSL_CONST_MKS_POINT) A68_ENV_REAL (genie_mks_poise, GSL_CONST_MKS_POISE) A68_ENV_REAL (genie_mks_pound_force, GSL_CONST_MKS_POUND_FORCE) A68_ENV_REAL (genie_mks_pound_mass, GSL_CONST_MKS_POUND_MASS) A68_ENV_REAL (genie_mks_poundal, GSL_CONST_MKS_POUNDAL) A68_ENV_REAL (genie_mks_proton_magnetic_moment, GSL_CONST_MKS_PROTON_MAGNETIC_MOMENT) A68_ENV_REAL (genie_mks_psi, GSL_CONST_MKS_PSI) A68_ENV_REAL (genie_mks_quart, GSL_CONST_MKS_QUART) A68_ENV_REAL (genie_mks_rad, GSL_CONST_MKS_RAD) A68_ENV_REAL (genie_mks_roentgen, GSL_CONST_MKS_ROENTGEN) A68_ENV_REAL (genie_mks_rydberg, GSL_CONST_MKS_RYDBERG) A68_ENV_REAL (genie_mks_solar_mass, GSL_CONST_MKS_SOLAR_MASS) A68_ENV_REAL (genie_mks_speed_of_light, GSL_CONST_MKS_SPEED_OF_LIGHT) A68_ENV_REAL (genie_mks_standard_gas_volume, GSL_CONST_MKS_STANDARD_GAS_VOLUME) A68_ENV_REAL (genie_mks_std_atmosphere, GSL_CONST_MKS_STD_ATMOSPHERE) A68_ENV_REAL (genie_mks_stilb, GSL_CONST_MKS_STILB) A68_ENV_REAL (genie_mks_stokes, GSL_CONST_MKS_STOKES) A68_ENV_REAL (genie_mks_tablespoon, GSL_CONST_MKS_TABLESPOON) A68_ENV_REAL (genie_mks_teaspoon, GSL_CONST_MKS_TEASPOON) A68_ENV_REAL (genie_mks_texpoint, GSL_CONST_MKS_TEXPOINT) A68_ENV_REAL (genie_mks_therm, GSL_CONST_MKS_THERM) A68_ENV_REAL (genie_mks_ton, GSL_CONST_MKS_TON) A68_ENV_REAL (genie_mks_torr, GSL_CONST_MKS_TORR) A68_ENV_REAL (genie_mks_troy_ounce, GSL_CONST_MKS_TROY_OUNCE) A68_ENV_REAL (genie_mks_uk_gallon, GSL_CONST_MKS_UK_GALLON) A68_ENV_REAL (genie_mks_uk_ton, GSL_CONST_MKS_UK_TON) A68_ENV_REAL (genie_mks_unified_atomic_mass, GSL_CONST_MKS_UNIFIED_ATOMIC_MASS) A68_ENV_REAL (genie_mks_us_gallon, GSL_CONST_MKS_US_GALLON) A68_ENV_REAL (genie_mks_vacuum_permeability, GSL_CONST_MKS_VACUUM_PERMEABILITY) A68_ENV_REAL (genie_mks_vacuum_permittivity, GSL_CONST_MKS_VACUUM_PERMITTIVITY) A68_ENV_REAL (genie_mks_week, GSL_CONST_MKS_WEEK) A68_ENV_REAL (genie_mks_yard, GSL_CONST_MKS_YARD) A68_ENV_REAL (genie_num_atto, GSL_CONST_NUM_ATTO) A68_ENV_REAL (genie_num_avogadro, GSL_CONST_NUM_AVOGADRO) A68_ENV_REAL (genie_num_exa, GSL_CONST_NUM_EXA) A68_ENV_REAL (genie_num_femto, GSL_CONST_NUM_FEMTO) A68_ENV_REAL (genie_num_fine_structure, GSL_CONST_NUM_FINE_STRUCTURE) A68_ENV_REAL (genie_num_giga, GSL_CONST_NUM_GIGA) A68_ENV_REAL (genie_num_kilo, GSL_CONST_NUM_KILO) A68_ENV_REAL (genie_num_mega, GSL_CONST_NUM_MEGA) A68_ENV_REAL (genie_num_micro, GSL_CONST_NUM_MICRO) A68_ENV_REAL (genie_num_milli, GSL_CONST_NUM_MILLI) A68_ENV_REAL (genie_num_nano, GSL_CONST_NUM_NANO) A68_ENV_REAL (genie_num_peta, GSL_CONST_NUM_PETA) A68_ENV_REAL (genie_num_pico, GSL_CONST_NUM_PICO) A68_ENV_REAL (genie_num_tera, GSL_CONST_NUM_TERA) A68_ENV_REAL (genie_num_yocto, GSL_CONST_NUM_YOCTO) A68_ENV_REAL (genie_num_yotta, GSL_CONST_NUM_YOTTA) A68_ENV_REAL (genie_num_zepto, GSL_CONST_NUM_ZEPTO) A68_ENV_REAL (genie_num_zetta, GSL_CONST_NUM_ZETTA) /* Macros */ #define C_FUNCTION(p, f)\ A68_REAL *x;\ POP_OPERAND_ADDRESS (p, x, A68_REAL);\ RESET_ERRNO;\ VALUE (x) = f (VALUE (x));\ MATH_RTE (p, errno != 0, MODE (REAL), NO_TEXT); #define OWN_FUNCTION(p, f)\ A68_REAL *x;\ POP_OPERAND_ADDRESS (p, x, A68_REAL);\ RESET_ERRNO;\ VALUE (x) = f (p, VALUE (x));\ MATH_RTE (p, errno != 0, MODE (REAL), NO_TEXT); #define GSL_FUNCTION(p, f)\ A68_REAL *x;\ POP_OPERAND_ADDRESS (p, x, A68_REAL);\ RESET_ERRNO;\ VALUE (x) = f (VALUE (x));\ MATH_RTE (p, errno != 0, MODE (REAL), NO_TEXT); #define GSL_COMPLEX_FUNCTION(f)\ gsl_complex x, z;\ A68_REAL *rex, *imx;\ imx = (A68_REAL *) (STACK_OFFSET (-ALIGNED_SIZE_OF (A68_REAL)));\ rex = (A68_REAL *) (STACK_OFFSET (-2 * ALIGNED_SIZE_OF (A68_REAL)));\ GSL_SET_COMPLEX (&x, VALUE (rex), VALUE (imx));\ (void) gsl_set_error_handler_off ();\ RESET_ERRNO;\ z = f (x);\ MATH_RTE (p, errno != 0, MODE (COMPLEX), NO_TEXT);\ VALUE (imx) = GSL_IMAG(z);\ VALUE (rex) = GSL_REAL(z) #define GSL_1_FUNCTION(p, f)\ A68_REAL *x;\ gsl_sf_result y;\ int status;\ POP_OPERAND_ADDRESS (p, x, A68_REAL);\ (void) gsl_set_error_handler_off ();\ status = f (VALUE (x), &y);\ MATH_RTE (p, status != 0, MODE (REAL), (char *) gsl_strerror (status));\ VALUE (x) = VAL (&y) #define GSL_2_FUNCTION(p, f)\ A68_REAL *x, *y;\ gsl_sf_result r;\ int status;\ POP_OPERAND_ADDRESSES (p, x, y, A68_REAL);\ (void) gsl_set_error_handler_off ();\ status = f (VALUE (x), VALUE (y), &r);\ MATH_RTE (p, status != 0, MODE (REAL), (char *) gsl_strerror (status));\ VALUE (x) = VAL (&r) #define GSL_2_INT_FUNCTION(p, f)\ A68_REAL *x, *y;\ gsl_sf_result r;\ int status;\ POP_OPERAND_ADDRESSES (p, x, y, A68_REAL);\ (void) gsl_set_error_handler_off ();\ status = f ((int) VALUE (x), VALUE (y), &r);\ MATH_RTE (p, status != 0, MODE (REAL), (char *) gsl_strerror (status));\ VALUE (x) = VAL (&r) #define GSL_3_FUNCTION(p, f)\ A68_REAL *x, *y, *z;\ gsl_sf_result r;\ int status;\ POP_ADDRESS (p, z, A68_REAL);\ POP_OPERAND_ADDRESSES (p, x, y, A68_REAL);\ (void) gsl_set_error_handler_off ();\ status = f (VALUE (x), VALUE (y), VALUE (z), &r);\ MATH_RTE (p, status != 0, MODE (REAL), (char *) gsl_strerror (status));\ VALUE (x) = VAL (&r) #define GSL_1D_FUNCTION(p, f)\ A68_REAL *x;\ gsl_sf_result y;\ int status;\ POP_OPERAND_ADDRESS (p, x, A68_REAL);\ (void) gsl_set_error_handler_off ();\ status = f (VALUE (x), GSL_PREC_DOUBLE, &y);\ MATH_RTE (p, status != 0, MODE (REAL), (char *) gsl_strerror (status));\ VALUE (x) = VAL (&y) #define GSL_2D_FUNCTION(p, f)\ A68_REAL *x, *y;\ gsl_sf_result r;\ int status;\ POP_OPERAND_ADDRESSES (p, x, y, A68_REAL);\ (void) gsl_set_error_handler_off ();\ status = f (VALUE (x), VALUE (y), GSL_PREC_DOUBLE, &r);\ MATH_RTE (p, status != 0, MODE (REAL), (char *) gsl_strerror (status));\ VALUE (x) = VAL (&r) #define GSL_3D_FUNCTION(p, f)\ A68_REAL *x, *y, *z;\ gsl_sf_result r;\ int status;\ POP_ADDRESS (p, z, A68_REAL);\ POP_OPERAND_ADDRESSES (p, x, y, A68_REAL);\ (void) gsl_set_error_handler_off ();\ status = f (VALUE (x), VALUE (y), VALUE (z), GSL_PREC_DOUBLE, &r);\ MATH_RTE (p, status != 0, MODE (REAL), (char *) gsl_strerror (status));\ VALUE (x) = VAL (&r) #define GSL_4D_FUNCTION(p, f)\ A68_REAL *x, *y, *z, *rho;\ gsl_sf_result r;\ int status;\ POP_ADDRESS (p, rho, A68_REAL);\ POP_ADDRESS (p, z, A68_REAL);\ POP_OPERAND_ADDRESSES (p, x, y, A68_REAL);\ (void) gsl_set_error_handler_off ();\ status = f (VALUE (x), VALUE (y), VALUE (z), VALUE (rho), GSL_PREC_DOUBLE, &r);\ MATH_RTE (p, status != 0, MODE (REAL), (char *) gsl_strerror (status));\ VALUE (x) = VAL (&r) /*! \brief the cube root of x \param x x \return same **/ double curt (double x) { #define CBRT2 1.2599210498948731647672; #define CBRT4 1.5874010519681994747517; int expo, sign; double z, x0; static double y[11] = { 7.937005259840997e-01, 8.193212706006459e-01, 8.434326653017493e-01, 8.662391053409029e-01, 8.879040017426008e-01, 9.085602964160699e-01, 9.283177667225558e-01, 9.472682371859097e-01, 9.654893846056298e-01, 9.830475724915586e-01, 1.0 }; if (x == 0.0 || x == 1.0) { return (x); } if (x > 0.0) { sign = 1; } else { sign = -1; x = -x; } x = frexp (x, &expo); /* Cube root in [0.5, 1] by Newton's method */ z = x; x = y[(int) (20 * x - 10)]; x0 = 0; while (ABS (x - x0) > DBL_EPSILON) { x0 = x; x = (z / (x * x) + x + x) / 3; } /* Get exponent */ if (expo >= 0) { int j = expo % 3; if (j == 1) { x *= CBRT2; } else if (j == 2) { x *= CBRT4; } expo /= 3; } else { int j = (-expo) % 3; if (j == 1) { x /= CBRT2; } else if (j == 2) { x /= CBRT4; } expo = -(-expo) / 3; } x = ldexp (x, expo); return (sign >= 0 ? x : -x); } /*! \brief inverse complementary error function \param y y \return same **/ double inverfc (double y) { if (y < 0.0 || y > 2.0) { errno = EDOM; return (0.0); } else if (y == 0.0) { return (DBL_MAX); } else if (y == 1.0) { return (0.0); } else if (y == 2.0) { return (-DBL_MAX); } else { /* Next is adapted code from a package that contains following statement: Copyright (c) 1996 Takuya Ooura. You may use, copy, modify this code for any purpose and without fee */ double s, t, u, v, x, z; if (y <= 1.0) { z = y; } else { z = 2.0 - y; } v = 0.916461398268964 - log (z); u = sqrt (v); s = (log (u) + 0.488826640273108) / v; t = 1.0 / (u + 0.231729200323405); x = u * (1.0 - s * (s * 0.124610454613712 + 0.5)) - ((((-0.0728846765585675 * t + 0.269999308670029) * t + 0.150689047360223) * t + 0.116065025341614) * t + 0.499999303439796) * t; t = 3.97886080735226 / (x + 3.97886080735226); u = t - 0.5; s = (((((((((0.00112648096188977922 * u + 1.05739299623423047e-4) * u - 0.00351287146129100025) * u - 7.71708358954120939e-4) * u + 0.00685649426074558612) * u + 0.00339721910367775861) * u - 0.011274916933250487) * u - 0.0118598117047771104) * u + 0.0142961988697898018) * u + 0.0346494207789099922) * u + 0.00220995927012179067; s = ((((((((((((s * u - 0.0743424357241784861) * u - 0.105872177941595488) * u + 0.0147297938331485121) * u + 0.316847638520135944) * u + 0.713657635868730364) * u + 1.05375024970847138) * u + 1.21448730779995237) * u + 1.16374581931560831) * u + 0.956464974744799006) * u + 0.686265948274097816) * u + 0.434397492331430115) * u + 0.244044510593190935) * t - z * exp (x * x - 0.120782237635245222); x += s * (x * s + 1.0); return (y <= 1.0 ? x : -x); } } /*! \brief inverse error function \param y y \return same **/ double inverf (double y) { return (inverfc (1 - y)); } /*! \brief PROC sqrt = (REAL) REAL \param p position in tree **/ void genie_sqrt_real (NODE_T * p) { C_FUNCTION (p, sqrt); } /*! \brief PROC curt = (REAL) REAL \param p position in tree **/ void genie_curt_real (NODE_T * p) { C_FUNCTION (p, curt); } /*! \brief PROC exp = (REAL) REAL \param p position in tree **/ void genie_exp_real (NODE_T * p) { C_FUNCTION (p, a68g_exp); } /*! \brief PROC ln = (REAL) REAL \param p position in tree **/ void genie_ln_real (NODE_T * p) { C_FUNCTION (p, log); } /*! \brief PROC log = (REAL) REAL \param p position in tree **/ void genie_log_real (NODE_T * p) { C_FUNCTION (p, log10); } /*! \brief PROC sin = (REAL) REAL \param p position in tree **/ void genie_sin_real (NODE_T * p) { C_FUNCTION (p, sin); } /*! \brief PROC arcsin = (REAL) REAL \param p position in tree **/ void genie_arcsin_real (NODE_T * p) { C_FUNCTION (p, asin); } /*! \brief PROC cos = (REAL) REAL \param p position in tree **/ void genie_cos_real (NODE_T * p) { C_FUNCTION (p, cos); } /*! \brief PROC arccos = (REAL) REAL \param p position in tree **/ void genie_arccos_real (NODE_T * p) { C_FUNCTION (p, acos); } /*! \brief PROC tan = (REAL) REAL \param p position in tree **/ void genie_tan_real (NODE_T * p) { C_FUNCTION (p, tan); } /*! \brief PROC arctan = (REAL) REAL \param p position in tree **/ void genie_arctan_real (NODE_T * p) { C_FUNCTION (p, atan); } /*! \brief PROC arctan2 = (REAL) REAL \param p position in tree **/ void genie_atan2_real (NODE_T * p) { A68_REAL *x, *y; POP_OPERAND_ADDRESSES (p, x, y, A68_REAL); RESET_ERRNO; PRELUDE_ERROR (VALUE (x) == 0.0 && VALUE (y) == 0.0, p, ERROR_INVALID_ARGUMENT, MODE (LONG_REAL)); VALUE (x) = a68g_atan2 (VALUE (y), VALUE (x)); PRELUDE_ERROR (errno != 0, p, ERROR_MATH_EXCEPTION, NO_TEXT); } /*! \brief PROC sinh = (REAL) REAL \param p position in tree **/ void genie_sinh_real (NODE_T * p) { C_FUNCTION (p, sinh); } /*! \brief PROC cosh = (REAL) REAL \param p position in tree **/ void genie_cosh_real (NODE_T * p) { C_FUNCTION (p, cosh); } /*! \brief PROC tanh = (REAL) REAL \param p position in tree **/ void genie_tanh_real (NODE_T * p) { C_FUNCTION (p, tanh); } /*! \brief PROC arcsinh = (REAL) REAL \param p position in tree **/ void genie_arcsinh_real (NODE_T * p) { C_FUNCTION (p, a68g_asinh); } /*! \brief PROC arccosh = (REAL) REAL \param p position in tree **/ void genie_arccosh_real (NODE_T * p) { C_FUNCTION (p, a68g_acosh); } /*! \brief PROC arctanh = (REAL) REAL \param p position in tree **/ void genie_arctanh_real (NODE_T * p) { C_FUNCTION (p, a68g_atanh); } /*! \brief PROC inverse erf = (REAL) REAL \param p position in tree **/ void genie_inverf_real (NODE_T * p) { C_FUNCTION (p, inverf); } /*! \brief PROC inverse erfc = (REAL) REAL \param p position in tree **/ void genie_inverfc_real (NODE_T * p) { C_FUNCTION (p, inverfc); } /*! \brief PROC lj e 12 6 = (REAL, REAL, REAL) REAL \param p position in tree **/ void genie_lj_e_12_6 (NODE_T * p) { A68_REAL *e, *s, *r; double u, u2, u6; POP_3_OPERAND_ADDRESSES (p, e, s, r, A68_REAL); u = (VALUE (s) / VALUE (r)); u2 = u * u; u6 = u2 * u2 * u2; VALUE (e) = 4.0 * VALUE (e) * u6 * (u6 - 1.0); } /*! \brief PROC lj f 12 6 = (REAL, REAL, REAL) REAL \param p position in tree **/ void genie_lj_f_12_6 (NODE_T * p) { A68_REAL *e, *s, *r; double u, u2, u6; POP_3_OPERAND_ADDRESSES (p, e, s, r, A68_REAL); u = (VALUE (s) / VALUE (r)); u2 = u * u; u6 = u2 * u2 * u2; VALUE (e) = 24.0 * VALUE (e) * u * u6 * (1.0 - 2.0 * u6); } #if defined HAVE_GNU_GSL /* "Special" functions - but what is so "special" about them? */ /*! \brief PROC erf = (REAL) REAL \param p position in tree **/ void genie_erf_real (NODE_T * p) { GSL_1_FUNCTION (p, gsl_sf_erf_e); } /*! \brief PROC erfc = (REAL) REAL \param p position in tree **/ void genie_erfc_real (NODE_T * p) { GSL_1_FUNCTION (p, gsl_sf_erfc_e); } /*! \brief PROC gamma = (REAL) REAL \param p position in tree **/ void genie_gamma_real (NODE_T * p) { GSL_1_FUNCTION (p, gsl_sf_gamma_e); } /*! \brief PROC gamma incomplete = (REAL, REAL) REAL \param p position in tree **/ void genie_gamma_inc_real (NODE_T * p) { GSL_2_FUNCTION (p, gsl_sf_gamma_inc_P_e); } /*! \brief PROC lngamma = (REAL) REAL \param p position in tree **/ void genie_lngamma_real (NODE_T * p) { GSL_1_FUNCTION (p, gsl_sf_lngamma_e); } /*! \brief PROC factorial = (REAL) REAL \param p position in tree **/ void genie_factorial_real (NODE_T * p) { /* gsl_sf_fact reduces argument to int, hence we do gamma (x + 1) */ A68_REAL *z = (A68_REAL *) STACK_OFFSET (-ALIGNED_SIZE_OF (A68_REAL)); VALUE (z) += 1.0; { GSL_1_FUNCTION (p, gsl_sf_gamma_e); } } /*! \brief PROC beta = (REAL, REAL) REAL \param p position in tree **/ void genie_beta_real (NODE_T * p) { GSL_2_FUNCTION (p, gsl_sf_beta_e); } /*! \brief PROC beta incomplete = (REAL, REAL, REAL) REAL \param p position in tree **/ void genie_beta_inc_real (NODE_T * p) { GSL_3_FUNCTION (p, gsl_sf_beta_inc_e); } /*! \brief PROC airy ai = (REAL) REAL \param p position in tree **/ void genie_airy_ai_real (NODE_T * p) { GSL_1D_FUNCTION (p, gsl_sf_airy_Ai_e); } /*! \brief PROC airy bi = (REAL) REAL \param p position in tree **/ void genie_airy_bi_real (NODE_T * p) { GSL_1D_FUNCTION (p, gsl_sf_airy_Bi_e); } /*! \brief PROC airy ai derivative = (REAL) REAL \param p position in tree **/ void genie_airy_ai_deriv_real (NODE_T * p) { GSL_1D_FUNCTION (p, gsl_sf_airy_Ai_deriv_e); } /*! \brief PROC airy bi derivative = (REAL) REAL \param p position in tree **/ void genie_airy_bi_deriv_real (NODE_T * p) { GSL_1D_FUNCTION (p, gsl_sf_airy_Bi_deriv_e); } /*! \brief PROC bessel jn = (REAL, REAL) REAL \param p position in tree **/ void genie_bessel_jn_real (NODE_T * p) { GSL_2_INT_FUNCTION (p, gsl_sf_bessel_Jn_e); } /*! \brief PROC bessel yn = (REAL, REAL) REAL \param p position in tree **/ void genie_bessel_yn_real (NODE_T * p) { GSL_2_INT_FUNCTION (p, gsl_sf_bessel_Yn_e); } /*! \brief PROC bessel in = (REAL, REAL) REAL \param p position in tree **/ void genie_bessel_in_real (NODE_T * p) { GSL_2_INT_FUNCTION (p, gsl_sf_bessel_In_e); } /*! \brief PROC bessel exp in = (REAL, REAL) REAL \param p position in tree **/ void genie_bessel_exp_in_real (NODE_T * p) { GSL_2_INT_FUNCTION (p, gsl_sf_bessel_In_scaled_e); } /*! \brief PROC bessel kn = (REAL, REAL) REAL \param p position in tree **/ void genie_bessel_kn_real (NODE_T * p) { GSL_2_INT_FUNCTION (p, gsl_sf_bessel_Kn_e); } /*! \brief PROC bessel exp kn = (REAL, REAL) REAL \param p position in tree **/ void genie_bessel_exp_kn_real (NODE_T * p) { GSL_2_INT_FUNCTION (p, gsl_sf_bessel_Kn_scaled_e); } /*! \brief PROC bessel jl = (REAL, REAL) REAL \param p position in tree **/ void genie_bessel_jl_real (NODE_T * p) { GSL_2_INT_FUNCTION (p, gsl_sf_bessel_jl_e); } /*! \brief PROC bessel yl = (REAL, REAL) REAL \param p position in tree **/ void genie_bessel_yl_real (NODE_T * p) { GSL_2_INT_FUNCTION (p, gsl_sf_bessel_yl_e); } /*! \brief PROC bessel exp il = (REAL, REAL) REAL \param p position in tree **/ void genie_bessel_exp_il_real (NODE_T * p) { GSL_2_INT_FUNCTION (p, gsl_sf_bessel_il_scaled_e); } /*! \brief PROC bessel exp kl = (REAL, REAL) REAL \param p position in tree **/ void genie_bessel_exp_kl_real (NODE_T * p) { GSL_2_INT_FUNCTION (p, gsl_sf_bessel_kl_scaled_e); } /*! \brief PROC bessel jnu = (REAL, REAL) REAL \param p position in tree **/ void genie_bessel_jnu_real (NODE_T * p) { GSL_2_FUNCTION (p, gsl_sf_bessel_Jnu_e); } /*! \brief PROC bessel ynu = (REAL, REAL) REAL \param p position in tree **/ void genie_bessel_ynu_real (NODE_T * p) { GSL_2_FUNCTION (p, gsl_sf_bessel_Ynu_e); } /*! \brief PROC bessel inu = (REAL, REAL) REAL \param p position in tree **/ void genie_bessel_inu_real (NODE_T * p) { GSL_2_FUNCTION (p, gsl_sf_bessel_Inu_e); } /*! \brief PROC bessel exp inu = (REAL, REAL) REAL \param p position in tree **/ void genie_bessel_exp_inu_real (NODE_T * p) { GSL_2_FUNCTION (p, gsl_sf_bessel_Inu_scaled_e); } /*! \brief PROC bessel knu = (REAL, REAL) REAL \param p position in tree **/ void genie_bessel_knu_real (NODE_T * p) { GSL_2_FUNCTION (p, gsl_sf_bessel_Knu_e); } /*! \brief PROC bessel exp knu = (REAL, REAL) REAL \param p position in tree **/ void genie_bessel_exp_knu_real (NODE_T * p) { GSL_2_FUNCTION (p, gsl_sf_bessel_Knu_scaled_e); } /*! \brief PROC elliptic integral k = (REAL) REAL \param p position in tree **/ void genie_elliptic_integral_k_real (NODE_T * p) { GSL_1D_FUNCTION (p, gsl_sf_ellint_Kcomp_e); } /*! \brief PROC elliptic integral e = (REAL) REAL \param p position in tree **/ void genie_elliptic_integral_e_real (NODE_T * p) { GSL_1D_FUNCTION (p, gsl_sf_ellint_Ecomp_e); } /*! \brief PROC elliptic integral rf = (REAL, REAL, REAL) REAL \param p position in tree **/ void genie_elliptic_integral_rf_real (NODE_T * p) { GSL_3D_FUNCTION (p, gsl_sf_ellint_RF_e); } /*! \brief PROC elliptic integral rd = (REAL, REAL, REAL) REAL \param p position in tree **/ void genie_elliptic_integral_rd_real (NODE_T * p) { GSL_3D_FUNCTION (p, gsl_sf_ellint_RD_e); } /*! \brief PROC elliptic integral rj = (REAL, REAL, REAL, REAL) REAL \param p position in tree **/ void genie_elliptic_integral_rj_real (NODE_T * p) { GSL_4D_FUNCTION (p, gsl_sf_ellint_RJ_e); } /*! \brief PROC elliptic integral rc = (REAL, REAL) REAL \param p position in tree **/ void genie_elliptic_integral_rc_real (NODE_T * p) { GSL_2D_FUNCTION (p, gsl_sf_ellint_RC_e); } #endif /* Next part is a "stand-alone" version of GNU Scientific Library (GSL) random number generator "taus113", based on GSL file "rng/taus113.c" that has the notice: Copyright (C) 2002 Atakan Gurkan Based on the file taus.c which has the notice Copyright (C) 1996, 1997, 1998, 1999, 2000 James Theiler, Brian Gough. This is a maximally equidistributed combined, collision free Tausworthe generator, with a period ~2^113 (~10^34). The sequence is x_n = (z1_n ^ z2_n ^ z3_n ^ z4_n) b = (((z1_n << 6) ^ z1_n) >> 13) z1_{n+1} = (((z1_n & 4294967294) << 18) ^ b) b = (((z2_n << 2) ^ z2_n) >> 27) z2_{n+1} = (((z2_n & 4294967288) << 2) ^ b) b = (((z3_n << 13) ^ z3_n) >> 21) z3_{n+1} = (((z3_n & 4294967280) << 7) ^ b) b = (((z4_n << 3) ^ z4_n) >> 12) z4_{n+1} = (((z4_n & 4294967168) << 13) ^ b) computed modulo 2^32. In the formulas above '^' means exclusive-or (C-notation), not exponentiation. The algorithm is for 32-bit integers, hence a bitmask is used to clear all but least significant 32 bits, after left shifts, to make the code work on architectures where integers are 64-bit. The generator is initialized with zi = (69069 * z{i+1}) MOD 2^32 where z0 is the seed provided During initialization a check is done to make sure that the initial seeds have a required number of their most significant bits set. After this, the state is passed through the RNG 10 times to ensure the state satisfies a recurrence relation. References: P. L'Ecuyer, "Tables of Maximally-Equidistributed Combined LFSR Generators", Mathematics of Computation, 68, 225 (1999), 261--269. http://www.iro.umontreal.ca/~lecuyer/myftp/papers/tausme2.ps P. L'Ecuyer, "Maximally Equidistributed Combined Tausworthe Generators", Mathematics of Computation, 65, 213 (1996), 203--213. http://www.iro.umontreal.ca/~lecuyer/myftp/papers/tausme.ps the online version of the latter contains corrections to the print version. */ #define LCG(n) ((69069UL * n) & 0xffffffffUL) #define TAUSWORTHE_MASK 0xffffffffUL #define Z1(p) ((p)->z1) #define Z2(p) ((p)->z2) #define Z3(p) ((p)->z3) #define Z4(p) ((p)->z4) typedef struct { unsigned long int z1, z2, z3, z4; } taus113_state_t; static taus113_state_t rng_state; static unsigned long int taus113_get (taus113_state_t * state); static void taus113_set (taus113_state_t * state, unsigned long int s); /*! \brief taus113_get \param state state \return same **/ static unsigned long taus113_get (taus113_state_t * state) { unsigned long b1, b2, b3, b4; b1 = ((((Z1 (state) << 6UL) & TAUSWORTHE_MASK) ^ Z1 (state)) >> 13UL); Z1 (state) = ((((Z1 (state) & 4294967294UL) << 18UL) & TAUSWORTHE_MASK) ^ b1); b2 = ((((Z2 (state) << 2UL) & TAUSWORTHE_MASK) ^ Z2 (state)) >> 27UL); Z2 (state) = ((((Z2 (state) & 4294967288UL) << 2UL) & TAUSWORTHE_MASK) ^ b2); b3 = ((((Z3 (state) << 13UL) & TAUSWORTHE_MASK) ^ Z3 (state)) >> 21UL); Z3 (state) = ((((Z3 (state) & 4294967280UL) << 7UL) & TAUSWORTHE_MASK) ^ b3); b4 = ((((Z4 (state) << 3UL) & TAUSWORTHE_MASK) ^ Z4 (state)) >> 12UL); Z4 (state) = ((((Z4 (state) & 4294967168UL) << 13UL) & TAUSWORTHE_MASK) ^ b4); return (Z1 (state) ^ Z2 (state) ^ Z3 (state) ^ Z4 (state)); } /*! \brief taus113_set \param state state \param s s **/ static void taus113_set (taus113_state_t * state, unsigned long int s) { if (!s) { /* default seed is 1 */ s = 1UL; } Z1 (state) = LCG (s); if (Z1 (state) < 2UL) { Z1 (state) += 2UL; } Z2 (state) = LCG (Z1 (state)); if (Z2 (state) < 8UL) { Z2 (state) += 8UL; } Z3 (state) = LCG (Z2 (state)); if (Z3 (state) < 16UL) { Z3 (state) += 16UL; } Z4 (state) = LCG (Z3 (state)); if (Z4 (state) < 128UL) { Z4 (state) += 128UL; } /* Calling RNG ten times to satify recurrence condition */ (void) taus113_get (state); (void) taus113_get (state); (void) taus113_get (state); (void) taus113_get (state); (void) taus113_get (state); (void) taus113_get (state); (void) taus113_get (state); (void) taus113_get (state); (void) taus113_get (state); (void) taus113_get (state); } /*! \brief initialise rng \param u initialiser **/ void init_rng (unsigned long u) { taus113_set (&rng_state, u); } /*! \brief rng 53 bit \return same **/ double rng_53_bit (void) { double a = (double) (taus113_get (&rng_state) >> 5); double b = (double) (taus113_get (&rng_state) >> 6); return (a * /* 2^26 */ 67108864.0 + b) / /* 2^53 */ 9007199254740992.0; } /* Rules for analytic calculations using GNU Emacs Calc: (used to find the values for the test program) [ LCG(n) := n * 69069 mod (2^32) ] [ b1(x) := rsh(xor(lsh(x, 6), x), 13), q1(x) := xor(lsh(and(x, 4294967294), 18), b1(x)), b2(x) := rsh(xor(lsh(x, 2), x), 27), q2(x) := xor(lsh(and(x, 4294967288), 2), b2(x)), b3(x) := rsh(xor(lsh(x, 13), x), 21), q3(x) := xor(lsh(and(x, 4294967280), 7), b3(x)), b4(x) := rsh(xor(lsh(x, 3), x), 12), q4(x) := xor(lsh(and(x, 4294967168), 13), b4(x)) ] [ S([z1,z2,z3,z4]) := [q1(z1), q2(z2), q3(z3), q4(z4)] ] */ /* This file also contains Algol68G's standard environ for complex numbers. Some of the LONG operations are generic for LONG and LONG LONG. Some routines are based on * GNU Scientific Library * Abramowitz and Stegun. */ #if defined HAVE_GNU_GSL #define GSL_COMPLEX_FUNCTION(f)\ gsl_complex x, z;\ A68_REAL *rex, *imx;\ imx = (A68_REAL *) (STACK_OFFSET (-ALIGNED_SIZE_OF (A68_REAL)));\ rex = (A68_REAL *) (STACK_OFFSET (-2 * ALIGNED_SIZE_OF (A68_REAL)));\ GSL_SET_COMPLEX (&x, VALUE (rex), VALUE (imx));\ (void) gsl_set_error_handler_off ();\ RESET_ERRNO;\ z = f (x);\ MATH_RTE (p, errno != 0, MODE (COMPLEX), NO_TEXT);\ VALUE (imx) = GSL_IMAG(z);\ VALUE (rex) = GSL_REAL(z) #endif /*! \brief OP +* = (REAL, REAL) COMPLEX \param p position in tree **/ void genie_icomplex (NODE_T * p) { (void) p; } /*! \brief OP +* = (INT, INT) COMPLEX \param p position in tree **/ void genie_iint_complex (NODE_T * p) { A68_INT re, im; POP_OBJECT (p, &im, A68_INT); POP_OBJECT (p, &re, A68_INT); PUSH_PRIMITIVE (p, (double) VALUE (&re), A68_REAL); PUSH_PRIMITIVE (p, (double) VALUE (&im), A68_REAL); } /*! \brief OP RE = (COMPLEX) REAL \param p position in tree **/ void genie_re_complex (NODE_T * p) { DECREMENT_STACK_POINTER (p, ALIGNED_SIZE_OF (A68_REAL)); } /*! \brief OP IM = (COMPLEX) REAL \param p position in tree **/ void genie_im_complex (NODE_T * p) { A68_REAL im; POP_OBJECT (p, &im, A68_REAL); *(A68_REAL *) (STACK_OFFSET (-ALIGNED_SIZE_OF (A68_REAL))) = im; } /*! \brief OP - = (COMPLEX) COMPLEX \param p position in tree **/ void genie_minus_complex (NODE_T * p) { A68_REAL *re_x, *im_x; im_x = (A68_REAL *) (STACK_OFFSET (-ALIGNED_SIZE_OF (A68_REAL))); re_x = (A68_REAL *) (STACK_OFFSET (-2 * ALIGNED_SIZE_OF (A68_REAL))); VALUE (im_x) = -VALUE (im_x); VALUE (re_x) = -VALUE (re_x); (void) p; } /*! \brief ABS = (COMPLEX) REAL \param p position in tree **/ void genie_abs_complex (NODE_T * p) { A68_REAL re_x, im_x; POP_COMPLEX (p, &re_x, &im_x); PUSH_PRIMITIVE (p, a68g_hypot (VALUE (&re_x), VALUE (&im_x)), A68_REAL); } /*! \brief OP ARG = (COMPLEX) REAL \param p position in tree **/ void genie_arg_complex (NODE_T * p) { A68_REAL re_x, im_x; POP_COMPLEX (p, &re_x, &im_x); PRELUDE_ERROR (VALUE (&re_x) == 0.0 && VALUE (&im_x) == 0.0, p, ERROR_INVALID_ARGUMENT, MODE (COMPLEX)); PUSH_PRIMITIVE (p, atan2 (VALUE (&im_x), VALUE (&re_x)), A68_REAL); } /*! \brief OP CONJ = (COMPLEX) COMPLEX \param p position in tree **/ void genie_conj_complex (NODE_T * p) { A68_REAL *im; POP_OPERAND_ADDRESS (p, im, A68_REAL); VALUE (im) = -VALUE (im); } /*! \brief OP + = (COMPLEX, COMPLEX) COMPLEX \param p position in tree **/ void genie_add_complex (NODE_T * p) { A68_REAL *re_x, *im_x, re_y, im_y; POP_COMPLEX (p, &re_y, &im_y); im_x = (A68_REAL *) (STACK_OFFSET (-ALIGNED_SIZE_OF (A68_REAL))); re_x = (A68_REAL *) (STACK_OFFSET (-2 * ALIGNED_SIZE_OF (A68_REAL))); VALUE (im_x) += VALUE (&im_y); VALUE (re_x) += VALUE (&re_y); CHECK_COMPLEX_REPRESENTATION (p, VALUE (re_x), VALUE (im_x)); } /*! \brief OP - = (COMPLEX, COMPLEX) COMPLEX \param p position in tree **/ void genie_sub_complex (NODE_T * p) { A68_REAL *re_x, *im_x, re_y, im_y; POP_COMPLEX (p, &re_y, &im_y); im_x = (A68_REAL *) (STACK_OFFSET (-ALIGNED_SIZE_OF (A68_REAL))); re_x = (A68_REAL *) (STACK_OFFSET (-2 * ALIGNED_SIZE_OF (A68_REAL))); VALUE (im_x) -= VALUE (&im_y); VALUE (re_x) -= VALUE (&re_y); CHECK_COMPLEX_REPRESENTATION (p, VALUE (re_x), VALUE (im_x)); } /*! \brief OP * = (COMPLEX, COMPLEX) COMPLEX \param p position in tree **/ void genie_mul_complex (NODE_T * p) { A68_REAL re_x, im_x, re_y, im_y; double re, im; POP_COMPLEX (p, &re_y, &im_y); POP_COMPLEX (p, &re_x, &im_x); re = VALUE (&re_x) * VALUE (&re_y) - VALUE (&im_x) * VALUE (&im_y); im = VALUE (&im_x) * VALUE (&re_y) + VALUE (&re_x) * VALUE (&im_y); CHECK_COMPLEX_REPRESENTATION (p, re, im); PUSH_COMPLEX (p, re, im); } /*! \brief OP / = (COMPLEX, COMPLEX) COMPLEX \param p position in tree **/ void genie_div_complex (NODE_T * p) { A68_REAL re_x, im_x, re_y, im_y; double re = 0.0, im = 0.0; POP_COMPLEX (p, &re_y, &im_y); POP_COMPLEX (p, &re_x, &im_x); #if ! defined HAVE_IEEE_754 PRELUDE_ERROR (VALUE (&re_y) == 0.0 && VALUE (&im_y) == 0.0, p, ERROR_DIVISION_BY_ZERO, MODE (COMPLEX)); #endif if (ABS (VALUE (&re_y)) >= ABS (VALUE (&im_y))) { double r = VALUE (&im_y) / VALUE (&re_y), den = VALUE (&re_y) + r * VALUE (&im_y); re = (VALUE (&re_x) + r * VALUE (&im_x)) / den; im = (VALUE (&im_x) - r * VALUE (&re_x)) / den; } else { double r = VALUE (&re_y) / VALUE (&im_y), den = VALUE (&im_y) + r * VALUE (&re_y); re = (VALUE (&re_x) * r + VALUE (&im_x)) / den; im = (VALUE (&im_x) * r - VALUE (&re_x)) / den; } CHECK_COMPLEX_REPRESENTATION (p, re, im); PUSH_COMPLEX (p, re, im); } /*! \brief OP ** = (COMPLEX, INT) COMPLEX \param p position in tree **/ void genie_pow_complex_int (NODE_T * p) { A68_REAL re_x, im_x; double re_y, im_y, re_z, im_z, rea; A68_INT j; int expo; BOOL_T negative; POP_OBJECT (p, &j, A68_INT); POP_COMPLEX (p, &re_x, &im_x); re_z = 1.0; im_z = 0.0; re_y = VALUE (&re_x); im_y = VALUE (&im_x); expo = 1; negative = (BOOL_T) (VALUE (&j) < 0); if (negative) { VALUE (&j) = -VALUE (&j); } while ((unsigned) expo <= (unsigned) (VALUE (&j))) { if (expo & VALUE (&j)) { rea = re_z * re_y - im_z * im_y; im_z = re_z * im_y + im_z * re_y; re_z = rea; } rea = re_y * re_y - im_y * im_y; im_y = im_y * re_y + re_y * im_y; re_y = rea; expo <<= 1; } CHECK_COMPLEX_REPRESENTATION (p, re_z, im_z); if (negative) { PUSH_PRIMITIVE (p, 1.0, A68_REAL); PUSH_PRIMITIVE (p, 0.0, A68_REAL); PUSH_PRIMITIVE (p, re_z, A68_REAL); PUSH_PRIMITIVE (p, im_z, A68_REAL); genie_div_complex (p); } else { PUSH_PRIMITIVE (p, re_z, A68_REAL); PUSH_PRIMITIVE (p, im_z, A68_REAL); } } /*! \brief OP = = (COMPLEX, COMPLEX) BOOL \param p position in tree **/ void genie_eq_complex (NODE_T * p) { A68_REAL re_x, im_x, re_y, im_y; POP_COMPLEX (p, &re_y, &im_y); POP_COMPLEX (p, &re_x, &im_x); PUSH_PRIMITIVE (p, (BOOL_T) ((VALUE (&re_x) == VALUE (&re_y)) && (VALUE (&im_x) == VALUE (&im_y))), A68_BOOL); } /*! \brief OP /= = (COMPLEX, COMPLEX) BOOL \param p position in tree **/ void genie_ne_complex (NODE_T * p) { A68_REAL re_x, im_x, re_y, im_y; POP_COMPLEX (p, &re_y, &im_y); POP_COMPLEX (p, &re_x, &im_x); PUSH_PRIMITIVE (p, (BOOL_T) ! ((VALUE (&re_x) == VALUE (&re_y)) && (VALUE (&im_x) == VALUE (&im_y))), A68_BOOL); } /*! \brief OP +:= = (REF COMPLEX, COMPLEX) REF COMPLEX \param p position in tree **/ void genie_plusab_complex (NODE_T * p) { genie_f_and_becomes (p, MODE (REF_COMPLEX), genie_add_complex); } /*! \brief OP -:= = (REF COMPLEX, COMPLEX) REF COMPLEX \param p position in tree **/ void genie_minusab_complex (NODE_T * p) { genie_f_and_becomes (p, MODE (REF_COMPLEX), genie_sub_complex); } /*! \brief OP *:= = (REF COMPLEX, COMPLEX) REF COMPLEX \param p position in tree **/ void genie_timesab_complex (NODE_T * p) { genie_f_and_becomes (p, MODE (REF_COMPLEX), genie_mul_complex); } /*! \brief OP /:= = (REF COMPLEX, COMPLEX) REF COMPLEX \param p position in tree **/ void genie_divab_complex (NODE_T * p) { genie_f_and_becomes (p, MODE (REF_COMPLEX), genie_div_complex); } /*! \brief OP LENG = (COMPLEX) LONG COMPLEX \param p position in tree **/ void genie_lengthen_complex_to_long_complex (NODE_T * p) { int digits = get_mp_digits (MODE (LONG_REAL)); MP_T *z; A68_REAL a, b; POP_OBJECT (p, &b, A68_REAL); POP_OBJECT (p, &a, A68_REAL); STACK_MP (z, p, digits); (void) real_to_mp (p, z, VALUE (&a), digits); MP_STATUS (z) = (MP_T) INIT_MASK; STACK_MP (z, p, digits); (void) real_to_mp (p, z, VALUE (&b), digits); MP_STATUS (z) = (MP_T) INIT_MASK; } /*! \brief OP SHORTEN = (LONG COMPLEX) COMPLEX \param p position in tree **/ void genie_shorten_long_complex_to_complex (NODE_T * p) { int digits = get_mp_digits (MODE (LONG_REAL)), size = get_mp_size (MODE (LONG_REAL)); MP_T *b = (MP_T *) STACK_OFFSET (-size); MP_T *a = (MP_T *) STACK_OFFSET (-2 * size); DECREMENT_STACK_POINTER (p, 2 * size); PUSH_PRIMITIVE (p, mp_to_real (p, a, digits), A68_REAL); PUSH_PRIMITIVE (p, mp_to_real (p, b, digits), A68_REAL); } /*! \brief OP LENG = (LONG COMPLEX) LONG LONG COMPLEX \param p position in tree **/ void genie_lengthen_long_complex_to_longlong_complex (NODE_T * p) { int digits = get_mp_digits (MODE (LONG_REAL)), size = get_mp_size (MODE (LONG_REAL)); int digs_long = get_mp_digits (MODE (LONGLONG_REAL)), size_long = get_mp_size (MODE (LONGLONG_REAL)); ADDR_T pop_sp = stack_pointer; MP_T *a, *b, *c, *d; b = (MP_T *) STACK_OFFSET (-size); a = (MP_T *) STACK_OFFSET (-2 * size); STACK_MP (c, p, digs_long); STACK_MP (d, p, digs_long); (void) lengthen_mp (p, c, digs_long, a, digits); (void) lengthen_mp (p, d, digs_long, b, digits); MOVE_MP (a, c, digs_long); MOVE_MP (&a[2 + digs_long], d, digs_long); stack_pointer = pop_sp; MP_STATUS (a) = (MP_T) INIT_MASK; (&a[2 + digs_long])[0] = (MP_T) INIT_MASK; INCREMENT_STACK_POINTER (p, 2 * (size_long - size)); } /*! \brief OP SHORTEN = (LONG LONG COMPLEX) LONG COMPLEX \param p position in tree **/ void genie_shorten_longlong_complex_to_long_complex (NODE_T * p) { int digits = get_mp_digits (MODE (LONG_REAL)), size = get_mp_size (MODE (LONG_REAL)); int digs_long = get_mp_digits (MODE (LONGLONG_REAL)), size_long = get_mp_size (MODE (LONGLONG_REAL)); ADDR_T pop_sp = stack_pointer; MP_T *a, *b; b = (MP_T *) STACK_OFFSET (-size_long); a = (MP_T *) STACK_OFFSET (-2 * size_long); (void) shorten_mp (p, a, digits, a, digs_long); (void) shorten_mp (p, &a[2 + digits], digits, b, digs_long); stack_pointer = pop_sp; MP_STATUS (a) = (MP_T) INIT_MASK; (&a[2 + digits])[0] = (MP_T) INIT_MASK; DECREMENT_STACK_POINTER (p, 2 * (size_long - size)); } /*! \brief OP RE = (LONG COMPLEX) LONG REAL \param p position in tree **/ void genie_re_long_complex (NODE_T * p) { int size = get_mp_size (LHS_MODE (p)); MP_T *a = (MP_T *) STACK_OFFSET (-2 * size); MP_STATUS (a) = (MP_T) INIT_MASK; DECREMENT_STACK_POINTER (p, (int) size_long_mp ()); } /*! \brief OP IM = (LONG COMPLEX) LONG REAL \param p position in tree **/ void genie_im_long_complex (NODE_T * p) { int digits = get_mp_digits (LHS_MODE (p)), size = get_mp_size (MOID (PACK (MOID (p)))); MP_T *b = (MP_T *) STACK_OFFSET (-size); MP_T *a = (MP_T *) STACK_OFFSET (-2 * size); MOVE_MP (a, b, digits); MP_STATUS (a) = (MP_T) INIT_MASK; DECREMENT_STACK_POINTER (p, (int) size_long_mp ()); } /*! \brief OP - = (LONG COMPLEX) LONG COMPLEX \param p position in tree **/ void genie_minus_long_complex (NODE_T * p) { int size = get_mp_size (LHS_MODE (p)); MP_T *b = (MP_T *) STACK_OFFSET (-size); MP_T *a = (MP_T *) STACK_OFFSET (-2 * size); MP_DIGIT (a, 1) = -MP_DIGIT (a, 1); MP_DIGIT (b, 1) = -MP_DIGIT (b, 1); MP_STATUS (a) = (MP_T) INIT_MASK; MP_STATUS (b) = (MP_T) INIT_MASK; } /*! \brief OP CONJ = (LONG COMPLEX) LONG COMPLEX \param p position in tree **/ void genie_conj_long_complex (NODE_T * p) { int size = get_mp_size (LHS_MODE (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 COMPLEX \param p position in tree **/ void genie_abs_long_complex (NODE_T * p) { MOID_T *mode = LHS_MODE (p); int digits = get_mp_digits (mode), size = get_mp_size (mode); ADDR_T pop_sp = stack_pointer; MP_T *b = (MP_T *) STACK_OFFSET (-size); MP_T *a = (MP_T *) STACK_OFFSET (-2 * size); MP_T *z; STACK_MP (z, p, digits); (void) hypot_mp (p, z, a, b, digits); stack_pointer = pop_sp; DECREMENT_STACK_POINTER (p, size); MOVE_MP (a, z, digits); MP_STATUS (a) = (MP_T) INIT_MASK; MATH_RTE (p, errno != 0, mode, NO_TEXT); } /*! \brief OP ARG = (LONG COMPLEX) LONG REAL \param p position in tree **/ void genie_arg_long_complex (NODE_T * p) { MOID_T *mode = LHS_MODE (p); int digits = get_mp_digits (mode), size = get_mp_size (mode); ADDR_T pop_sp = stack_pointer; MP_T *b = (MP_T *) STACK_OFFSET (-size); MP_T *a = (MP_T *) STACK_OFFSET (-2 * size); MP_T *z; STACK_MP (z, p, digits); (void) atan2_mp (p, z, a, b, digits); stack_pointer = pop_sp; DECREMENT_STACK_POINTER (p, size); MOVE_MP (a, z, digits); MP_STATUS (a) = (MP_T) INIT_MASK; MATH_RTE (p, errno != 0, mode, NO_TEXT); } /*! \brief OP + = (LONG COMPLEX, LONG COMPLEX) LONG COMPLEX \param p position in tree **/ void genie_add_long_complex (NODE_T * p) { MOID_T *mode = RHS_MODE (p); int digits = get_mp_digits (mode), size = get_mp_size (mode); ADDR_T pop_sp = stack_pointer; MP_T *d = (MP_T *) STACK_OFFSET (-size); MP_T *c = (MP_T *) STACK_OFFSET (-2 * size); MP_T *b = (MP_T *) STACK_OFFSET (-3 * size); MP_T *a = (MP_T *) STACK_OFFSET (-4 * size); (void) add_mp (p, b, b, d, digits); (void) add_mp (p, a, a, c, digits); MP_STATUS (a) = (MP_T) INIT_MASK; MP_STATUS (b) = (MP_T) INIT_MASK; stack_pointer = pop_sp; DECREMENT_STACK_POINTER (p, 2 * size); } /*! \brief OP - = (LONG COMPLEX, LONG COMPLEX) LONG COMPLEX \param p position in tree **/ void genie_sub_long_complex (NODE_T * p) { MOID_T *mode = RHS_MODE (p); int digits = get_mp_digits (mode), size = get_mp_size (mode); ADDR_T pop_sp = stack_pointer; MP_T *d = (MP_T *) STACK_OFFSET (-size); MP_T *c = (MP_T *) STACK_OFFSET (-2 * size); MP_T *b = (MP_T *) STACK_OFFSET (-3 * size); MP_T *a = (MP_T *) STACK_OFFSET (-4 * size); (void) sub_mp (p, b, b, d, digits); (void) sub_mp (p, a, a, c, digits); MP_STATUS (a) = (MP_T) INIT_MASK; MP_STATUS (b) = (MP_T) INIT_MASK; stack_pointer = pop_sp; DECREMENT_STACK_POINTER (p, 2 * size); } /*! \brief OP * = (LONG COMPLEX, LONG COMPLEX) LONG COMPLEX \param p position in tree **/ void genie_mul_long_complex (NODE_T * p) { MOID_T *mode = RHS_MODE (p); int digits = get_mp_digits (mode), size = get_mp_size (mode); ADDR_T pop_sp = stack_pointer; MP_T *d = (MP_T *) STACK_OFFSET (-size); MP_T *c = (MP_T *) STACK_OFFSET (-2 * size); MP_T *b = (MP_T *) STACK_OFFSET (-3 * size); MP_T *a = (MP_T *) STACK_OFFSET (-4 * size); (void) cmul_mp (p, a, b, c, d, digits); MP_STATUS (a) = (MP_T) INIT_MASK; MP_STATUS (b) = (MP_T) INIT_MASK; stack_pointer = pop_sp; DECREMENT_STACK_POINTER (p, 2 * size); } /*! \brief OP / = (LONG COMPLEX, LONG COMPLEX) LONG COMPLEX \param p position in tree **/ void genie_div_long_complex (NODE_T * p) { MOID_T *mode = RHS_MODE (p); int digits = get_mp_digits (mode), size = get_mp_size (mode); ADDR_T pop_sp = stack_pointer; MP_T *d = (MP_T *) STACK_OFFSET (-size); MP_T *c = (MP_T *) STACK_OFFSET (-2 * size); MP_T *b = (MP_T *) STACK_OFFSET (-3 * size); MP_T *a = (MP_T *) STACK_OFFSET (-4 * size); PRELUDE_ERROR (cdiv_mp (p, a, b, c, d, digits) == NO_MP, p, ERROR_DIVISION_BY_ZERO, mode); MP_STATUS (a) = (MP_T) INIT_MASK; MP_STATUS (b) = (MP_T) INIT_MASK; stack_pointer = pop_sp; DECREMENT_STACK_POINTER (p, 2 * size); } /*! \brief OP ** = (LONG COMPLEX, INT) LONG COMPLEX \param p position in tree **/ void genie_pow_long_complex_int (NODE_T * p) { MOID_T *mode = LHS_MODE (p); int digits = get_mp_digits (mode), size = get_mp_size (mode); ADDR_T pop_sp; MP_T *re_x, *im_x, *re_y, *im_y, *re_z, *im_z, *rea, *acc; A68_INT j; int expo; BOOL_T negative; POP_OBJECT (p, &j, A68_INT); pop_sp = stack_pointer; im_x = (MP_T *) STACK_OFFSET (-size); re_x = (MP_T *) STACK_OFFSET (-2 * size); STACK_MP (re_z, p, digits); (void) set_mp_short (re_z, (MP_T) 1, 0, digits); STACK_MP (im_z, p, digits); SET_MP_ZERO (im_z, digits); STACK_MP (re_y, p, digits); STACK_MP (im_y, p, digits); MOVE_MP (re_y, re_x, digits); MOVE_MP (im_y, im_x, digits); STACK_MP (rea, p, digits); STACK_MP (acc, p, digits); expo = 1; negative = (BOOL_T) (VALUE (&j) < 0); if (negative) { VALUE (&j) = -VALUE (&j); } while ((unsigned) expo <= (unsigned) (VALUE (&j))) { if (expo & VALUE (&j)) { (void) mul_mp (p, acc, im_z, im_y, digits); (void) mul_mp (p, rea, re_z, re_y, digits); (void) sub_mp (p, rea, rea, acc, digits); (void) mul_mp (p, acc, im_z, re_y, digits); (void) mul_mp (p, im_z, re_z, im_y, digits); (void) add_mp (p, im_z, im_z, acc, digits); MOVE_MP (re_z, rea, digits); } (void) mul_mp (p, acc, im_y, im_y, digits); (void) mul_mp (p, rea, re_y, re_y, digits); (void) sub_mp (p, rea, rea, acc, digits); (void) mul_mp (p, acc, im_y, re_y, digits); (void) mul_mp (p, im_y, re_y, im_y, digits); (void) add_mp (p, im_y, im_y, acc, digits); MOVE_MP (re_y, rea, digits); expo <<= 1; } stack_pointer = pop_sp; if (negative) { (void) set_mp_short (re_x, (MP_T) 1, 0, digits); SET_MP_ZERO (im_x, digits); INCREMENT_STACK_POINTER (p, 2 * size); genie_div_long_complex (p); } else { MOVE_MP (re_x, re_z, digits); MOVE_MP (im_x, im_z, digits); } MP_STATUS (re_x) = (MP_T) INIT_MASK; MP_STATUS (im_x) = (MP_T) INIT_MASK; } /*! \brief OP = = (LONG COMPLEX, LONG COMPLEX) BOOL \param p position in tree **/ void genie_eq_long_complex (NODE_T * p) { int size = get_mp_size (LHS_MODE (p)); MP_T *b = (MP_T *) STACK_OFFSET (-3 * size); MP_T *a = (MP_T *) STACK_OFFSET (-4 * size); genie_sub_long_complex (p); DECREMENT_STACK_POINTER (p, 2 * size); PUSH_PRIMITIVE (p, (BOOL_T) (MP_DIGIT (a, 1) == 0 && MP_DIGIT (b, 1) == 0), A68_BOOL); } /*! \brief OP /= = (LONG COMPLEX, LONG COMPLEX) BOOL \param p position in tree **/ void genie_ne_long_complex (NODE_T * p) { int size = get_mp_size (LHS_MODE (p)); MP_T *b = (MP_T *) STACK_OFFSET (-3 * size); MP_T *a = (MP_T *) STACK_OFFSET (-4 * size); genie_sub_long_complex (p); DECREMENT_STACK_POINTER (p, 2 * size); PUSH_PRIMITIVE (p, (BOOL_T) (MP_DIGIT (a, 1) != 0 || MP_DIGIT (b, 1) != 0), A68_BOOL); } /*! \brief OP +:= = (REF LONG COMPLEX, LONG COMPLEX) REF LONG COMPLEX \param p position in tree **/ void genie_plusab_long_complex (NODE_T * p) { MOID_T *mode = LHS_MODE (p); genie_f_and_becomes (p, mode, genie_add_long_complex); } /*! \brief OP -:= = (REF LONG COMPLEX, LONG COMPLEX) REF LONG COMPLEX \param p position in tree **/ void genie_minusab_long_complex (NODE_T * p) { MOID_T *mode = LHS_MODE (p); genie_f_and_becomes (p, mode, genie_sub_long_complex); } /*! \brief OP *:= = (REF LONG COMPLEX, LONG COMPLEX) REF LONG COMPLEX \param p position in tree **/ void genie_timesab_long_complex (NODE_T * p) { MOID_T *mode = LHS_MODE (p); genie_f_and_becomes (p, mode, genie_mul_long_complex); } /*! \brief OP /:= = (REF LONG COMPLEX, LONG COMPLEX) REF LONG COMPLEX \param p position in tree **/ void genie_divab_long_complex (NODE_T * p) { MOID_T *mode = LHS_MODE (p); genie_f_and_becomes (p, mode, genie_div_long_complex); } /*! \brief PROC csqrt = (COMPLEX) COMPLEX \param p position in tree **/ void genie_sqrt_complex (NODE_T * p) { A68_REAL *re, *im; im = (A68_REAL *) (STACK_OFFSET (-ALIGNED_SIZE_OF (A68_REAL))); re = (A68_REAL *) (STACK_OFFSET (-2 * ALIGNED_SIZE_OF (A68_REAL))); RESET_ERRNO; if (VALUE (re) == 0.0 && VALUE (im) == 0.0) { VALUE (re) = 0.0; VALUE (im) = 0.0; } else { double x = ABS (VALUE (re)), y = ABS (VALUE (im)), w; if (x >= y) { double t = y / x; w = sqrt (x) * sqrt (0.5 * (1.0 + sqrt (1.0 + t * t))); } else { double t = x / y; w = sqrt (y) * sqrt (0.5 * (t + sqrt (1.0 + t * t))); } if (VALUE (re) >= 0.0) { VALUE (re) = w; VALUE (im) = VALUE (im) / (2.0 * w); } else { double ai = VALUE (im); double vi = (ai >= 0.0 ? w : -w); VALUE (re) = ai / (2.0 * vi); VALUE (im) = vi; } } MATH_RTE (p, errno != 0, MODE (COMPLEX), NO_TEXT); } /*! \brief PROC long csqrt = (LONG COMPLEX) LONG COMPLEX \param p position in tree **/ void genie_sqrt_long_complex (NODE_T * p) { MOID_T *mode = LHS_MODE (p); int digits = get_mp_digits (mode), size = get_mp_size (mode); ADDR_T pop_sp = stack_pointer; MP_T *im = (MP_T *) STACK_OFFSET (-size); MP_T *re = (MP_T *) STACK_OFFSET (-2 * size); RESET_ERRNO; (void) csqrt_mp (p, re, im, digits); stack_pointer = pop_sp; MP_STATUS (re) = (MP_T) INIT_MASK; MP_STATUS (im) = (MP_T) INIT_MASK; MATH_RTE (p, errno != 0, mode, NO_TEXT); } /*! \brief PROC cexp = (COMPLEX) COMPLEX \param p position in tree **/ void genie_exp_complex (NODE_T * p) { A68_REAL *re, *im; double r; im = (A68_REAL *) (STACK_OFFSET (-ALIGNED_SIZE_OF (A68_REAL))); re = (A68_REAL *) (STACK_OFFSET (-2 * ALIGNED_SIZE_OF (A68_REAL))); RESET_ERRNO; r = exp (VALUE (re)); VALUE (re) = r * cos (VALUE (im)); VALUE (im) = r * sin (VALUE (im)); MATH_RTE (p, errno != 0, MODE (COMPLEX), NO_TEXT); } /*! \brief PROC long cexp = (LONG COMPLEX) LONG COMPLEX \param p position in tree **/ void genie_exp_long_complex (NODE_T * p) { MOID_T *mode = LHS_MODE (p); int digits = get_mp_digits (mode), size = get_mp_size (mode); ADDR_T pop_sp = stack_pointer; MP_T *im = (MP_T *) STACK_OFFSET (-size); MP_T *re = (MP_T *) STACK_OFFSET (-2 * size); (void) cexp_mp (p, re, im, digits); stack_pointer = pop_sp; MP_STATUS (re) = (MP_T) INIT_MASK; MP_STATUS (im) = (MP_T) INIT_MASK; MATH_RTE (p, errno != 0, mode, NO_TEXT); } /*! \brief PROC cln = (COMPLEX) COMPLEX \param p position in tree **/ void genie_ln_complex (NODE_T * p) { A68_REAL *re, *im, r, th; im = (A68_REAL *) (STACK_OFFSET (-ALIGNED_SIZE_OF (A68_REAL))); re = (A68_REAL *) (STACK_OFFSET (-2 * ALIGNED_SIZE_OF (A68_REAL))); RESET_ERRNO; PUSH_COMPLEX (p, VALUE (re), VALUE (im)); genie_abs_complex (p); POP_OBJECT (p, &r, A68_REAL); PUSH_COMPLEX (p, VALUE (re), VALUE (im)); genie_arg_complex (p); POP_OBJECT (p, &th, A68_REAL); VALUE (re) = log (VALUE (&r)); VALUE (im) = VALUE (&th); MATH_RTE (p, errno != 0, MODE (COMPLEX), NO_TEXT); } /*! \brief PROC long cln = (LONG COMPLEX) LONG COMPLEX \param p position in tree **/ void genie_ln_long_complex (NODE_T * p) { MOID_T *mode = LHS_MODE (p); int digits = get_mp_digits (mode), size = get_mp_size (mode); ADDR_T pop_sp = stack_pointer; MP_T *im = (MP_T *) STACK_OFFSET (-size); MP_T *re = (MP_T *) STACK_OFFSET (-2 * size); (void) cln_mp (p, re, im, digits); stack_pointer = pop_sp; MP_STATUS (re) = (MP_T) INIT_MASK; MP_STATUS (im) = (MP_T) INIT_MASK; MATH_RTE (p, errno != 0, mode, NO_TEXT); } /*! \brief PROC csin = (COMPLEX) COMPLEX \param p position in tree **/ void genie_sin_complex (NODE_T * p) { A68_REAL *re, *im; im = (A68_REAL *) (STACK_OFFSET (-ALIGNED_SIZE_OF (A68_REAL))); re = (A68_REAL *) (STACK_OFFSET (-2 * ALIGNED_SIZE_OF (A68_REAL))); RESET_ERRNO; if (VALUE (im) == 0.0) { VALUE (re) = sin (VALUE (re)); VALUE (im) = 0.0; } else { double r = VALUE (re), i = VALUE (im); VALUE (re) = sin (r) * cosh (i); VALUE (im) = cos (r) * sinh (i); } MATH_RTE (p, errno != 0, MODE (REAL), NO_TEXT); } /*! \brief PROC long csin = (LONG COMPLEX) LONG COMPLEX \param p position in tree **/ void genie_sin_long_complex (NODE_T * p) { MOID_T *mode = LHS_MODE (p); int digits = get_mp_digits (mode), size = get_mp_size (mode); ADDR_T pop_sp = stack_pointer; MP_T *im = (MP_T *) STACK_OFFSET (-size); MP_T *re = (MP_T *) STACK_OFFSET (-2 * size); (void) csin_mp (p, re, im, digits); stack_pointer = pop_sp; MP_STATUS (re) = (MP_T) INIT_MASK; MP_STATUS (im) = (MP_T) INIT_MASK; MATH_RTE (p, errno != 0, mode, NO_TEXT); } /*! \brief PROC ccos = (COMPLEX) COMPLEX \param p position in tree **/ void genie_cos_complex (NODE_T * p) { A68_REAL *re, *im; im = (A68_REAL *) (STACK_OFFSET (-ALIGNED_SIZE_OF (A68_REAL))); re = (A68_REAL *) (STACK_OFFSET (-2 * ALIGNED_SIZE_OF (A68_REAL))); RESET_ERRNO; if (VALUE (im) == 0.0) { VALUE (re) = cos (VALUE (re)); VALUE (im) = 0.0; } else { double r = VALUE (re), i = VALUE (im); VALUE (re) = cos (r) * cosh (i); VALUE (im) = sin (r) * sinh (-i); } MATH_RTE (p, errno != 0, MODE (REAL), NO_TEXT); } /*! \brief PROC long ccos = (LONG COMPLEX) LONG COMPLEX \param p position in tree **/ void genie_cos_long_complex (NODE_T * p) { MOID_T *mode = LHS_MODE (p); int digits = get_mp_digits (mode), size = get_mp_size (mode); ADDR_T pop_sp = stack_pointer; MP_T *im = (MP_T *) STACK_OFFSET (-size); MP_T *re = (MP_T *) STACK_OFFSET (-2 * size); (void) ccos_mp (p, re, im, digits); stack_pointer = pop_sp; MP_STATUS (re) = (MP_T) INIT_MASK; MP_STATUS (im) = (MP_T) INIT_MASK; MATH_RTE (p, errno != 0, mode, NO_TEXT); } /*! \brief PROC ctan = (COMPLEX) COMPLEX \param p position in tree **/ void genie_tan_complex (NODE_T * p) { A68_REAL *im = (A68_REAL *) (STACK_OFFSET (-ALIGNED_SIZE_OF (A68_REAL))); A68_REAL *re = (A68_REAL *) (STACK_OFFSET (-2 * ALIGNED_SIZE_OF (A68_REAL))); double r, i; A68_REAL u, v; RESET_ERRNO; r = VALUE (re); i = VALUE (im); PUSH_PRIMITIVE (p, r, A68_REAL); PUSH_PRIMITIVE (p, i, A68_REAL); genie_sin_complex (p); POP_OBJECT (p, &v, A68_REAL); POP_OBJECT (p, &u, A68_REAL); PUSH_PRIMITIVE (p, r, A68_REAL); PUSH_PRIMITIVE (p, i, A68_REAL); genie_cos_complex (p); VALUE (re) = VALUE (&u); VALUE (im) = VALUE (&v); genie_div_complex (p); MATH_RTE (p, errno != 0, MODE (REAL), NO_TEXT); } /*! \brief PROC long ctan = (LONG COMPLEX) LONG COMPLEX \param p position in tree **/ void genie_tan_long_complex (NODE_T * p) { MOID_T *mode = LHS_MODE (p); int digits = get_mp_digits (mode), size = get_mp_size (mode); ADDR_T pop_sp = stack_pointer; MP_T *re = (MP_T *) STACK_OFFSET (-2 * size); MP_T *im = (MP_T *) STACK_OFFSET (-size); (void) ctan_mp (p, re, im, digits); stack_pointer = pop_sp; MP_STATUS (re) = (MP_T) INIT_MASK; MP_STATUS (im) = (MP_T) INIT_MASK; MATH_RTE (p, errno != 0, mode, NO_TEXT); } /*! \brief PROC carcsin= (COMPLEX) COMPLEX \param p position in tree **/ void genie_arcsin_complex (NODE_T * p) { A68_REAL *re = (A68_REAL *) (STACK_OFFSET (-2 * ALIGNED_SIZE_OF (A68_REAL))); A68_REAL *im = (A68_REAL *) (STACK_OFFSET (-ALIGNED_SIZE_OF (A68_REAL))); RESET_ERRNO; if (im == 0) { VALUE (re) = asin (VALUE (re)); } else { double r = VALUE (re), i = VALUE (im); double u = a68g_hypot (r + 1, i), v = a68g_hypot (r - 1, i); double a = 0.5 * (u + v), b = 0.5 * (u - v); VALUE (re) = asin (b); VALUE (im) = log (a + sqrt (a * a - 1)); } MATH_RTE (p, errno != 0, MODE (REAL), NO_TEXT); } /*! \brief PROC long arcsin = (LONG COMPLEX) LONG COMPLEX \param p position in tree **/ void genie_asin_long_complex (NODE_T * p) { MOID_T *mode = LHS_MODE (p); int digits = get_mp_digits (mode), size = get_mp_size (mode); ADDR_T pop_sp = stack_pointer; MP_T *re = (MP_T *) STACK_OFFSET (-2 * size); MP_T *im = (MP_T *) STACK_OFFSET (-size); RESET_ERRNO; (void) casin_mp (p, re, im, digits); stack_pointer = pop_sp; MP_STATUS (re) = (MP_T) INIT_MASK; MP_STATUS (im) = (MP_T) INIT_MASK; MATH_RTE (p, errno != 0, mode, NO_TEXT); } /*! \brief PROC carccos = (COMPLEX) COMPLEX \param p position in tree **/ void genie_arccos_complex (NODE_T * p) { A68_REAL *re = (A68_REAL *) (STACK_OFFSET (-2 * ALIGNED_SIZE_OF (A68_REAL))); A68_REAL *im = (A68_REAL *) (STACK_OFFSET (-ALIGNED_SIZE_OF (A68_REAL))); RESET_ERRNO; if (im == 0) { VALUE (re) = acos (VALUE (re)); } else { double r = VALUE (re), i = VALUE (im); double u = a68g_hypot (r + 1, i), v = a68g_hypot (r - 1, i); double a = 0.5 * (u + v), b = 0.5 * (u - v); VALUE (re) = acos (b); VALUE (im) = -log (a + sqrt (a * a - 1)); } MATH_RTE (p, errno != 0, MODE (REAL), NO_TEXT); } /*! \brief PROC long carccos = (LONG COMPLEX) LONG COMPLEX \param p position in tree **/ void genie_acos_long_complex (NODE_T * p) { MOID_T *mode = LHS_MODE (p); int digits = get_mp_digits (mode), size = get_mp_size (mode); ADDR_T pop_sp = stack_pointer; MP_T *re = (MP_T *) STACK_OFFSET (-2 * size); MP_T *im = (MP_T *) STACK_OFFSET (-size); RESET_ERRNO; (void) cacos_mp (p, re, im, digits); stack_pointer = pop_sp; MP_STATUS (re) = (MP_T) INIT_MASK; MP_STATUS (im) = (MP_T) INIT_MASK; MATH_RTE (p, errno != 0, mode, NO_TEXT); } /*! \brief PROC carctan = (COMPLEX) COMPLEX \param p position in tree **/ void genie_arctan_complex (NODE_T * p) { A68_REAL *re = (A68_REAL *) (STACK_OFFSET (-2 * ALIGNED_SIZE_OF (A68_REAL))); A68_REAL *im = (A68_REAL *) (STACK_OFFSET (-ALIGNED_SIZE_OF (A68_REAL))); RESET_ERRNO; if (im == 0) { VALUE (re) = atan (VALUE (re)); } else { double r = VALUE (re), i = VALUE (im); double a = a68g_hypot (r, i + 1), b = a68g_hypot (r, i - 1); VALUE (re) = 0.5 * atan (2 * r / (1 - r * r - i * i)); VALUE (im) = 0.5 * log (a / b); } MATH_RTE (p, errno != 0, MODE (REAL), NO_TEXT); } /*! \brief PROC long catan = (LONG COMPLEX) LONG COMPLEX \param p position in tree **/ void genie_atan_long_complex (NODE_T * p) { MOID_T *mode = LHS_MODE (p); int digits = get_mp_digits (mode), size = get_mp_size (mode); ADDR_T pop_sp = stack_pointer; MP_T *re = (MP_T *) STACK_OFFSET (-2 * size); MP_T *im = (MP_T *) STACK_OFFSET (-size); RESET_ERRNO; (void) catan_mp (p, re, im, digits); stack_pointer = pop_sp; MP_STATUS (re) = (MP_T) INIT_MASK; MP_STATUS (im) = (MP_T) INIT_MASK; MATH_RTE (p, errno != 0, mode, NO_TEXT); } #if defined HAVE_GNU_GSL /*! \brief PROC csinh = (COMPLEX) COMPLEX \param p position in tree **/ void genie_sinh_complex (NODE_T * p) { GSL_COMPLEX_FUNCTION (gsl_complex_sinh); } /*! \brief PROC ccosh = (COMPLEX) COMPLEX \param p position in tree **/ void genie_cosh_complex (NODE_T * p) { GSL_COMPLEX_FUNCTION (gsl_complex_cosh); } /*! \brief PROC ctanh = (COMPLEX) COMPLEX \param p position in tree **/ void genie_tanh_complex (NODE_T * p) { GSL_COMPLEX_FUNCTION (gsl_complex_tanh); } /*! \brief PROC carcsinh = (COMPLEX) COMPLEX \param p position in tree **/ void genie_arcsinh_complex (NODE_T * p) { GSL_COMPLEX_FUNCTION (gsl_complex_arcsinh); } /*! \brief PROC carccosh = (COMPLEX) COMPLEX \param p position in tree **/ void genie_arccosh_complex (NODE_T * p) { GSL_COMPLEX_FUNCTION (gsl_complex_arccosh); } /*! \brief PROC carctanh = (COMPLEX) COMPLEX \param p position in tree **/ void genie_arctanh_complex (NODE_T * p) { GSL_COMPLEX_FUNCTION (gsl_complex_arctanh); } #endif /* defined HAVE_GNU_GSL */ /* Standard prelude implementation, transput */ /* Transput library - General routines and (formatted) transput. But Eeyore wasn't listening. He was taking the balloon out, and putting it back again, as happy as could be ... Winnie the Pooh, A.A. Milne. - Revised Report on the Algorithmic Language Algol 68. */ A68_CHANNEL stand_in_channel, stand_out_channel, stand_draw_channel, stand_back_channel, stand_error_channel, associate_channel, skip_channel; A68_REF stand_in, stand_out, stand_back, stand_error, skip_file; A68_FORMAT nil_format = { INIT_MASK, NULL, 0 }; /* File table handling In a table we record opened files. When execution ends, unclosed files are closed, and temps are removed. This keeps /tmp free of spurious files :-) */ typedef struct FILE_ENTRY FILE_ENTRY; struct FILE_ENTRY { NODE_T *pos; BOOL_T is_open, is_tmp; FILE_T fd; A68_REF idf; }; FILE_ENTRY file_entries[MAX_OPEN_FILES]; /* \brief init an entry **/ void init_file_entry (int k) { if (k >= 0 && k < MAX_OPEN_FILES) { FILE_ENTRY *fe = &(file_entries[k]); POS (fe) = NO_NODE; IS_OPEN (fe) = A68_FALSE; IS_TMP (fe) = A68_FALSE; FD (fe) = A68_NO_FILENO; IDF (fe) = nil_ref; } } /* \brief initialise file entry table **/ void init_file_entries (void) { int k; for (k = 0; k < MAX_OPEN_FILES; k ++) { init_file_entry (k); } } /* \brief store file for later closing when not explicitly closed \param p entry in syntax tree \param fd file descriptor \param idf file name \param is_tmp whether file is a temp file \return entry in table **/ int store_file_entry (NODE_T *p, FILE_T fd, char *idf, BOOL_T is_tmp) { int k; for (k = 0; k < MAX_OPEN_FILES; k ++) { FILE_ENTRY *fe = &(file_entries[k]); if (!IS_OPEN (fe)) { int len = 1 + (int) strlen (idf); POS (fe) = p; IS_OPEN (fe) = A68_TRUE; IS_TMP (fe) = is_tmp; FD (fe) = fd; IDF (fe) = heap_generator (p, MODE (C_STRING), len); BLOCK_GC_HANDLE (&(IDF (fe))); bufcpy (DEREF (char, &IDF (fe)), idf, len); return (k); } } diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_TOO_MANY_OPEN_FILES); exit_genie (p, A68_RUNTIME_ERROR); return (-1); /* Fool them */ } /* \brief close file and delete temp file \param k entry in table **/ static void close_file_entry (NODE_T *p, int k) { if (k >= 0 && k < MAX_OPEN_FILES) { FILE_ENTRY *fe = &(file_entries[k]); if (IS_OPEN (fe)) { /* Close the file */ if (FD (fe) != A68_NO_FILENO && close (FD (fe)) == -1) { init_file_entry (k); diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FILE_CLOSE); exit_genie (p, A68_RUNTIME_ERROR); } IS_OPEN (fe) = A68_FALSE; } } } /* \brief close file and delete temp file \param k entry in table **/ static void free_file_entry (NODE_T *p, int k) { close_file_entry (p, k); if (k >= 0 && k < MAX_OPEN_FILES) { FILE_ENTRY *fe = &(file_entries[k]); if (IS_OPEN (fe)) { /* Attempt to remove a temp file, but ignore failure */ if (FD (fe) != A68_NO_FILENO && IS_TMP (fe)) { if (!IS_NIL (IDF (fe))) { char *filename; CHECK_INIT (p, INITIALISED (&(IDF (fe))), MODE (ROWS)); filename = DEREF (char, &IDF (fe)); if (filename != NO_TEXT) { (void) remove (filename); } } } /* Restore the fields */ if (!IS_NIL (IDF (fe))) { UNBLOCK_GC_HANDLE (&(IDF (fe))); } init_file_entry (k); } } } /* \brief close all files and delete all temp files **/ void free_file_entries (void) { int k; for (k = 0; k < MAX_OPEN_FILES; k ++) { free_file_entry (NO_NODE, k); } } /*! \brief PROC char in string = (CHAR, REF INT, STRING) BOOL \param p position in tree **/ void genie_char_in_string (NODE_T * p) { A68_CHAR c; A68_INT pos; A68_REF ref_pos, ref_str, row; A68_ARRAY *arr; A68_TUPLE *tup; char *q, ch; int k, len; POP_REF (p, &ref_str); row = *(A68_REF *) & ref_str; CHECK_INIT (p, INITIALISED (&row), MODE (ROWS)); GET_DESCRIPTOR (arr, tup, &row); POP_REF (p, &ref_pos); POP_OBJECT (p, &c, A68_CHAR); reset_transput_buffer (PATTERN_BUFFER); add_a_string_transput_buffer (p, PATTERN_BUFFER, (BYTE_T *) & ref_str); len = get_transput_buffer_index (PATTERN_BUFFER); q = get_transput_buffer (PATTERN_BUFFER); ch = (char) VALUE (&c); for (k = 0; k < len; k++) { if (q[k] == ch) { STATUS (&pos) = INIT_MASK; VALUE (&pos) = k + LOWER_BOUND (tup); * DEREF (A68_INT, &ref_pos) = pos; PUSH_PRIMITIVE (p, A68_TRUE, A68_BOOL); return; } } PUSH_PRIMITIVE (p, A68_FALSE, A68_BOOL); } /*! \brief PROC last char in string = (CHAR, REF INT, STRING) BOOL \param p position in tree **/ void genie_last_char_in_string (NODE_T * p) { A68_CHAR c; A68_INT pos; A68_REF ref_pos, ref_str, row; A68_ARRAY *arr; A68_TUPLE *tup; char *q, ch; int k, len; POP_REF (p, &ref_str); row = *(A68_REF *) & ref_str; CHECK_INIT (p, INITIALISED (&row), MODE (ROWS)); GET_DESCRIPTOR (arr, tup, &row); POP_REF (p, &ref_pos); POP_OBJECT (p, &c, A68_CHAR); reset_transput_buffer (PATTERN_BUFFER); add_a_string_transput_buffer (p, PATTERN_BUFFER, (BYTE_T *) & ref_str); len = get_transput_buffer_index (PATTERN_BUFFER); q = get_transput_buffer (PATTERN_BUFFER); ch = (char) VALUE (&c); for (k = len - 1; k >= 0; k--) { if (q[k] == ch) { STATUS (&pos) = INIT_MASK; VALUE (&pos) = k + LOWER_BOUND (tup); * DEREF (A68_INT, &ref_pos) = pos; PUSH_PRIMITIVE (p, A68_TRUE, A68_BOOL); return; } } PUSH_PRIMITIVE (p, A68_FALSE, A68_BOOL); } /*! \brief PROC string in string = (STRING, REF INT, STRING) BOOL \param p position in tree **/ void genie_string_in_string (NODE_T * p) { A68_REF ref_pos, ref_str, ref_pat, row; A68_ARRAY *arr; A68_TUPLE *tup; char *q; POP_REF (p, &ref_str); row = *(A68_REF *) & ref_str; CHECK_INIT (p, INITIALISED (&row), MODE (ROWS)); GET_DESCRIPTOR (arr, tup, &row); POP_REF (p, &ref_pos); POP_REF (p, &ref_pat); reset_transput_buffer (PATTERN_BUFFER); reset_transput_buffer (STRING_BUFFER); add_a_string_transput_buffer (p, PATTERN_BUFFER, (BYTE_T *) & ref_pat); add_a_string_transput_buffer (p, STRING_BUFFER, (BYTE_T *) & ref_str); q = strstr (get_transput_buffer (STRING_BUFFER), get_transput_buffer (PATTERN_BUFFER)); if (q != NO_TEXT) { if (!IS_NIL (ref_pos)) { A68_INT pos; STATUS (&pos) = INIT_MASK; /* ANSI standard leaves pointer difference undefined */ VALUE (&pos) = LOWER_BOUND (tup) + (int) get_transput_buffer_index (STRING_BUFFER) - (int) strlen (q); * DEREF (A68_INT, &ref_pos) = pos; } PUSH_PRIMITIVE (p, A68_TRUE, A68_BOOL); } else { PUSH_PRIMITIVE (p, A68_FALSE, A68_BOOL); } } /* Strings in transput are of arbitrary size. For this, we have transput buffers. A transput buffer is a REF STRUCT (INT size, index, STRING buffer). It is in the heap, but cannot be gced. If it is too small, we give up on it and make a larger one. */ static A68_REF ref_transput_buffer[MAX_TRANSPUT_BUFFER]; /*! \brief set max number of chars in a transput buffer \param n transput buffer number \param size max number of chars **/ void set_transput_buffer_size (int n, int size) { A68_INT *k = (A68_INT *) (ADDRESS (&ref_transput_buffer[n])); STATUS (k) = INIT_MASK; VALUE (k) = size; } /*! \brief set char index for transput buffer \param n transput buffer number \param cindex char index **/ void set_transput_buffer_index (int n, int cindex) { A68_INT *k = (A68_INT *) (ADDRESS (&ref_transput_buffer[n]) + ALIGNED_SIZE_OF (A68_INT)); STATUS (k) = INIT_MASK; VALUE (k) = cindex; } /*! \brief get max number of chars in a transput buffer \param n transput buffer number \return same **/ int get_transput_buffer_size (int n) { A68_INT *k = (A68_INT *) (ADDRESS (&ref_transput_buffer[n])); return (VALUE (k)); } /*! \brief get char index for transput buffer \param n transput buffer number \return same **/ int get_transput_buffer_index (int n) { A68_INT *k = (A68_INT *) (ADDRESS (&ref_transput_buffer[n]) + ALIGNED_SIZE_OF (A68_INT)); return (VALUE (k)); } /*! \brief get char[] from transput buffer \param n transput buffer number \return same **/ char *get_transput_buffer (int n) { return ((char *) (ADDRESS (&ref_transput_buffer[n]) + 2 * ALIGNED_SIZE_OF (A68_INT))); } /*! \brief mark transput buffer as no longer in use \param n transput buffer number **/ void unblock_transput_buffer (int n) { set_transput_buffer_index (n, -1); } /*! \brief find first unused transput buffer (for opening a file) \param p position in tree position in syntax tree \return same **/ int get_unblocked_transput_buffer (NODE_T * p) { int k; for (k = FIXED_TRANSPUT_BUFFERS; k < MAX_TRANSPUT_BUFFER; k++) { if (get_transput_buffer_index (k) == -1) { return (k); } } /* Oops! */ diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_TOO_MANY_OPEN_FILES); exit_genie (p, A68_RUNTIME_ERROR); return (-1); } /*! \brief empty contents of transput buffer \param n transput buffer number **/ void reset_transput_buffer (int n) { set_transput_buffer_index (n, 0); (get_transput_buffer (n))[0] = NULL_CHAR; } /*! \brief initialise transput buffers before use \param p position in tree position in syntax tree **/ void init_transput_buffers (NODE_T * p) { int k; for (k = 0; k < MAX_TRANSPUT_BUFFER; k++) { ref_transput_buffer[k] = heap_generator (p, MODE (ROWS), 2 * ALIGNED_SIZE_OF (A68_INT) + TRANSPUT_BUFFER_SIZE); BLOCK_GC_HANDLE (&ref_transput_buffer[k]); set_transput_buffer_size (k, TRANSPUT_BUFFER_SIZE); reset_transput_buffer (k); } /* Last buffers are available for FILE values */ for (k = FIXED_TRANSPUT_BUFFERS; k < MAX_TRANSPUT_BUFFER; k++) { unblock_transput_buffer (k); } } /*! \brief make a transput buffer larger \param p position in tree \param k transput buffer number \param size new size in characters **/ void enlarge_transput_buffer (NODE_T * p, int k, int size) { int tbindex = get_transput_buffer_index (k); char *sb_1 = get_transput_buffer (k), *sb_2; UNBLOCK_GC_HANDLE (&ref_transput_buffer[k]); ref_transput_buffer[k] = heap_generator (p, MODE (ROWS), 2 * ALIGNED_SIZE_OF (A68_INT) + size); BLOCK_GC_HANDLE (&ref_transput_buffer[k]); set_transput_buffer_size (k, size); set_transput_buffer_index (k, tbindex); sb_2 = get_transput_buffer (k); bufcpy (sb_2, sb_1, size); } /*! \brief add char to transput buffer; if the buffer is full, make it larger \param p position in tree \param k transput buffer number \param ch char to add **/ void add_char_transput_buffer (NODE_T * p, int k, char ch) { char *sb = get_transput_buffer (k); int size = get_transput_buffer_size (k); int tbindex = get_transput_buffer_index (k); if (tbindex == size - 2) { enlarge_transput_buffer (p, k, 10 * size /* size + TRANSPUT_BUFFER_SIZE */ ); add_char_transput_buffer (p, k, ch); } else { sb[tbindex] = ch; sb[tbindex + 1] = NULL_CHAR; set_transput_buffer_index (k, tbindex + 1); } } /*! \brief add char[] to transput buffer \param p position in tree \param k transput buffer number \param ch string to add **/ void add_string_transput_buffer (NODE_T * p, int k, char *ch) { for (; ch[0] != NULL_CHAR; ch++) { add_char_transput_buffer (p, k, ch[0]); } } /*! \brief add A68 string to transput buffer \param p position in tree \param k transput buffer number \param ref fat pointer to A68 string **/ void add_a_string_transput_buffer (NODE_T * p, int k, BYTE_T * ref) { A68_REF row = *(A68_REF *) ref; A68_ARRAY *arr; A68_TUPLE *tup; CHECK_INIT (p, INITIALISED (&row), MODE (ROWS)); GET_DESCRIPTOR (arr, tup, &row); if (ROW_SIZE (tup) > 0) { int i; BYTE_T *base_address = DEREF (BYTE_T, &ARRAY (arr)); for (i = LWB (tup); i <= UPB (tup); i++) { int addr = INDEX_1_DIM (arr, tup, i); A68_CHAR *ch = (A68_CHAR *) & (base_address[addr]); CHECK_INIT (p, INITIALISED (ch), MODE (CHAR)); add_char_transput_buffer (p, k, (char) VALUE (ch)); } } } /*! \brief pop A68 string and add to buffer \param p position in tree \param k transput buffer number **/ void add_string_from_stack_transput_buffer (NODE_T * p, int k) { DECREMENT_STACK_POINTER (p, A68_REF_SIZE); add_a_string_transput_buffer (p, k, STACK_TOP); } /*! \brief pop first character from transput buffer \param k transput buffer number \return same **/ char pop_char_transput_buffer (int k) { char *sb = get_transput_buffer (k); int tbindex = get_transput_buffer_index (k); if (tbindex <= 0) { return (NULL_CHAR); } else { char ch = sb[0]; MOVE (&sb[0], &sb[1], tbindex); set_transput_buffer_index (k, tbindex - 1); return (ch); } } /*! \brief add C string to A68 string \param p position in tree \param ref_str fat pointer to A68 string \param str pointer to C string **/ static void add_c_string_to_a_string (NODE_T * p, A68_REF ref_str, char *str) { A68_REF a, c, d; A68_ARRAY *a_1, *a_3; A68_TUPLE *t_1, *t_3; int l_1, l_2, u, v; BYTE_T *b_1, *b_3; l_2 = (int) strlen (str); /* left part */ CHECK_REF (p, ref_str, MODE (REF_STRING)); a = * DEREF (A68_REF, &ref_str); CHECK_INIT (p, INITIALISED (&a), MODE (STRING)); GET_DESCRIPTOR (a_1, t_1, &a); l_1 = ROW_SIZE (t_1); /* Sum string */ c = heap_generator (p, MODE (STRING), ALIGNED_SIZE_OF (A68_ARRAY) + ALIGNED_SIZE_OF (A68_TUPLE)); d = heap_generator (p, MODE (STRING), (l_1 + l_2) * ALIGNED_SIZE_OF (A68_CHAR)); /* Calculate again since garbage collector might have moved data */ GET_DESCRIPTOR (a_1, t_1, &a); /* Make descriptor of new string */ GET_DESCRIPTOR (a_3, t_3, &c); DIM (a_3) = 1; MOID (a_3) = MODE (CHAR); ELEM_SIZE (a_3) = ALIGNED_SIZE_OF (A68_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)], ALIGNED_SIZE_OF (A68_CHAR)); u += ALIGNED_SIZE_OF (A68_CHAR); } for (v = 0; v < l_2; v++) { A68_CHAR ch; STATUS (&ch) = INIT_MASK; VALUE (&ch) = str[v]; MOVE ((BYTE_T *) & b_3[u], (BYTE_T *) & ch, ALIGNED_SIZE_OF (A68_CHAR)); u += ALIGNED_SIZE_OF (A68_CHAR); } * DEREF (A68_REF, &ref_str) = c; } /*! \brief purge buffer for file \param p position in tree \param ref_file \param k transput buffer number for file **/ void write_purge_buffer (NODE_T * p, A68_REF ref_file, int k) { A68_FILE *file = FILE_DEREF (&ref_file); if (IS_NIL (STRING (file))) { if (!(FD (file) == STDOUT_FILENO && halt_typing)) { WRITE (FD (file), get_transput_buffer (k)); } } else { add_c_string_to_a_string (p, STRING (file), get_transput_buffer (k)); } reset_transput_buffer (k); } /* Routines that involve the A68 expression stack */ /*! \brief allocate a temporary string on the stack \param p position in tree \param size size in characters \return same **/ char *stack_string (NODE_T * p, int size) { char *new_str = (char *) STACK_TOP; INCREMENT_STACK_POINTER (p, size); if (stack_pointer > expr_stack_limit) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_STACK_OVERFLOW); exit_genie (p, A68_RUNTIME_ERROR); } FILL (new_str, NULL_CHAR, size); return (new_str); } /* Transput basic RTS routines */ /*! \brief REF FILE standin \param p position in tree **/ void genie_stand_in (NODE_T * p) { PUSH_REF (p, stand_in); } /*! \brief REF FILE standout \param p position in tree **/ void genie_stand_out (NODE_T * p) { PUSH_REF (p, stand_out); } /*! \brief REF FILE standback \param p position in tree **/ void genie_stand_back (NODE_T * p) { PUSH_REF (p, stand_back); } /*! \brief REF FILE standerror \param p position in tree **/ void genie_stand_error (NODE_T * p) { PUSH_REF (p, stand_error); } /*! \brief CHAR error char \param p position in tree **/ void genie_error_char (NODE_T * p) { PUSH_PRIMITIVE (p, ERROR_CHAR, A68_CHAR); } /*! \brief CHAR exp char \param p position in tree **/ void genie_exp_char (NODE_T * p) { PUSH_PRIMITIVE (p, EXPONENT_CHAR, A68_CHAR); } /*! \brief CHAR flip char \param p position in tree **/ void genie_flip_char (NODE_T * p) { PUSH_PRIMITIVE (p, FLIP_CHAR, A68_CHAR); } /*! \brief CHAR flop char \param p position in tree **/ void genie_flop_char (NODE_T * p) { PUSH_PRIMITIVE (p, FLOP_CHAR, A68_CHAR); } /*! \brief CHAR null char \param p position in tree **/ void genie_null_char (NODE_T * p) { PUSH_PRIMITIVE (p, NULL_CHAR, A68_CHAR); } /*! \brief CHAR blank \param p position in tree **/ void genie_blank_char (NODE_T * p) { PUSH_PRIMITIVE (p, BLANK_CHAR, A68_CHAR); } /*! \brief CHAR newline char \param p position in tree **/ void genie_newline_char (NODE_T * p) { PUSH_PRIMITIVE (p, NEWLINE_CHAR, A68_CHAR); } /*! \brief CHAR formfeed char \param p position in tree **/ void genie_formfeed_char (NODE_T * p) { PUSH_PRIMITIVE (p, FORMFEED_CHAR, A68_CHAR); } /*! \brief CHAR tab char \param p position in tree **/ void genie_tab_char (NODE_T * p) { PUSH_PRIMITIVE (p, TAB_CHAR, A68_CHAR); } /*! \brief CHANNEL standin channel \param p position in tree **/ void genie_stand_in_channel (NODE_T * p) { PUSH_OBJECT (p, stand_in_channel, A68_CHANNEL); } /*! \brief CHANNEL standout channel \param p position in tree **/ void genie_stand_out_channel (NODE_T * p) { PUSH_OBJECT (p, stand_out_channel, A68_CHANNEL); } /*! \brief CHANNEL stand draw channel \param p position in tree **/ void genie_stand_draw_channel (NODE_T * p) { PUSH_OBJECT (p, stand_draw_channel, A68_CHANNEL); } /*! \brief CHANNEL standback channel \param p position in tree **/ void genie_stand_back_channel (NODE_T * p) { PUSH_OBJECT (p, stand_back_channel, A68_CHANNEL); } /*! \brief CHANNEL standerror channel \param p position in tree **/ void genie_stand_error_channel (NODE_T * p) { PUSH_OBJECT (p, stand_error_channel, A68_CHANNEL); } /*! \brief PROC STRING program idf \param p position in tree **/ void genie_program_idf (NODE_T * p) { PUSH_REF (p, c_to_a_string (p, FILE_SOURCE_NAME (&program), DEFAULT_WIDTH)); } /* FILE and CHANNEL initialisations */ /*! \brief set_default_event_procedure \param z **/ void set_default_event_procedure (A68_PROCEDURE * z) { STATUS (z) = INIT_MASK; NODE (&(BODY (z))) = NO_NODE; ENVIRON (z) = 0; } /*! \brief initialise channel \param chan channel \param r reset possible \param s set possible \param g get possible \param p put possible \param b bin possible \param d draw possible **/ static void init_channel (A68_CHANNEL * chan, BOOL_T r, BOOL_T s, BOOL_T g, BOOL_T p, BOOL_T b, BOOL_T d) { STATUS (chan) = INIT_MASK; RESET (chan) = r; SET (chan) = s; GET (chan) = g; PUT (chan) = p; BIN (chan) = b; DRAW (chan) = d; COMPRESS (chan) = A68_TRUE; } /*! \brief set default event handlers \param f file **/ void set_default_event_procedures (A68_FILE * f) { set_default_event_procedure (&(FILE_END_MENDED (f))); set_default_event_procedure (&(PAGE_END_MENDED (f))); set_default_event_procedure (&(LINE_END_MENDED (f))); set_default_event_procedure (&(VALUE_ERROR_MENDED (f))); set_default_event_procedure (&(OPEN_ERROR_MENDED (f))); set_default_event_procedure (&(TRANSPUT_ERROR_MENDED (f))); set_default_event_procedure (&(FORMAT_END_MENDED (f))); set_default_event_procedure (&(FORMAT_ERROR_MENDED (f))); } /*! \brief set up a REF FILE object \param p position in tree \param ref_file fat pointer to A68 file \param c channel \param s file number \param rm read mood \param wm write mood \param cm char mood **/ static void init_file (NODE_T * p, A68_REF * ref_file, A68_CHANNEL c, FILE_T s, BOOL_T rm, BOOL_T wm, BOOL_T cm, char *env) { A68_FILE *f; char *filename = (env == NO_TEXT ? NO_TEXT : getenv (env)); *ref_file = heap_generator (p, MODE (REF_FILE), ALIGNED_SIZE_OF (A68_FILE)); BLOCK_GC_HANDLE (ref_file); f = FILE_DEREF (ref_file); STATUS (f) = INIT_MASK; TERMINATOR (f) = nil_ref; CHANNEL (f) = c; if (filename != NO_TEXT && strlen (filename) > 0) { int len = 1 + (int) strlen (filename); IDENTIFICATION (f) = heap_generator (p, MODE (C_STRING), len); BLOCK_GC_HANDLE (&(IDENTIFICATION (f))); bufcpy (DEREF (char, &IDENTIFICATION (f)), filename, len); FD (f) = A68_NO_FILENO; READ_MOOD (f) = A68_FALSE; WRITE_MOOD (f) = A68_FALSE; CHAR_MOOD (f) = A68_FALSE; DRAW_MOOD (f) = A68_FALSE; } else { IDENTIFICATION (f) = nil_ref; FD (f) = s; READ_MOOD (f) = rm; WRITE_MOOD (f) = wm; CHAR_MOOD (f) = cm; DRAW_MOOD (f) = A68_FALSE; } TRANSPUT_BUFFER (f) = get_unblocked_transput_buffer (p); reset_transput_buffer (TRANSPUT_BUFFER (f)); END_OF_FILE (f) = A68_FALSE; TMP_FILE (f) = A68_FALSE; OPENED (f) = A68_TRUE; OPEN_EXCLUSIVE (f) = A68_FALSE; FORMAT (f) = nil_format; STRING (f) = nil_ref; STRPOS (f) = 0; FILE_ENTRY (f) = -1; set_default_event_procedures (f); } /*! \brief initialise the transput RTL \param p position in tree **/ void genie_init_transput (NODE_T * p) { init_transput_buffers (p); /* Channels */ init_channel (&stand_in_channel, A68_FALSE, A68_FALSE, A68_TRUE, A68_FALSE, A68_FALSE, A68_FALSE); init_channel (&stand_out_channel, A68_FALSE, A68_FALSE, A68_FALSE, A68_TRUE, A68_FALSE, A68_FALSE); init_channel (&stand_back_channel, A68_TRUE, A68_TRUE, A68_TRUE, A68_TRUE, A68_TRUE, A68_FALSE); init_channel (&stand_error_channel, A68_FALSE, A68_FALSE, A68_FALSE, A68_TRUE, A68_FALSE, A68_FALSE); init_channel (&associate_channel, A68_TRUE, A68_TRUE, A68_TRUE, A68_TRUE, A68_FALSE, A68_FALSE); init_channel (&skip_channel, A68_FALSE, A68_FALSE, A68_FALSE, A68_FALSE, A68_FALSE, A68_FALSE); #if defined HAVE_GNU_PLOTUTILS init_channel (&stand_draw_channel, A68_FALSE, A68_FALSE, A68_FALSE, A68_FALSE, A68_FALSE, A68_TRUE); #else /* */ init_channel (&stand_draw_channel, A68_FALSE, A68_FALSE, A68_FALSE, A68_FALSE, A68_FALSE, A68_TRUE); #endif /* */ /* Files */ init_file (p, &stand_in, stand_in_channel, STDIN_FILENO, A68_TRUE, A68_FALSE, A68_TRUE, "A68G_STANDIN"); init_file (p, &stand_out, stand_out_channel, STDOUT_FILENO, A68_FALSE, A68_TRUE, A68_TRUE, "A68G_STANDOUT"); init_file (p, &stand_back, stand_back_channel, A68_NO_FILENO, A68_FALSE, A68_FALSE, A68_FALSE, NO_TEXT); init_file (p, &stand_error, stand_error_channel, STDERR_FILENO, A68_FALSE, A68_TRUE, A68_TRUE, "A68G_STANDERROR"); init_file (p, &skip_file, skip_channel, A68_NO_FILENO, A68_FALSE, A68_FALSE, A68_FALSE, NO_TEXT); } /*! \brief PROC (REF FILE) STRING idf \param p position in tree **/ void genie_idf (NODE_T * p) { A68_REF ref_file, ref_filename; char *filename; POP_REF (p, &ref_file); CHECK_REF (p, ref_file, MODE (REF_FILE)); ref_file = *(A68_REF *) STACK_TOP; ref_filename = IDENTIFICATION (FILE_DEREF (&ref_file)); CHECK_REF (p, ref_filename, MODE (ROWS)); filename = DEREF (char, &ref_filename); PUSH_REF (p, c_to_a_string (p, filename, DEFAULT_WIDTH)); } /*! \brief PROC (REF FILE) STRING term \param p position in tree **/ void genie_term (NODE_T * p) { A68_REF ref_file, ref_term; char *term; POP_REF (p, &ref_file); CHECK_REF (p, ref_file, MODE (REF_FILE)); ref_file = *(A68_REF *) STACK_TOP; ref_term = TERMINATOR (FILE_DEREF (&ref_file)); CHECK_REF (p, ref_term, MODE (ROWS)); term = DEREF (char, &ref_term); PUSH_REF (p, c_to_a_string (p, term, DEFAULT_WIDTH)); } /*! \brief PROC (REF FILE, STRING) VOID make term \param p position in tree **/ void genie_make_term (NODE_T * p) { int size; A68_FILE *file; A68_REF ref_file, str; POP_REF (p, &str); POP_REF (p, &ref_file); CHECK_REF (p, ref_file, MODE (REF_FILE)); ref_file = *(A68_REF *) STACK_TOP; file = FILE_DEREF (&ref_file); /* Don't check initialisation so we can "make term" before opening. That is ok */ size = a68_string_size (p, str); if (INITIALISED (&(TERMINATOR (file))) && !IS_NIL (TERMINATOR (file))) { UNBLOCK_GC_HANDLE (&(TERMINATOR (file))); } TERMINATOR (file) = heap_generator (p, MODE (C_STRING), 1 + size); BLOCK_GC_HANDLE (&(TERMINATOR (file))); ASSERT (a_to_c_string (p, DEREF (char, &TERMINATOR (file)), str) != NO_TEXT); } /*! \brief PROC (REF FILE) BOOL put possible \param p position in tree **/ void genie_put_possible (NODE_T * p) { A68_REF ref_file; A68_FILE *file; POP_REF (p, &ref_file); CHECK_REF (p, ref_file, MODE (REF_FILE)); file = FILE_DEREF (&ref_file); CHECK_INIT (p, INITIALISED (file), MODE (FILE)); PUSH_PRIMITIVE (p, PUT (&CHANNEL (file)), A68_BOOL); } /*! \brief PROC (REF FILE) BOOL get possible \param p position in tree **/ void genie_get_possible (NODE_T * p) { A68_REF ref_file; A68_FILE *file; POP_REF (p, &ref_file); CHECK_REF (p, ref_file, MODE (REF_FILE)); file = FILE_DEREF (&ref_file); CHECK_INIT (p, INITIALISED (file), MODE (FILE)); PUSH_PRIMITIVE (p, GET (&CHANNEL (file)), A68_BOOL); } /*! \brief PROC (REF FILE) BOOL bin possible \param p position in tree **/ void genie_bin_possible (NODE_T * p) { A68_REF ref_file; A68_FILE *file; POP_REF (p, &ref_file); CHECK_REF (p, ref_file, MODE (REF_FILE)); file = FILE_DEREF (&ref_file); CHECK_INIT (p, INITIALISED (file), MODE (FILE)); PUSH_PRIMITIVE (p, BIN (&CHANNEL (file)), A68_BOOL); } /*! \brief PROC (REF FILE) BOOL set possible \param p position in tree **/ void genie_set_possible (NODE_T * p) { A68_REF ref_file; A68_FILE *file; POP_REF (p, &ref_file); CHECK_REF (p, ref_file, MODE (REF_FILE)); file = FILE_DEREF (&ref_file); CHECK_INIT (p, INITIALISED (file), MODE (FILE)); PUSH_PRIMITIVE (p, SET (&CHANNEL (file)), A68_BOOL); } /*! \brief PROC (REF FILE) BOOL reidf possible \param p position in tree **/ void genie_reidf_possible (NODE_T * p) { A68_REF ref_file; A68_FILE *file; POP_REF (p, &ref_file); CHECK_REF (p, ref_file, MODE (REF_FILE)); file = FILE_DEREF (&ref_file); CHECK_INIT (p, INITIALISED (file), MODE (FILE)); PUSH_PRIMITIVE (p, A68_FALSE, A68_BOOL); } /*! \brief PROC (REF FILE) BOOL reset possible \param p position in tree **/ void genie_reset_possible (NODE_T * p) { A68_REF ref_file; A68_FILE *file; POP_REF (p, &ref_file); CHECK_REF (p, ref_file, MODE (REF_FILE)); file = FILE_DEREF (&ref_file); CHECK_INIT (p, INITIALISED (file), MODE (FILE)); PUSH_PRIMITIVE (p, RESET (&CHANNEL (file)), A68_BOOL); } /*! \brief PROC (REF FILE) BOOL compressible \param p position in tree **/ void genie_compressible (NODE_T * p) { A68_REF ref_file; A68_FILE *file; POP_REF (p, &ref_file); CHECK_REF (p, ref_file, MODE (REF_FILE)); file = FILE_DEREF (&ref_file); CHECK_INIT (p, INITIALISED (file), MODE (FILE)); PUSH_PRIMITIVE (p, COMPRESS (&CHANNEL (file)), A68_BOOL); } /*! \brief PROC (REF FILE) BOOL draw possible \param p position in tree **/ void genie_draw_possible (NODE_T * p) { A68_REF ref_file; A68_FILE *file; POP_REF (p, &ref_file); CHECK_REF (p, ref_file, MODE (REF_FILE)); file = FILE_DEREF (&ref_file); CHECK_INIT (p, INITIALISED (file), MODE (FILE)); PUSH_PRIMITIVE (p, DRAW (&CHANNEL (file)), A68_BOOL); } /*! \brief PROC (REF FILE, STRING, CHANNEL) INT open \param p position in tree **/ void genie_open (NODE_T * p) { A68_CHANNEL channel; A68_REF ref_iden, ref_file; A68_FILE *file; int size; POP_OBJECT (p, &channel, A68_CHANNEL); POP_REF (p, &ref_iden); CHECK_REF (p, ref_iden, MODE (REF_STRING)); POP_REF (p, &ref_file); CHECK_REF (p, ref_file, MODE (REF_FILE)); file = FILE_DEREF (&ref_file); STATUS (file) = INIT_MASK; FILE_ENTRY (file) = -1; CHANNEL (file) = channel; OPENED (file) = A68_TRUE; OPEN_EXCLUSIVE (file) = A68_FALSE; READ_MOOD (file) = A68_FALSE; WRITE_MOOD (file) = A68_FALSE; CHAR_MOOD (file) = A68_FALSE; DRAW_MOOD (file) = A68_FALSE; TMP_FILE (file) = A68_FALSE; size = a68_string_size (p, ref_iden); if (INITIALISED (&(IDENTIFICATION (file))) && !IS_NIL (IDENTIFICATION (file))) { UNBLOCK_GC_HANDLE (&(IDENTIFICATION (file))); } IDENTIFICATION (file) = heap_generator (p, MODE (C_STRING), 1 + size); BLOCK_GC_HANDLE (&(IDENTIFICATION (file))); ASSERT (a_to_c_string (p, DEREF (char, &IDENTIFICATION (file)), ref_iden) != NO_TEXT); TERMINATOR (file) = nil_ref; FORMAT (file) = nil_format; FD (file) = A68_NO_FILENO; if (INITIALISED (&(STRING (file))) && !IS_NIL (STRING (file))) { UNBLOCK_GC_HANDLE (DEREF (A68_REF, &STRING (file))); } STRING (file) = nil_ref; STRPOS (file) = 0; DEVICE_MADE (&DEVICE (file)) = A68_FALSE; STREAM (&DEVICE (file)) = NO_STREAM; set_default_event_procedures (file); { struct stat status; if (stat (DEREF (char, &IDENTIFICATION (file)), &status) == 0) { PUSH_PRIMITIVE (p, (S_ISREG (ST_MODE (&status)) != 0 ? 0 : 1), A68_INT); } else { PUSH_PRIMITIVE (p, 1, A68_INT); } RESET_ERRNO; } } /*! \brief PROC (REF FILE, STRING, CHANNEL) INT establish \param p position in tree **/ void genie_establish (NODE_T * p) { A68_CHANNEL channel; A68_REF ref_iden, ref_file; A68_FILE *file; int size; POP_OBJECT (p, &channel, A68_CHANNEL); POP_REF (p, &ref_iden); CHECK_REF (p, ref_iden, MODE (REF_STRING)); POP_REF (p, &ref_file); CHECK_REF (p, ref_file, MODE (REF_FILE)); file = FILE_DEREF (&ref_file); STATUS (file) = INIT_MASK; FILE_ENTRY (file) = -1; CHANNEL (file) = channel; OPENED (file) = A68_TRUE; OPEN_EXCLUSIVE (file) = A68_TRUE; READ_MOOD (file) = A68_FALSE; WRITE_MOOD (file) = A68_FALSE; CHAR_MOOD (file) = A68_FALSE; DRAW_MOOD (file) = A68_FALSE; TMP_FILE (file) = A68_FALSE; if (!PUT (&CHANNEL (file))) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_CHANNEL_DOES_NOT_ALLOW, "putting"); exit_genie (p, A68_RUNTIME_ERROR); } size = a68_string_size (p, ref_iden); if (INITIALISED (&(IDENTIFICATION (file))) && !IS_NIL (IDENTIFICATION (file))) { UNBLOCK_GC_HANDLE (&(IDENTIFICATION (file))); } IDENTIFICATION (file) = heap_generator (p, MODE (C_STRING), 1 + size); BLOCK_GC_HANDLE (&(IDENTIFICATION (file))); ASSERT (a_to_c_string (p, DEREF (char, &IDENTIFICATION (file)), ref_iden) != NO_TEXT); TERMINATOR (file) = nil_ref; FORMAT (file) = nil_format; FD (file) = A68_NO_FILENO; if (INITIALISED (&(STRING (file))) && !IS_NIL (STRING (file))) { UNBLOCK_GC_HANDLE (DEREF (A68_REF, &STRING (file))); } STRING (file) = nil_ref; STRPOS (file) = 0; DEVICE_MADE (&DEVICE (file)) = A68_FALSE; STREAM (&DEVICE (file)) = NO_STREAM; set_default_event_procedures (file); PUSH_PRIMITIVE (p, 0, A68_INT); } /*! \brief PROC (REF FILE, CHANNEL) INT create \param p position in tree **/ void genie_create (NODE_T * p) { A68_CHANNEL channel; A68_REF ref_file; A68_FILE *file; POP_OBJECT (p, &channel, A68_CHANNEL); POP_REF (p, &ref_file); CHECK_REF (p, ref_file, MODE (REF_FILE)); file = FILE_DEREF (&ref_file); STATUS (file) = INIT_MASK; FILE_ENTRY (file) = -1; CHANNEL (file) = channel; OPENED (file) = A68_TRUE; OPEN_EXCLUSIVE (file) = A68_FALSE; READ_MOOD (file) = A68_FALSE; WRITE_MOOD (file) = A68_FALSE; CHAR_MOOD (file) = A68_FALSE; DRAW_MOOD (file) = A68_FALSE; TMP_FILE (file) = A68_TRUE; if (INITIALISED (&(IDENTIFICATION (file))) && !IS_NIL (IDENTIFICATION (file))) { UNBLOCK_GC_HANDLE (&(IDENTIFICATION (file))); } IDENTIFICATION (file) = nil_ref; TERMINATOR (file) = nil_ref; FORMAT (file) = nil_format; FD (file) = A68_NO_FILENO; if (INITIALISED (&(STRING (file))) && !IS_NIL (STRING (file))) { UNBLOCK_GC_HANDLE (DEREF (A68_REF, &STRING (file))); } STRING (file) = nil_ref; STRPOS (file) = 0; DEVICE_MADE (&DEVICE (file)) = A68_FALSE; STREAM (&DEVICE (file)) = NO_STREAM; set_default_event_procedures (file); PUSH_PRIMITIVE (p, 0, A68_INT); } /*! \brief PROC (REF FILE, REF STRING) VOID associate \param p position in tree **/ void genie_associate (NODE_T * p) { A68_REF ref_string, ref_file; A68_FILE *file; POP_REF (p, &ref_string); CHECK_REF (p, ref_string, MODE (REF_STRING)); POP_REF (p, &ref_file); CHECK_REF (p, ref_file, MODE (REF_FILE)); if (IS_IN_HEAP (&ref_file) && !IS_IN_HEAP (&ref_string)) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_SCOPE_DYNAMIC_1, MODE (REF_STRING)); exit_genie (p, A68_RUNTIME_ERROR); } else if (IS_IN_FRAME (&ref_file) && IS_IN_FRAME (&ref_string)) { if (REF_SCOPE (&ref_string) > REF_SCOPE (&ref_file)) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_SCOPE_DYNAMIC_1, MODE (REF_STRING)); exit_genie (p, A68_RUNTIME_ERROR); } } file = FILE_DEREF (&ref_file); STATUS (file) = INIT_MASK; FILE_ENTRY (file) = -1; CHANNEL (file) = associate_channel; OPENED (file) = A68_TRUE; OPEN_EXCLUSIVE (file) = A68_FALSE; READ_MOOD (file) = A68_FALSE; WRITE_MOOD (file) = A68_FALSE; CHAR_MOOD (file) = A68_FALSE; DRAW_MOOD (file) = A68_FALSE; TMP_FILE (file) = A68_FALSE; if (INITIALISED (&(IDENTIFICATION (file))) && !IS_NIL (IDENTIFICATION (file))) { UNBLOCK_GC_HANDLE (&(IDENTIFICATION (file))); } IDENTIFICATION (file) = nil_ref; TERMINATOR (file) = nil_ref; FORMAT (file) = nil_format; FD (file) = A68_NO_FILENO; if (INITIALISED (&(STRING (file))) && !IS_NIL (STRING (file))) { UNBLOCK_GC_HANDLE (DEREF (A68_REF, &STRING (file))); } STRING (file) = ref_string; BLOCK_GC_HANDLE ((A68_REF *) (&(STRING (file)))); STRPOS (file) = 1; DEVICE_MADE (&DEVICE (file)) = A68_FALSE; STREAM (&DEVICE (file)) = NO_STREAM; set_default_event_procedures (file); } /*! \brief PROC (REF FILE) VOID close \param p position in tree **/ void genie_close (NODE_T * p) { A68_REF ref_file; A68_FILE *file; POP_REF (p, &ref_file); CHECK_REF (p, ref_file, MODE (REF_FILE)); file = FILE_DEREF (&ref_file); CHECK_INIT (p, INITIALISED (file), MODE (FILE)); if (!OPENED (file) || (!READ_MOOD (file) && !WRITE_MOOD (file) && !DRAW_MOOD (file))) { return; } DEVICE_MADE (&DEVICE (file)) = A68_FALSE; #if defined HAVE_GNU_PLOTUTILS if (DEVICE_OPENED (&DEVICE (file))) { ASSERT(close_device (p, file) == A68_TRUE); STREAM (&DEVICE (file)) = NO_STREAM; return; } #endif /* */ FD (file) = A68_NO_FILENO; OPENED (file) = A68_FALSE; unblock_transput_buffer (TRANSPUT_BUFFER (file)); set_default_event_procedures (file); free_file_entry (p, FILE_ENTRY (file)); } /*! \brief PROC (REF FILE) VOID lock \param p position in tree **/ void genie_lock (NODE_T * p) { A68_REF ref_file; A68_FILE *file; POP_REF (p, &ref_file); CHECK_REF (p, ref_file, MODE (REF_FILE)); file = FILE_DEREF (&ref_file); CHECK_INIT (p, INITIALISED (file), MODE (FILE)); if (!OPENED (file) || (!READ_MOOD (file) && !WRITE_MOOD (file) && !DRAW_MOOD (file))) { return; } DEVICE_MADE (&DEVICE (file)) = A68_FALSE; #if defined HAVE_GNU_PLOTUTILS if (DEVICE_OPENED (&DEVICE (file))) { ASSERT(close_device (p, file) == A68_TRUE); STREAM (&DEVICE (file)) = NO_STREAM; return; } #endif /* */ #if ! defined HAVE_WIN32 RESET_ERRNO; ASSERT (fchmod (FD (file), (mode_t) 0x0) != -1); #endif if (FD (file) != A68_NO_FILENO && close (FD (file)) == -1) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FILE_LOCK); exit_genie (p, A68_RUNTIME_ERROR); } else { FD (file) = A68_NO_FILENO; OPENED (file) = A68_FALSE; unblock_transput_buffer (TRANSPUT_BUFFER (file)); set_default_event_procedures (file); } free_file_entry (p, FILE_ENTRY (file)); } /*! \brief PROC (REF FILE) VOID erase \param p position in tree **/ void genie_erase (NODE_T * p) { A68_REF ref_file; A68_FILE *file; POP_REF (p, &ref_file); CHECK_REF (p, ref_file, MODE (REF_FILE)); file = FILE_DEREF (&ref_file); CHECK_INIT (p, INITIALISED (file), MODE (FILE)); if (!OPENED (file) || (!READ_MOOD (file) && !WRITE_MOOD (file) && !DRAW_MOOD (file))) { return; } DEVICE_MADE (&DEVICE (file)) = A68_FALSE; #if defined HAVE_GNU_PLOTUTILS if (DEVICE_OPENED (&DEVICE (file))) { ASSERT(close_device (p, file) == A68_TRUE); STREAM (&DEVICE (file)) = NO_STREAM; return; } #endif /* */ if (FD (file) != A68_NO_FILENO && close (FD (file)) == -1) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FILE_SCRATCH); exit_genie (p, A68_RUNTIME_ERROR); } else { unblock_transput_buffer (TRANSPUT_BUFFER (file)); set_default_event_procedures (file); } /* Remove the file */ if (!IS_NIL (IDENTIFICATION (file))) { char *filename; CHECK_INIT (p, INITIALISED (&(IDENTIFICATION (file))), MODE (ROWS)); filename = DEREF (char, &IDENTIFICATION (file)); if (remove (filename) != 0) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FILE_SCRATCH); exit_genie (p, A68_RUNTIME_ERROR); } UNBLOCK_GC_HANDLE (&(IDENTIFICATION (file))); IDENTIFICATION (file) = nil_ref; } init_file_entry (FILE_ENTRY (file)); } /*! \brief PROC (REF FILE) VOID backspace \param p position in tree **/ void genie_backspace (NODE_T * p) { ADDR_T pop_sp = stack_pointer; PUSH_PRIMITIVE (p, -1, A68_INT); genie_set (p); stack_pointer = pop_sp; } /*! \brief PROC (REF FILE, INT) INT set \param p position in tree **/ void genie_set (NODE_T * p) { A68_REF ref_file; A68_FILE *file; A68_INT pos; POP_OBJECT (p, &pos, A68_INT); POP_REF (p, &ref_file); CHECK_REF (p, ref_file, MODE (REF_FILE)); file = FILE_DEREF (&ref_file); CHECK_INIT (p, INITIALISED (file), MODE (FILE)); if (!OPENED (file)) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FILE_NOT_OPEN); exit_genie (p, A68_RUNTIME_ERROR); } if (!SET (&CHANNEL (file))) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FILE_CANT_SET); exit_genie (p, A68_RUNTIME_ERROR); } if (!IS_NIL (STRING (file))) { A68_REF z = * DEREF (A68_REF, &STRING (file)); A68_ARRAY *a; A68_TUPLE *t; /* 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); if (STRPOS (file) < LWB (t) || STRPOS (file) > UPB (t)) { A68_BOOL res; on_event_handler (p, FILE_END_MENDED (FILE_DEREF (&ref_file)), ref_file); POP_OBJECT (p, &res, A68_BOOL); if (VALUE (&res) == A68_FALSE) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FILE_ENDED); exit_genie (p, A68_RUNTIME_ERROR); } } PUSH_PRIMITIVE (p, STRPOS (file), A68_INT); } else if (FD (file) == A68_NO_FILENO) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FILE_RESET); exit_genie (p, A68_RUNTIME_ERROR); } else { __off_t curpos = lseek (FD (file), 0, SEEK_CUR); __off_t maxpos = lseek (FD (file), 0, SEEK_END); __off_t res = lseek (FD (file), curpos, SEEK_SET); /* Circumvent buffering problems */ int reserve = get_transput_buffer_index (TRANSPUT_BUFFER (file)); curpos -= (__off_t) reserve; res = lseek (FD (file), -reserve, SEEK_CUR); ASSERT (res != -1 && errno == 0); reset_transput_buffer (TRANSPUT_BUFFER (file)); /* Now set */ CHECK_INT_ADDITION (p, curpos, VALUE (&pos)); curpos += VALUE (&pos); if (curpos < 0 || curpos >= maxpos) { A68_BOOL ret; on_event_handler (p, FILE_END_MENDED (FILE_DEREF (&ref_file)), ref_file); POP_OBJECT (p, &ret, A68_BOOL); if (VALUE (&ret) == A68_FALSE) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FILE_ENDED); exit_genie (p, A68_RUNTIME_ERROR); } PUSH_PRIMITIVE (p, (int) lseek (FD (file), 0, SEEK_CUR), A68_INT); } else { res = lseek (FD (file), curpos, SEEK_SET); if (res == -1 || errno != 0) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FILE_SET); exit_genie (p, A68_RUNTIME_ERROR); } PUSH_PRIMITIVE (p, (int) res, A68_INT); } } } /*! \brief PROC (REF FILE) VOID reset \param p position in tree **/ void genie_reset (NODE_T * p) { A68_REF ref_file; A68_FILE *file; POP_REF (p, &ref_file); CHECK_REF (p, ref_file, MODE (REF_FILE)); file = FILE_DEREF (&ref_file); CHECK_INIT (p, INITIALISED (file), MODE (FILE)); if (!OPENED (file)) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FILE_NOT_OPEN); exit_genie (p, A68_RUNTIME_ERROR); } if (!RESET (&CHANNEL (file))) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FILE_CANT_RESET); exit_genie (p, A68_RUNTIME_ERROR); } if (IS_NIL (STRING (file))) { close_file_entry (p, FILE_ENTRY (file)); } else { STRPOS (file) = 1; } READ_MOOD (file) = A68_FALSE; WRITE_MOOD (file) = A68_FALSE; CHAR_MOOD (file) = A68_FALSE; DRAW_MOOD (file) = A68_FALSE; FD (file) = A68_NO_FILENO; /* set_default_event_procedures (file); */ } /*! \brief PROC (REF FILE, PROC (REF FILE) BOOL) VOID on file end \param p position in tree **/ void genie_on_file_end (NODE_T * p) { A68_PROCEDURE z; A68_REF ref_file; A68_FILE *file; POP_PROCEDURE (p, &z); POP_REF (p, &ref_file); CHECK_REF (p, ref_file, MODE (REF_FILE)); file = FILE_DEREF (&ref_file); CHECK_INIT (p, INITIALISED (file), MODE (FILE)); FILE_END_MENDED (file) = z; } /*! \brief PROC (REF FILE, PROC (REF FILE) BOOL) VOID on page end \param p position in tree **/ void genie_on_page_end (NODE_T * p) { A68_PROCEDURE z; A68_REF ref_file; A68_FILE *file; POP_PROCEDURE (p, &z); POP_REF (p, &ref_file); CHECK_REF (p, ref_file, MODE (REF_FILE)); file = FILE_DEREF (&ref_file); CHECK_INIT (p, INITIALISED (file), MODE (FILE)); PAGE_END_MENDED (file) = z; } /*! \brief PROC (REF FILE, PROC (REF FILE) BOOL) VOID on line end \param p position in tree **/ void genie_on_line_end (NODE_T * p) { A68_PROCEDURE z; A68_REF ref_file; A68_FILE *file; POP_PROCEDURE (p, &z); POP_REF (p, &ref_file); CHECK_REF (p, ref_file, MODE (REF_FILE)); file = FILE_DEREF (&ref_file); CHECK_INIT (p, INITIALISED (file), MODE (FILE)); LINE_END_MENDED (file) = z; } /*! \brief PROC (REF FILE, PROC (REF FILE) BOOL) VOID on format end \param p position in tree **/ void genie_on_format_end (NODE_T * p) { A68_PROCEDURE z; A68_REF ref_file; A68_FILE *file; POP_PROCEDURE (p, &z); POP_REF (p, &ref_file); CHECK_REF (p, ref_file, MODE (REF_FILE)); file = FILE_DEREF (&ref_file); CHECK_INIT (p, INITIALISED (file), MODE (FILE)); FORMAT_END_MENDED (file) = z; } /*! \brief PROC (REF FILE, PROC (REF FILE) BOOL) VOID on format error \param p position in tree **/ void genie_on_format_error (NODE_T * p) { A68_PROCEDURE z; A68_REF ref_file; A68_FILE *file; POP_PROCEDURE (p, &z); POP_REF (p, &ref_file); CHECK_REF (p, ref_file, MODE (REF_FILE)); file = FILE_DEREF (&ref_file); CHECK_INIT (p, INITIALISED (file), MODE (FILE)); FORMAT_ERROR_MENDED (file) = z; } /*! \brief PROC (REF FILE, PROC (REF FILE) BOOL) VOID on value error \param p position in tree **/ void genie_on_value_error (NODE_T * p) { A68_PROCEDURE z; A68_REF ref_file; A68_FILE *file; POP_PROCEDURE (p, &z); POP_REF (p, &ref_file); CHECK_REF (p, ref_file, MODE (REF_FILE)); file = FILE_DEREF (&ref_file); CHECK_INIT (p, INITIALISED (file), MODE (FILE)); VALUE_ERROR_MENDED (file) = z; } /*! \brief PROC (REF FILE, PROC (REF FILE) BOOL) VOID on open error \param p position in tree **/ void genie_on_open_error (NODE_T * p) { A68_PROCEDURE z; A68_REF ref_file; A68_FILE *file; POP_PROCEDURE (p, &z); POP_REF (p, &ref_file); CHECK_REF (p, ref_file, MODE (REF_FILE)); file = FILE_DEREF (&ref_file); CHECK_INIT (p, INITIALISED (file), MODE (FILE)); OPEN_ERROR_MENDED (file) = z; } /*! \brief PROC (REF FILE, PROC (REF FILE) BOOL) VOID on transput error \param p position in tree **/ void genie_on_transput_error (NODE_T * p) { A68_PROCEDURE z; A68_REF ref_file; A68_FILE *file; POP_PROCEDURE (p, &z); POP_REF (p, &ref_file); CHECK_REF (p, ref_file, MODE (REF_FILE)); file = FILE_DEREF (&ref_file); CHECK_INIT (p, INITIALISED (file), MODE (FILE)); TRANSPUT_ERROR_MENDED (file) = z; } /*! \brief invoke event routine \param p position in tree \param z routine to invoke \param ref_file fat pointer to A68 file **/ void on_event_handler (NODE_T * p, A68_PROCEDURE z, A68_REF ref_file) { if (NODE (&(BODY (&z))) == NO_NODE) { /* Default procedure */ PUSH_PRIMITIVE (p, A68_FALSE, A68_BOOL); } else { ADDR_T pop_sp = stack_pointer, pop_fp = frame_pointer; PUSH_REF (p, ref_file); genie_call_event_routine (p, MODE (PROC_REF_FILE_BOOL), &z, pop_sp, pop_fp); } } /*! \brief handle end-of-file event \param p position in tree \param ref_file fat pointer to A68 file **/ void end_of_file_error (NODE_T * p, A68_REF ref_file) { A68_BOOL z; on_event_handler (p, FILE_END_MENDED (FILE_DEREF (&ref_file)), ref_file); POP_OBJECT (p, &z, A68_BOOL); if (VALUE (&z) == A68_FALSE) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FILE_ENDED); exit_genie (p, A68_RUNTIME_ERROR); } } /*! \brief handle file-open-error event \param p position in tree \param ref_file fat pointer to A68 file \param mode mode for opening **/ void open_error (NODE_T * p, A68_REF ref_file, char *mode) { A68_BOOL z; on_event_handler (p, OPEN_ERROR_MENDED (FILE_DEREF (&ref_file)), ref_file); POP_OBJECT (p, &z, A68_BOOL); if (VALUE (&z) == A68_FALSE) { A68_FILE *file; char *filename; CHECK_REF (p, ref_file, MODE (REF_FILE)); file = FILE_DEREF (&ref_file); CHECK_INIT (p, INITIALISED (file), MODE (FILE)); if (!IS_NIL (IDENTIFICATION (file))) { filename = DEREF (char, &IDENTIFICATION (FILE_DEREF (&ref_file))); } else { filename = "(missing filename)"; } diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FILE_CANNOT_OPEN_FOR, filename, mode); exit_genie (p, A68_RUNTIME_ERROR); } } /*! \brief handle value error event \param p position in tree \param m mode of object read or written \param ref_file fat pointer to A68 file **/ void value_error (NODE_T * p, MOID_T * m, A68_REF ref_file) { A68_FILE *f = FILE_DEREF (&ref_file); if (END_OF_FILE (f)) { end_of_file_error (p, ref_file); } else { A68_BOOL z; on_event_handler (p, VALUE_ERROR_MENDED (f), ref_file); POP_OBJECT (p, &z, A68_BOOL); if (VALUE (&z) == A68_FALSE) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FILE_TRANSPUT, m); exit_genie (p, A68_RUNTIME_ERROR); } } } /*! \brief handle value_error event \param p position in tree \param m mode of object read or written \param ref_file fat pointer to A68 file **/ void value_sign_error (NODE_T * p, MOID_T * m, A68_REF ref_file) { A68_FILE *f = FILE_DEREF (&ref_file); if (END_OF_FILE (f)) { end_of_file_error (p, ref_file); } else { A68_BOOL z; on_event_handler (p, VALUE_ERROR_MENDED (f), ref_file); POP_OBJECT (p, &z, A68_BOOL); if (VALUE (&z) == A68_FALSE) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FILE_TRANSPUT_SIGN, m); exit_genie (p, A68_RUNTIME_ERROR); } } } /*! \brief handle transput-error event \param p position in tree \param ref_file fat pointer to A68 file \param m mode of object read or written **/ void transput_error (NODE_T * p, A68_REF ref_file, MOID_T * m) { A68_BOOL z; on_event_handler (p, TRANSPUT_ERROR_MENDED (FILE_DEREF (&ref_file)), ref_file); POP_OBJECT (p, &z, A68_BOOL); if (VALUE (&z) == A68_FALSE) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FILE_TRANSPUT, m); exit_genie (p, A68_RUNTIME_ERROR); } } /* Implementation of put and get */ /*! \brief get next char from file \param f file \return same **/ 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; GET_DESCRIPTOR (a, t, &z); if (ROW_SIZE (t) <= 0 || STRPOS (f) < LWB (t) || STRPOS (f) > 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, STRPOS (f))]); STRPOS (f)++; return (VALUE (ch)); } } } /*! \brief push back look-ahead character to file \param p position in tree \param f file \param ch character to push **/ void unchar_scanner (NODE_T * p, A68_FILE * f, char ch) { END_OF_FILE (f) = A68_FALSE; add_char_transput_buffer (p, TRANSPUT_BUFFER (f), ch); } /*! \brief PROC (REF FILE) BOOL eof \param p position in tree **/ void genie_eof (NODE_T * p) { A68_REF ref_file; A68_FILE *file; POP_REF (p, &ref_file); CHECK_REF (p, ref_file, MODE (REF_FILE)); file = FILE_DEREF (&ref_file); CHECK_INIT (p, INITIALISED (file), MODE (FILE)); if (!OPENED (file)) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FILE_NOT_OPEN); exit_genie (p, A68_RUNTIME_ERROR); } if (DRAW_MOOD (file)) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "draw"); exit_genie (p, A68_RUNTIME_ERROR); } if (WRITE_MOOD (file)) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "write"); exit_genie (p, A68_RUNTIME_ERROR); } else if (READ_MOOD (file)) { int ch = char_scanner (file); PUSH_PRIMITIVE (p, (BOOL_T) ((ch == EOF_CHAR || END_OF_FILE (file)) ? A68_TRUE : A68_FALSE), A68_BOOL); unchar_scanner (p, file, (char) ch); } else { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "undetermined"); exit_genie (p, A68_RUNTIME_ERROR); } } /*! \brief PROC (REF FILE) BOOL eoln \param p position in tree **/ void genie_eoln (NODE_T * p) { A68_REF ref_file; A68_FILE *file; POP_REF (p, &ref_file); CHECK_REF (p, ref_file, MODE (REF_FILE)); file = FILE_DEREF (&ref_file); CHECK_INIT (p, INITIALISED (file), MODE (FILE)); if (!OPENED (file)) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FILE_NOT_OPEN); exit_genie (p, A68_RUNTIME_ERROR); } if (DRAW_MOOD (file)) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "draw"); exit_genie (p, A68_RUNTIME_ERROR); } if (WRITE_MOOD (file)) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "write"); exit_genie (p, A68_RUNTIME_ERROR); } else if (READ_MOOD (file)) { int ch = char_scanner (file); if (END_OF_FILE (file)) { end_of_file_error (p, ref_file); } PUSH_PRIMITIVE (p, (BOOL_T) (ch == NEWLINE_CHAR ? A68_TRUE : A68_FALSE), A68_BOOL); unchar_scanner (p, file, (char) ch); } else { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "undetermined"); exit_genie (p, A68_RUNTIME_ERROR); } } /*! \brief PROC (REF FILE) VOID new line \param p position in tree **/ void genie_new_line (NODE_T * p) { A68_REF ref_file; A68_FILE *file; POP_REF (p, &ref_file); CHECK_REF (p, ref_file, MODE (REF_FILE)); file = FILE_DEREF (&ref_file); CHECK_INIT (p, INITIALISED (file), MODE (FILE)); if (!OPENED (file)) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FILE_NOT_OPEN); exit_genie (p, A68_RUNTIME_ERROR); } if (DRAW_MOOD (file)) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "draw"); exit_genie (p, A68_RUNTIME_ERROR); } if (WRITE_MOOD (file)) { if (IS_NIL (STRING (file))) { WRITE (FD (file), NEWLINE_STRING); } else { add_c_string_to_a_string (p, STRING (file), NEWLINE_STRING); } } else if (READ_MOOD (file)) { BOOL_T go_on = A68_TRUE; while (go_on) { int ch; if (END_OF_FILE (file)) { end_of_file_error (p, ref_file); } ch = char_scanner (file); go_on = (BOOL_T) ((ch != NEWLINE_CHAR) && (ch != EOF_CHAR) && !END_OF_FILE (file)); } } else { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "undetermined"); exit_genie (p, A68_RUNTIME_ERROR); } } /*! \brief PROC (REF FILE) VOID new page \param p position in tree **/ void genie_new_page (NODE_T * p) { A68_REF ref_file; A68_FILE *file; POP_REF (p, &ref_file); CHECK_REF (p, ref_file, MODE (REF_FILE)); file = FILE_DEREF (&ref_file); CHECK_INIT (p, INITIALISED (file), MODE (FILE)); if (!OPENED (file)) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FILE_NOT_OPEN); exit_genie (p, A68_RUNTIME_ERROR); } if (DRAW_MOOD (file)) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "draw"); exit_genie (p, A68_RUNTIME_ERROR); } if (WRITE_MOOD (file)) { if (IS_NIL (STRING (file))) { WRITE (FD (file), "\f"); } else { add_c_string_to_a_string (p, STRING (file), "\f"); } } else if (READ_MOOD (file)) { BOOL_T go_on = A68_TRUE; while (go_on) { int ch; if (END_OF_FILE (file)) { end_of_file_error (p, ref_file); } ch = char_scanner (file); go_on = (BOOL_T) ((ch != FORMFEED_CHAR) && (ch != EOF_CHAR) && !END_OF_FILE (file)); } } else { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "undetermined"); exit_genie (p, A68_RUNTIME_ERROR); } } /*! \brief PROC (REF FILE) VOID space \param p position in tree **/ void genie_space (NODE_T * p) { A68_REF ref_file; A68_FILE *file; POP_REF (p, &ref_file); CHECK_REF (p, ref_file, MODE (REF_FILE)); file = FILE_DEREF (&ref_file); CHECK_INIT (p, INITIALISED (file), MODE (FILE)); if (!OPENED (file)) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FILE_NOT_OPEN); exit_genie (p, A68_RUNTIME_ERROR); } if (DRAW_MOOD (file)) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "draw"); exit_genie (p, A68_RUNTIME_ERROR); } if (WRITE_MOOD (file)) { WRITE (FD (file), " "); } else if (READ_MOOD (file)) { if (!END_OF_FILE (file)) { (void) char_scanner (file); } } else { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "undetermined"); exit_genie (p, A68_RUNTIME_ERROR); } } #define IS_NL_FF(ch) ((ch) == NEWLINE_CHAR || (ch) == FORMFEED_CHAR) /*! \brief skip new-lines and form-feeds \param p position in tree \param ch pointer to scanned character \param ref_file fat pointer to A68 file **/ void skip_nl_ff (NODE_T * p, int *ch, A68_REF ref_file) { A68_FILE *f = FILE_DEREF (&ref_file); while ((*ch) != EOF_CHAR && IS_NL_FF (*ch)) { A68_BOOL *z = (A68_BOOL *) STACK_TOP; ADDR_T pop_sp = stack_pointer; unchar_scanner (p, f, (char) (*ch)); if (*ch == NEWLINE_CHAR) { on_event_handler (p, LINE_END_MENDED (f), ref_file); stack_pointer = pop_sp; if (VALUE (z) == A68_FALSE) { PUSH_REF (p, ref_file); genie_new_line (p); } } else if (*ch == FORMFEED_CHAR) { on_event_handler (p, PAGE_END_MENDED (f), ref_file); stack_pointer = pop_sp; if (VALUE (z) == A68_FALSE) { PUSH_REF (p, ref_file); genie_new_page (p); } } (*ch) = char_scanner (f); } } /*! \brief scan an int from file \param p position in tree \param ref_file fat pointer to A68 file **/ void scan_integer (NODE_T * p, A68_REF ref_file) { A68_FILE *f = FILE_DEREF (&ref_file); int ch; reset_transput_buffer (INPUT_BUFFER); ch = char_scanner (f); while (ch != EOF_CHAR && (IS_SPACE (ch) || IS_NL_FF (ch))) { if (IS_NL_FF (ch)) { skip_nl_ff (p, &ch, ref_file); } else { ch = char_scanner (f); } } if (ch != EOF_CHAR && (ch == '+' || ch == '-')) { add_char_transput_buffer (p, INPUT_BUFFER, (char) ch); ch = char_scanner (f); } while (ch != EOF_CHAR && IS_DIGIT (ch)) { add_char_transput_buffer (p, INPUT_BUFFER, (char) ch); ch = char_scanner (f); } if (ch != EOF_CHAR) { unchar_scanner (p, f, (char) ch); } } /*! \brief scan a real from file \param p position in tree \param ref_file fat pointer to A68 file **/ void scan_real (NODE_T * p, A68_REF ref_file) { A68_FILE *f = FILE_DEREF (&ref_file); char x_e = EXPONENT_CHAR; int ch; reset_transput_buffer (INPUT_BUFFER); ch = char_scanner (f); while (ch != EOF_CHAR && (IS_SPACE (ch) || IS_NL_FF (ch))) { if (IS_NL_FF (ch)) { skip_nl_ff (p, &ch, ref_file); } else { ch = char_scanner (f); } } if (ch != EOF_CHAR && (ch == '+' || ch == '-')) { add_char_transput_buffer (p, INPUT_BUFFER, (char) ch); ch = char_scanner (f); } while (ch != EOF_CHAR && IS_DIGIT (ch)) { add_char_transput_buffer (p, INPUT_BUFFER, (char) ch); ch = char_scanner (f); } if (ch == EOF_CHAR || !(ch == POINT_CHAR || TO_UPPER (ch) == TO_UPPER (x_e))) { goto salida; } if (ch == POINT_CHAR) { add_char_transput_buffer (p, INPUT_BUFFER, (char) ch); ch = char_scanner (f); while (ch != EOF_CHAR && IS_DIGIT (ch)) { add_char_transput_buffer (p, INPUT_BUFFER, (char) ch); ch = char_scanner (f); } } if (ch == EOF_CHAR || TO_UPPER (ch) != TO_UPPER (x_e)) { goto salida; } if (TO_UPPER (ch) == TO_UPPER (x_e)) { add_char_transput_buffer (p, INPUT_BUFFER, (char) ch); ch = char_scanner (f); while (ch != EOF_CHAR && ch == BLANK_CHAR) { ch = char_scanner (f); } if (ch != EOF_CHAR && (ch == '+' || ch == '-')) { add_char_transput_buffer (p, INPUT_BUFFER, (char) ch); ch = char_scanner (f); } while (ch != EOF_CHAR && IS_DIGIT (ch)) { add_char_transput_buffer (p, INPUT_BUFFER, (char) ch); ch = char_scanner (f); } } salida:if (ch != EOF_CHAR) { unchar_scanner (p, f, (char) ch); } } /*! \brief scan a bits from file \param p position in tree \param ref_file fat pointer to A68 file **/ void scan_bits (NODE_T * p, A68_REF ref_file) { A68_FILE *f = FILE_DEREF (&ref_file); int ch, flip = FLIP_CHAR, flop = FLOP_CHAR; reset_transput_buffer (INPUT_BUFFER); ch = char_scanner (f); while (ch != EOF_CHAR && (IS_SPACE (ch) || IS_NL_FF (ch))) { if (IS_NL_FF (ch)) { skip_nl_ff (p, &ch, ref_file); } else { ch = char_scanner (f); } } while (ch != EOF_CHAR && (ch == flip || ch == flop)) { add_char_transput_buffer (p, INPUT_BUFFER, (char) ch); ch = char_scanner (f); } if (ch != EOF_CHAR) { unchar_scanner (p, f, (char) ch); } } /*! \brief scan a char from file \param p position in tree \param ref_file fat pointer to A68 file **/ void scan_char (NODE_T * p, A68_REF ref_file) { A68_FILE *f = FILE_DEREF (&ref_file); int ch; reset_transput_buffer (INPUT_BUFFER); ch = char_scanner (f); skip_nl_ff (p, &ch, ref_file); if (ch != EOF_CHAR) { add_char_transput_buffer (p, INPUT_BUFFER, (char) ch); } } /*! \brief scan a string from file \param p position in tree \param term string with terminators \param ref_file fat pointer to A68 file **/ void scan_string (NODE_T * p, char *term, A68_REF ref_file) { A68_FILE *f = FILE_DEREF (&ref_file); if (END_OF_FILE (f)) { reset_transput_buffer (INPUT_BUFFER); end_of_file_error (p, ref_file); } else { BOOL_T go_on; int ch; reset_transput_buffer (INPUT_BUFFER); ch = char_scanner (f); go_on = A68_TRUE; while (go_on) { if (ch == EOF_CHAR || END_OF_FILE (f)) { if (get_transput_buffer_index (INPUT_BUFFER) == 0) { end_of_file_error (p, ref_file); } go_on = A68_FALSE; } else if (IS_NL_FF (ch)) { ADDR_T pop_sp = stack_pointer; unchar_scanner (p, f, (char) ch); if (ch == NEWLINE_CHAR) { on_event_handler (p, LINE_END_MENDED (f), ref_file); } else if (ch == FORMFEED_CHAR) { on_event_handler (p, PAGE_END_MENDED (f), ref_file); } stack_pointer = pop_sp; go_on = A68_FALSE; } else if (term != NO_TEXT && a68g_strchr (term, ch) != NO_TEXT) { go_on = A68_FALSE; unchar_scanner (p, f, (char) ch); } else { add_char_transput_buffer (p, INPUT_BUFFER, (char) ch); ch = char_scanner (f); } } } } /*! \brief make temp file name \param fn pointer to string to hold filename \param permissions permissions to open file with \return whether file is good for use **/ BOOL_T a68g_mkstemp (char *fn, int flags, mode_t permissions) { /* "tmpnam" is not safe, "mkstemp" is Unix, so a68g brings its own tmpnam */ #define TMP_SIZE 32 #define TRIALS 32 char tfilename[BUFFER_SIZE]; char *letters = "0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"; int i, k, len = (int) strlen (letters); BOOL_T good_file = A68_FALSE; /* Next are prefixes to try. First we try /tmp, and if that won't go, the current dir. */ char *prefix[] = { "/tmp/a68g_", "./a68g_", NO_TEXT }; for (i = 0; prefix[i] != NO_TEXT; i ++) { for (k = 0; k < TRIALS && good_file == A68_FALSE; k++) { int j, cindex; FILE_T fd; bufcpy (tfilename, prefix[i], BUFFER_SIZE); for (j = 0; j < TMP_SIZE; j++) { char chars[2]; do { cindex = (int) (rng_53_bit () * len); } while (cindex < 0 || cindex >= len); chars[0] = letters[cindex]; chars[1] = NULL_CHAR; bufcat (tfilename, chars, BUFFER_SIZE); } bufcat (tfilename, ".tmp", BUFFER_SIZE); RESET_ERRNO; fd = open (tfilename, flags | O_EXCL, permissions); good_file = (BOOL_T) (fd != A68_NO_FILENO && errno == 0); if (good_file) { (void) close (fd); } } } if (good_file) { bufcpy (fn, tfilename, BUFFER_SIZE); return (A68_TRUE); } else { return (A68_FALSE); } #undef TMP_SIZE #undef TRIALS } /*! \brief open a file, or establish it \param p position in tree \param ref_file fat pointer to A68 file \param flags required access mode \param permissions optional permissions \return file number **/ FILE_T open_physical_file (NODE_T * p, A68_REF ref_file, int flags, mode_t permissions) { A68_FILE *file; A68_REF ref_filename; char *filename; BOOL_T reading = (flags & ~O_BINARY) == A68_READ_ACCESS; BOOL_T writing = (flags & ~O_BINARY) == A68_WRITE_ACCESS; ABEND (reading == writing, ERROR_INTERNAL_CONSISTENCY, NO_TEXT); CHECK_REF (p, ref_file, MODE (REF_FILE)); file = FILE_DEREF (&ref_file); CHECK_INIT (p, INITIALISED (file), MODE (FILE)); if (!IS_NIL (STRING (file))) { /* Associated file */ TRANSPUT_BUFFER (file) = get_unblocked_transput_buffer (p); reset_transput_buffer (TRANSPUT_BUFFER (file)); END_OF_FILE (file) = A68_FALSE; FILE_ENTRY (file) = -1; return (FD (file)); } else if (IS_NIL (IDENTIFICATION (file))) { /* No identification, so generate a unique identification. */ if (reading) { return (A68_NO_FILENO); } else { char tfilename[BUFFER_SIZE]; int len; if (!a68g_mkstemp (tfilename, flags, permissions)) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FILE_NO_TEMP); exit_genie (p, A68_RUNTIME_ERROR); } FD (file) = open (tfilename, flags, permissions); len = 1 + (int) strlen (tfilename); IDENTIFICATION (file) = heap_generator (p, MODE (C_STRING), len); BLOCK_GC_HANDLE (&(IDENTIFICATION (file))); bufcpy (DEREF (char, &IDENTIFICATION (file)), tfilename, len); TRANSPUT_BUFFER (file) = get_unblocked_transput_buffer (p); reset_transput_buffer (TRANSPUT_BUFFER (file)); END_OF_FILE (file) = A68_FALSE; TMP_FILE (file) = A68_TRUE; FILE_ENTRY (file) = store_file_entry (p, FD (file), tfilename, TMP_FILE (file)); return (FD (file)); } } else { /* Opening an identified file */ ref_filename = IDENTIFICATION (file); CHECK_REF (p, ref_filename, MODE (ROWS)); filename = DEREF (char, &ref_filename); if (OPEN_EXCLUSIVE (file)) { /* Establishing requires that the file does not exist */ if (flags == (A68_WRITE_ACCESS)) { flags |= O_EXCL; } OPEN_EXCLUSIVE (file) = A68_FALSE; } FD (file) = open (filename, flags, permissions); TRANSPUT_BUFFER (file) = get_unblocked_transput_buffer (p); reset_transput_buffer (TRANSPUT_BUFFER (file)); END_OF_FILE (file) = A68_FALSE; FILE_ENTRY (file) = store_file_entry (p, FD (file), filename, TMP_FILE (file)); return (FD (file)); } } /*! \brief call PROC (REF FILE) VOID during transput \param p position in tree \param ref_file fat pointer to A68 file \param z A68 routine to call **/ void genie_call_proc_ref_file_void (NODE_T * p, A68_REF ref_file, A68_PROCEDURE z) { ADDR_T pop_sp = stack_pointer, pop_fp = frame_pointer; MOID_T *u = MODE (PROC_REF_FILE_VOID); PUSH_REF (p, ref_file); genie_call_procedure (p, MOID (&z), u, u, &z, pop_sp, pop_fp); stack_pointer = pop_sp; /* VOIDING */ } /* Unformatted transput */ /*! \brief hexadecimal value of digit \param ch digit \return same **/ static int char_value (int ch) { switch (ch) { case '0': { return (0); } case '1': { return (1); } case '2': { return (2); } case '3': { return (3); } case '4': { return (4); } case '5': { return (5); } case '6': { return (6); } case '7': { return (7); } case '8': { return (8); } case '9': { return (9); } case 'A': case 'a': { return (10); } case 'B': case 'b': { return (11); } case 'C': case 'c': { return (12); } case 'D': case 'd': { return (13); } case 'E': case 'e': { return (14); } case 'F': case 'f': { return (15); } default: { return (-1); } } } /*! \brief own strtoul; some systems have no strtoul \param str string representing an unsigned int denotation \param end points to first character after denotation \param base exponent base \return value of denotation in str **/ unsigned a68g_strtoul (char *str, char **end, int base) { if (str == NO_TEXT || str[0] == NULL_CHAR) { (*end) = NO_TEXT; errno = EDOM; return (0); } else { int j, k = 0, start; char *q = str; unsigned mul = 1, sum = 0; while (IS_SPACE (q[k])) { k++; } if (q[k] == '+') { k++; } start = k; while (IS_XDIGIT (q[k])) { k++; } if (k == start) { if (end != NO_VAR) { *end = str; } errno = EDOM; return (0); } if (end != NO_VAR) { (*end) = &q[k]; } for (j = k - 1; j >= start; j--) { if (char_value (q[j]) >= base) { errno = EDOM; return (0); } else { unsigned add = (unsigned) ((unsigned) (char_value (q[j])) * mul); if (A68_MAX_UNT - sum >= add) { sum += add; mul *= (unsigned) base; } else { errno = ERANGE; return (0); } } } return (sum); } } /*! \brief INT value of BITS denotation \param p position in tree \param str string with BITS denotation \return same **/ static unsigned bits_to_int (NODE_T * p, char *str) { int base = 0; unsigned bits = 0; char *radix = NO_TEXT, *end = NO_TEXT; RESET_ERRNO; base = (int) a68g_strtoul (str, &radix, 10); if (radix != NO_TEXT && TO_UPPER (radix[0]) == TO_UPPER (RADIX_CHAR) && errno == 0) { if (base < 2 || base > 16) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_INVALID_RADIX, base); exit_genie (p, A68_RUNTIME_ERROR); } bits = a68g_strtoul (&(radix[1]), &end, base); if (end != NO_TEXT && end[0] == NULL_CHAR && errno == 0) { return (bits); } } diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_IN_DENOTATION, MODE (BITS)); exit_genie (p, A68_RUNTIME_ERROR); return (0); } /*! \brief LONG BITS value of LONG BITS denotation \param p position in tree \param z multi-precision number \param str string with LONG BITS denotation \param m mode of 'z' **/ static void long_bits_to_long_int (NODE_T * p, MP_T * z, char *str, MOID_T * m) { int base = 0; char *radix = NO_TEXT; RESET_ERRNO; base = (int) a68g_strtoul (str, &radix, 10); if (radix != NO_TEXT && TO_UPPER (radix[0]) == TO_UPPER (RADIX_CHAR) && errno == 0) { int digits = get_mp_digits (m); ADDR_T pop_sp = stack_pointer; MP_T *v; MP_T *w; char *q = radix; STACK_MP (v, p, digits); STACK_MP (w, p, digits); while (q[0] != NULL_CHAR) { q++; } SET_MP_ZERO (z, digits); (void) set_mp_short (w, (MP_T) 1, 0, digits); if (base < 2 || base > 16) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_INVALID_RADIX, base); exit_genie (p, A68_RUNTIME_ERROR); } while ((--q) != radix) { int digit = char_value (q[0]); if (digit >= 0 && digit < base) { (void) mul_mp_digit (p, v, w, (MP_T) digit, digits); (void) add_mp (p, z, z, v, digits); } else { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_IN_DENOTATION, m); exit_genie (p, A68_RUNTIME_ERROR); } (void) mul_mp_digit (p, w, w, (MP_T) base, digits); } check_long_bits_value (p, z, m); stack_pointer = pop_sp; } else { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_IN_DENOTATION, m); exit_genie (p, A68_RUNTIME_ERROR); } } /*! \brief convert string to required mode and store \param p position in tree \param m mode to convert to \param a string to convert \param item where to store result \return whether conversion is successful **/ BOOL_T genie_string_to_value_internal (NODE_T * p, MOID_T * m, char *a, BYTE_T * item) { RESET_ERRNO; /* strto.. does not mind empty strings */ if (strlen (a) == 0) { return (A68_FALSE); } if (m == MODE (INT)) { A68_INT *z = (A68_INT *) item; char *end; VALUE (z) = (int) strtol (a, &end, 10); if (end[0] == NULL_CHAR && errno == 0) { STATUS (z) = INIT_MASK; return (A68_TRUE); } else { return (A68_FALSE); } } else if (m == MODE (REAL)) { A68_REAL *z = (A68_REAL *) item; char *end; VALUE (z) = strtod (a, &end); if (end[0] == NULL_CHAR && errno == 0) { STATUS (z) = INIT_MASK; return (A68_TRUE); } else { return (A68_FALSE); } } else if (m == MODE (LONG_INT) || m == MODE (LONGLONG_INT)) { int digits = get_mp_digits (m); MP_T *z = (MP_T *) item; if (string_to_mp (p, z, a, digits) == NO_MP) { return (A68_FALSE); } if (!check_mp_int (z, m)) { errno = ERANGE; return (A68_FALSE); } MP_STATUS (z) = (MP_T) INIT_MASK; return (A68_TRUE); } else if (m == MODE (LONG_REAL) || m == MODE (LONGLONG_REAL)) { int digits = get_mp_digits (m); MP_T *z = (MP_T *) item; if (string_to_mp (p, z, a, digits) == NO_MP) { return (A68_FALSE); } MP_STATUS (z) = (MP_T) INIT_MASK; return (A68_TRUE); } else if (m == MODE (BOOL)) { A68_BOOL *z = (A68_BOOL *) item; char q = a[0], flip = FLIP_CHAR, flop = FLOP_CHAR; if (q == flip || q == flop) { VALUE (z) = (BOOL_T) (q == flip); STATUS (z) = INIT_MASK; return (A68_TRUE); } else { return (A68_FALSE); } } else if (m == MODE (BITS)) { A68_BITS *z = (A68_BITS *) item; int status = A68_TRUE; if (a[0] == FLIP_CHAR || a[0] == FLOP_CHAR) { /* [] BOOL denotation is "TTFFFFTFT ..." */ if (strlen (a) > (size_t) BITS_WIDTH) { errno = ERANGE; status = A68_FALSE; } else { int j = (int) strlen (a) - 1; unsigned k = 0x1; VALUE (z) = 0; for (; j >= 0; j--) { if (a[j] == FLIP_CHAR) { VALUE (z) += k; } else if (a[j] != FLOP_CHAR) { status = A68_FALSE; } k <<= 1; } } } else { /* BITS denotation is also allowed */ VALUE (z) = bits_to_int (p, a); } if (errno != 0 || status == A68_FALSE) { return (A68_FALSE); } STATUS (z) = INIT_MASK; return (A68_TRUE); } else if (m == MODE (LONG_BITS) || m == MODE (LONGLONG_BITS)) { int digits = get_mp_digits (m); int status = A68_TRUE; ADDR_T pop_sp = stack_pointer; MP_T *z = (MP_T *) item; if (a[0] == FLIP_CHAR || a[0] == FLOP_CHAR) { /* [] BOOL denotation is "TTFFFFTFT ..." */ if (strlen (a) > (size_t) BITS_WIDTH) { errno = ERANGE; status = A68_FALSE; } else { int j; MP_T *w; STACK_MP (w, p, digits); SET_MP_ZERO (z, digits); (void) set_mp_short (w, (MP_T) 1, 0, digits); for (j = (int) strlen (a) - 1; j >= 0; j--) { if (a[j] == FLIP_CHAR) { (void) add_mp (p, z, z, w, digits); } else if (a[j] != FLOP_CHAR) { status = A68_FALSE; } (void) mul_mp_digit (p, w, w, (MP_T) 2, digits); } } } else { /* BITS denotation is also allowed */ long_bits_to_long_int (p, z, a, m); } stack_pointer = pop_sp; if (errno != 0 || status == A68_FALSE) { return (A68_FALSE); } MP_STATUS (z) = (MP_T) INIT_MASK; return (A68_TRUE); } return (A68_FALSE); } /*! \brief convert string in input buffer to value of required mode \param p position in tree \param mode mode to convert to \param item where to store result \param ref_file fat pointer to A68 file **/ void genie_string_to_value (NODE_T * p, MOID_T * mode, BYTE_T * item, A68_REF ref_file) { char *str = get_transput_buffer (INPUT_BUFFER); RESET_ERRNO; add_char_transput_buffer (p, INPUT_BUFFER, NULL_CHAR); /* end string, just in case */ if (mode == MODE (INT)) { if (genie_string_to_value_internal (p, mode, str, item) == A68_FALSE) { value_error (p, mode, ref_file); } } else if (mode == MODE (LONG_INT) || mode == MODE (LONGLONG_INT)) { if (genie_string_to_value_internal (p, mode, str, item) == A68_FALSE) { value_error (p, mode, ref_file); } } else if (mode == MODE (REAL)) { if (genie_string_to_value_internal (p, mode, str, item) == A68_FALSE) { value_error (p, mode, ref_file); } } else if (mode == MODE (LONG_REAL) || mode == MODE (LONGLONG_REAL)) { if (genie_string_to_value_internal (p, mode, str, item) == A68_FALSE) { value_error (p, mode, ref_file); } } else if (mode == MODE (BOOL)) { if (genie_string_to_value_internal (p, mode, str, item) == A68_FALSE) { value_error (p, mode, ref_file); } } else if (mode == MODE (BITS)) { if (genie_string_to_value_internal (p, mode, str, item) == A68_FALSE) { value_error (p, mode, ref_file); } } else if (mode == MODE (LONG_BITS) || mode == MODE (LONGLONG_BITS)) { if (genie_string_to_value_internal (p, mode, str, item) == A68_FALSE) { value_error (p, mode, ref_file); } } else if (mode == MODE (CHAR)) { A68_CHAR *z = (A68_CHAR *) item; if (str[0] == NULL_CHAR) { /* value_error (p, mode, ref_file); */ VALUE (z) = NULL_CHAR; STATUS (z) = INIT_MASK; } else { int len = (int) strlen (str); if (len == 0 || len > 1) { value_error (p, mode, ref_file); } VALUE (z) = str[0]; STATUS (z) = INIT_MASK; } } else if (mode == MODE (STRING)) { A68_REF z; z = c_to_a_string (p, str, get_transput_buffer_index (INPUT_BUFFER) - 1); /* z = c_to_a_string (p, str, DEFAULT_WIDTH); */ *(A68_REF *) item = z; } if (errno != 0) { transput_error (p, ref_file, mode); } } /*! \brief read object from file \param p position in tree \param mode mode to read \param item where to store result \param ref_file fat pointer to A68 file **/ void genie_read_standard (NODE_T * p, MOID_T * mode, BYTE_T * item, A68_REF ref_file) { A68_FILE *f = FILE_DEREF (&ref_file); RESET_ERRNO; if (mode == MODE (INT) || mode == MODE (LONG_INT) || mode == MODE (LONGLONG_INT)) { scan_integer (p, ref_file); genie_string_to_value (p, mode, item, ref_file); } else if (mode == MODE (REAL) || mode == MODE (LONG_REAL) || mode == MODE (LONGLONG_REAL)) { scan_real (p, ref_file); genie_string_to_value (p, mode, item, ref_file); } else if (mode == MODE (BOOL)) { scan_char (p, ref_file); genie_string_to_value (p, mode, item, ref_file); } else if (mode == MODE (CHAR)) { scan_char (p, ref_file); genie_string_to_value (p, mode, item, ref_file); } else if (mode == MODE (BITS) || mode == MODE (LONG_BITS) || mode == MODE (LONGLONG_BITS)) { scan_bits (p, ref_file); genie_string_to_value (p, mode, item, ref_file); } else if (mode == MODE (STRING)) { char *term = DEREF (char, &TERMINATOR (f)); scan_string (p, term, ref_file); genie_string_to_value (p, mode, item, ref_file); } else if (IS (mode, STRUCT_SYMBOL)) { PACK_T *q = PACK (mode); for (; q != NO_PACK; FORWARD (q)) { genie_read_standard (p, MOID (q), &item[OFFSET (q)], ref_file); } } else if (IS (mode, UNION_SYMBOL)) { A68_UNION *z = (A68_UNION *) item; if (!(STATUS (z) | INIT_MASK) || VALUE (z) == NULL) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_EMPTY_VALUE, mode); exit_genie (p, A68_RUNTIME_ERROR); } genie_read_standard (p, (MOID_T *) (VALUE (z)), &item[A68_UNION_SIZE], ref_file); } else if (IS (mode, ROW_SYMBOL) || IS (mode, FLEX_SYMBOL)) { MOID_T *deflexed = DEFLEX (mode); A68_ARRAY *arr; A68_TUPLE *tup; CHECK_INIT (p, INITIALISED ((A68_REF *) item), mode); GET_DESCRIPTOR (arr, tup, (A68_REF *) item); if (get_row_size (tup, DIM (arr)) > 0) { BYTE_T *base_addr = DEREF (BYTE_T, &ARRAY (arr)); BOOL_T done = A68_FALSE; initialise_internal_index (tup, DIM (arr)); while (!done) { ADDR_T a68g_index = calculate_internal_index (tup, DIM (arr)); ADDR_T elem_addr = ROW_ELEMENT (arr, a68g_index); genie_read_standard (p, SUB (deflexed), &base_addr[elem_addr], ref_file); done = increment_internal_index (tup, DIM (arr)); } } } if (errno != 0) { transput_error (p, ref_file, mode); } } /*! \brief PROC ([] SIMPLIN) VOID read \param p position in tree **/ void genie_read (NODE_T * p) { A68_REF row; POP_REF (p, &row); genie_stand_in (p); PUSH_REF (p, row); genie_read_file (p); } /*! \brief open for reading \param p position in tree **/ void open_for_reading (NODE_T * p, A68_REF ref_file) { A68_FILE *file = FILE_DEREF (&ref_file); if (!OPENED (file)) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FILE_NOT_OPEN); exit_genie (p, A68_RUNTIME_ERROR); } if (DRAW_MOOD (file)) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "draw"); exit_genie (p, A68_RUNTIME_ERROR); } if (WRITE_MOOD (file)) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "write"); exit_genie (p, A68_RUNTIME_ERROR); } if (!GET (&CHANNEL (file))) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_CHANNEL_DOES_NOT_ALLOW, "getting"); exit_genie (p, A68_RUNTIME_ERROR); } if (!READ_MOOD (file) && !WRITE_MOOD (file)) { if (IS_NIL (STRING (file))) { if ((FD (file) = open_physical_file (p, ref_file, A68_READ_ACCESS, 0)) == A68_NO_FILENO) { open_error (p, ref_file, "getting"); } } else { FD (file) = open_physical_file (p, ref_file, A68_READ_ACCESS, 0); } DRAW_MOOD (file) = A68_FALSE; READ_MOOD (file) = A68_TRUE; WRITE_MOOD (file) = A68_FALSE; CHAR_MOOD (file) = A68_TRUE; } if (!CHAR_MOOD (file)) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "binary"); exit_genie (p, A68_RUNTIME_ERROR); } } /*! \brief PROC (REF FILE, [] SIMPLIN) VOID get \param p position in tree **/ void genie_read_file (NODE_T * p) { A68_REF ref_file; A68_FILE *file; A68_REF row; A68_ARRAY *arr; A68_TUPLE *tup; BYTE_T *base_address; int elems, k, elem_index; POP_REF (p, &row); CHECK_REF (p, row, MODE (ROW_SIMPLIN)); GET_DESCRIPTOR (arr, tup, &row); elems = ROW_SIZE (tup); POP_REF (p, &ref_file); CHECK_REF (p, ref_file, MODE (REF_FILE)); file = FILE_DEREF (&ref_file); CHECK_INIT (p, INITIALISED (file), MODE (FILE)); open_for_reading (p, ref_file); /* Read */ if (elems <= 0) { return; } base_address = DEREF (BYTE_T, &ARRAY (arr)); elem_index = 0; for (k = 0; k < elems; k++) { A68_UNION *z = (A68_UNION *) & base_address[elem_index]; MOID_T *mode = (MOID_T *) (VALUE (z)); BYTE_T *item = (BYTE_T *) & base_address[elem_index + A68_UNION_SIZE]; if (mode == MODE (PROC_REF_FILE_VOID)) { genie_call_proc_ref_file_void (p, ref_file, *(A68_PROCEDURE *) item); } else if (mode == MODE (FORMAT)) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_UNDEFINED_TRANSPUT, MODE (FORMAT)); exit_genie (p, A68_RUNTIME_ERROR); } else if (mode == MODE (REF_SOUND)) { read_sound (p, ref_file, DEREF (A68_SOUND, (A68_REF *) item)); } else { if (END_OF_FILE (file)) { end_of_file_error (p, ref_file); } CHECK_REF (p, *(A68_REF *) item, mode); genie_read_standard (p, SUB (mode), ADDRESS ((A68_REF *) item), ref_file); } elem_index += MOID_SIZE (MODE (SIMPLIN)); } } /*! \brief convert value to string \param p position in tree \param moid mode to convert to \param item pointer to value \param mod format modifier **/ void genie_value_to_string (NODE_T * p, MOID_T * moid, BYTE_T * item, int mod) { if (moid == MODE (INT)) { A68_INT *z = (A68_INT *) item; PUSH_UNION (p, MODE (INT)); PUSH_PRIMITIVE (p, VALUE (z), A68_INT); INCREMENT_STACK_POINTER (p, MOID_SIZE (MODE (NUMBER)) - (A68_UNION_SIZE + ALIGNED_SIZE_OF (A68_INT))); if (mod == FORMAT_ITEM_G) { PUSH_PRIMITIVE (p, INT_WIDTH + 1, A68_INT); genie_whole (p); } else if (mod == FORMAT_ITEM_H) { PUSH_PRIMITIVE (p, REAL_WIDTH + EXP_WIDTH + 4, A68_INT); PUSH_PRIMITIVE (p, REAL_WIDTH - 1, A68_INT); PUSH_PRIMITIVE (p, EXP_WIDTH + 1, A68_INT); PUSH_PRIMITIVE (p, 3, A68_INT); genie_real (p); } } else if (moid == MODE (LONG_INT)) { MP_T *z = (MP_T *) item; PUSH_UNION (p, MODE (LONG_INT)); PUSH (p, z, get_mp_size (MODE (LONG_INT))); INCREMENT_STACK_POINTER (p, MOID_SIZE (MODE (NUMBER)) - (A68_UNION_SIZE + get_mp_size (MODE (LONG_INT)))); if (mod == FORMAT_ITEM_G) { PUSH_PRIMITIVE (p, LONG_WIDTH + 1, A68_INT); genie_whole (p); } else if (mod == FORMAT_ITEM_H) { PUSH_PRIMITIVE (p, LONG_REAL_WIDTH + LONG_EXP_WIDTH + 4, A68_INT); PUSH_PRIMITIVE (p, LONG_REAL_WIDTH - 1, A68_INT); PUSH_PRIMITIVE (p, LONG_EXP_WIDTH + 1, A68_INT); PUSH_PRIMITIVE (p, 3, A68_INT); genie_real (p); } } else if (moid == MODE (LONGLONG_INT)) { MP_T *z = (MP_T *) item; PUSH_UNION (p, MODE (LONGLONG_INT)); PUSH (p, z, get_mp_size (MODE (LONGLONG_INT))); INCREMENT_STACK_POINTER (p, MOID_SIZE (MODE (NUMBER)) - (A68_UNION_SIZE + get_mp_size (MODE (LONGLONG_INT)))); if (mod == FORMAT_ITEM_G) { PUSH_PRIMITIVE (p, LONGLONG_WIDTH + 1, A68_INT); genie_whole (p); } else if (mod == FORMAT_ITEM_H) { PUSH_PRIMITIVE (p, LONGLONG_REAL_WIDTH + LONGLONG_EXP_WIDTH + 4, A68_INT); PUSH_PRIMITIVE (p, LONGLONG_REAL_WIDTH - 1, A68_INT); PUSH_PRIMITIVE (p, LONGLONG_EXP_WIDTH + 1, A68_INT); PUSH_PRIMITIVE (p, 3, A68_INT); genie_real (p); } } else if (moid == MODE (REAL)) { A68_REAL *z = (A68_REAL *) item; PUSH_UNION (p, MODE (REAL)); PUSH_PRIMITIVE (p, VALUE (z), A68_REAL); INCREMENT_STACK_POINTER (p, MOID_SIZE (MODE (NUMBER)) - (A68_UNION_SIZE + ALIGNED_SIZE_OF (A68_REAL))); PUSH_PRIMITIVE (p, REAL_WIDTH + EXP_WIDTH + 4, A68_INT); PUSH_PRIMITIVE (p, REAL_WIDTH - 1, A68_INT); PUSH_PRIMITIVE (p, EXP_WIDTH + 1, A68_INT); if (mod == FORMAT_ITEM_G) { genie_float (p); } else if (mod == FORMAT_ITEM_H) { PUSH_PRIMITIVE (p, 3, A68_INT); genie_real (p); } } else if (moid == MODE (LONG_REAL)) { MP_T *z = (MP_T *) item; PUSH_UNION (p, MODE (LONG_REAL)); PUSH (p, z, (int) get_mp_size (MODE (LONG_REAL))); INCREMENT_STACK_POINTER (p, MOID_SIZE (MODE (NUMBER)) - (A68_UNION_SIZE + get_mp_size (MODE (LONG_REAL)))); PUSH_PRIMITIVE (p, LONG_REAL_WIDTH + LONG_EXP_WIDTH + 4, A68_INT); PUSH_PRIMITIVE (p, LONG_REAL_WIDTH - 1, A68_INT); PUSH_PRIMITIVE (p, LONG_EXP_WIDTH + 1, A68_INT); if (mod == FORMAT_ITEM_G) { genie_float (p); } else if (mod == FORMAT_ITEM_H) { PUSH_PRIMITIVE (p, 3, A68_INT); genie_real (p); } } else if (moid == MODE (LONGLONG_REAL)) { MP_T *z = (MP_T *) item; PUSH_UNION (p, MODE (LONGLONG_REAL)); PUSH (p, z, (int) get_mp_size (MODE (LONGLONG_REAL))); INCREMENT_STACK_POINTER (p, MOID_SIZE (MODE (NUMBER)) - (A68_UNION_SIZE + get_mp_size (MODE (LONGLONG_REAL)))); PUSH_PRIMITIVE (p, LONGLONG_REAL_WIDTH + LONGLONG_EXP_WIDTH + 4, A68_INT); PUSH_PRIMITIVE (p, LONGLONG_REAL_WIDTH - 1, A68_INT); PUSH_PRIMITIVE (p, LONGLONG_EXP_WIDTH + 1, A68_INT); if (mod == FORMAT_ITEM_G) { genie_float (p); } else if (mod == FORMAT_ITEM_H) { PUSH_PRIMITIVE (p, 3, A68_INT); genie_real (p); } } else if (moid == MODE (BITS)) { A68_BITS *z = (A68_BITS *) item; char *str = stack_string (p, 8 + BITS_WIDTH); unsigned bit = 0x1; int j; for (j = 1; j < BITS_WIDTH; j++) { bit <<= 1; } for (j = 0; j < BITS_WIDTH; j++) { str[j] = (char) ((VALUE (z) & bit) ? FLIP_CHAR : FLOP_CHAR); bit >>= 1; } str[j] = NULL_CHAR; } else if (moid == MODE (LONG_BITS) || moid == MODE (LONGLONG_BITS)) { int bits = get_mp_bits_width (moid), word = get_mp_bits_words (moid); int cher = bits; char *str = stack_string (p, 8 + bits); ADDR_T pop_sp = stack_pointer; unsigned *row = stack_mp_bits (p, (MP_T *) item, moid); str[cher--] = NULL_CHAR; while (cher >= 0) { unsigned bit = 0x1; int j; for (j = 0; j < MP_BITS_BITS && cher >= 0; j++) { str[cher--] = (char) ((row[word - 1] & bit) ? FLIP_CHAR : FLOP_CHAR); bit <<= 1; } word--; } stack_pointer = pop_sp; } } /*! \brief print object to file \param p position in tree \param mode mode of object to print \param item pointer to value \param ref_file fat pointer to A68 file **/ void genie_write_standard (NODE_T * p, MOID_T * mode, BYTE_T * item, A68_REF ref_file) { RESET_ERRNO; if (mode == MODE (INT) || mode == MODE (LONG_INT) || mode == MODE (LONGLONG_INT)) { genie_value_to_string (p, mode, item, FORMAT_ITEM_G); add_string_from_stack_transput_buffer (p, UNFORMATTED_BUFFER); } else if (mode == MODE (REAL) || mode == MODE (LONG_REAL) || mode == MODE (LONGLONG_REAL)) { genie_value_to_string (p, mode, item, FORMAT_ITEM_G); add_string_from_stack_transput_buffer (p, UNFORMATTED_BUFFER); } else if (mode == MODE (BOOL)) { A68_BOOL *z = (A68_BOOL *) item; char flipflop = (char) (VALUE (z) == A68_TRUE ? FLIP_CHAR : FLOP_CHAR); add_char_transput_buffer (p, UNFORMATTED_BUFFER, flipflop); } else if (mode == MODE (CHAR)) { A68_CHAR *ch = (A68_CHAR *) item; add_char_transput_buffer (p, UNFORMATTED_BUFFER, (char) VALUE (ch)); } else if (mode == MODE (BITS) || mode == MODE (LONG_BITS) || mode == MODE (LONGLONG_BITS)) { char *str = (char *) STACK_TOP; genie_value_to_string (p, mode, item, FORMAT_ITEM_G); add_string_transput_buffer (p, UNFORMATTED_BUFFER, str); } else if (mode == MODE (ROW_CHAR) || mode == MODE (STRING)) { /* Handle these separately since this is faster than straightening */ add_a_string_transput_buffer (p, UNFORMATTED_BUFFER, item); } else if (IS (mode, UNION_SYMBOL)) { A68_UNION *z = (A68_UNION *) item; genie_write_standard (p, (MOID_T *) (VALUE (z)), &item[A68_UNION_SIZE], ref_file); } else if (IS (mode, STRUCT_SYMBOL)) { PACK_T *q = PACK (mode); for (; q != NO_PACK; FORWARD (q)) { BYTE_T *elem = &item[OFFSET (q)]; genie_check_initialisation (p, elem, MOID (q)); genie_write_standard (p, MOID (q), elem, ref_file); } } else if (IS (mode, ROW_SYMBOL) || IS (mode, FLEX_SYMBOL)) { MOID_T *deflexed = DEFLEX (mode); A68_ARRAY *arr; A68_TUPLE *tup; CHECK_INIT (p, INITIALISED ((A68_REF *) item), MODE (ROWS)); GET_DESCRIPTOR (arr, tup, (A68_REF *) item); if (get_row_size (tup, DIM (arr)) > 0) { BYTE_T *base_addr = DEREF (BYTE_T, &ARRAY (arr)); BOOL_T done = A68_FALSE; initialise_internal_index (tup, DIM (arr)); while (!done) { ADDR_T a68g_index = calculate_internal_index (tup, DIM (arr)); ADDR_T elem_addr = ROW_ELEMENT (arr, a68g_index); BYTE_T *elem = &base_addr[elem_addr]; genie_check_initialisation (p, elem, SUB (deflexed)); genie_write_standard (p, SUB (deflexed), elem, ref_file); done = increment_internal_index (tup, DIM (arr)); } } } if (errno != 0) { ABEND (IS_NIL (ref_file), "conversion error: ", error_specification ()); transput_error (p, ref_file, mode); } } /*! \brief PROC ([] SIMPLOUT) VOID print, write \param p position in tree **/ void genie_write (NODE_T * p) { A68_REF row; POP_REF (p, &row); genie_stand_out (p); PUSH_REF (p, row); genie_write_file (p); } /*! \brief open for reading \param p position in tree **/ void open_for_writing (NODE_T * p, A68_REF ref_file) { A68_FILE *file = FILE_DEREF (&ref_file); if (!OPENED (file)) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FILE_NOT_OPEN); exit_genie (p, A68_RUNTIME_ERROR); } if (DRAW_MOOD (file)) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "draw"); exit_genie (p, A68_RUNTIME_ERROR); } if (READ_MOOD (file)) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "read"); exit_genie (p, A68_RUNTIME_ERROR); } if (!PUT (&CHANNEL (file))) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_CHANNEL_DOES_NOT_ALLOW, "putting"); exit_genie (p, A68_RUNTIME_ERROR); } if (!READ_MOOD (file) && !WRITE_MOOD (file)) { if (IS_NIL (STRING (file))) { if ((FD (file) = open_physical_file (p, ref_file, A68_WRITE_ACCESS, A68_PROTECTION)) == A68_NO_FILENO) { open_error (p, ref_file, "putting"); } } else { FD (file) = open_physical_file (p, ref_file, A68_READ_ACCESS, 0); } DRAW_MOOD (file) = A68_FALSE; READ_MOOD (file) = A68_FALSE; WRITE_MOOD (file) = A68_TRUE; CHAR_MOOD (file) = A68_TRUE; } if (!CHAR_MOOD (file)) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "binary"); exit_genie (p, A68_RUNTIME_ERROR); } } /*! \brief PROC (REF FILE, [] SIMPLOUT) VOID put \param p position in tree **/ void genie_write_file (NODE_T * p) { A68_REF ref_file; A68_FILE *file; A68_REF row; A68_ARRAY *arr; A68_TUPLE *tup; BYTE_T *base_address; int elems, k, elem_index; POP_REF (p, &row); CHECK_REF (p, row, MODE (ROW_SIMPLOUT)); GET_DESCRIPTOR (arr, tup, &row); elems = ROW_SIZE (tup); POP_REF (p, &ref_file); CHECK_REF (p, ref_file, MODE (REF_FILE)); file = FILE_DEREF (&ref_file); CHECK_INIT (p, INITIALISED (file), MODE (FILE)); open_for_writing (p, ref_file); /* Write. */ if (elems <= 0) { return; } base_address = DEREF (BYTE_T, &ARRAY (arr)); elem_index = 0; for (k = 0; k < elems; k++) { A68_UNION *z = (A68_UNION *) & (base_address[elem_index]); MOID_T *mode = (MOID_T *) (VALUE (z)); BYTE_T *item = (BYTE_T *) & base_address[elem_index + A68_UNION_SIZE]; if (mode == MODE (PROC_REF_FILE_VOID)) { genie_call_proc_ref_file_void (p, ref_file, *(A68_PROCEDURE *) item); } else if (mode == MODE (FORMAT)) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_UNDEFINED_TRANSPUT, MODE (FORMAT)); exit_genie (p, A68_RUNTIME_ERROR); } else if (mode == MODE (SOUND)) { write_sound (p, ref_file, (A68_SOUND *) item); } else { reset_transput_buffer (UNFORMATTED_BUFFER); genie_write_standard (p, mode, item, ref_file); write_purge_buffer (p, ref_file, UNFORMATTED_BUFFER); } elem_index += MOID_SIZE (MODE (SIMPLOUT)); } } /*! \brief read object binary from file \param p position in tree \param mode mode to read \param item pointer to value \param ref_file fat pointer to A68 file **/ static void genie_read_bin_standard (NODE_T * p, MOID_T * mode, BYTE_T * item, A68_REF ref_file) { A68_FILE *f = FILE_DEREF (&ref_file); RESET_ERRNO; if (mode == MODE (INT)) { A68_INT *z = (A68_INT *) item; ASSERT (io_read (FD (f), &(VALUE (z)), sizeof (VALUE (z))) != -1); STATUS (z) = INIT_MASK; } else if (mode == MODE (LONG_INT) || mode == MODE (LONGLONG_INT)) { MP_T *z = (MP_T *) item; ASSERT (io_read (FD (f), z, (size_t) get_mp_size (mode)) != -1); MP_STATUS (z) = (MP_T) INIT_MASK; } else if (mode == MODE (REAL)) { A68_REAL *z = (A68_REAL *) item; ASSERT (io_read (FD (f), &(VALUE (z)), sizeof (VALUE (z))) != -1); STATUS (z) = INIT_MASK; } else if (mode == MODE (LONG_REAL) || mode == MODE (LONGLONG_REAL)) { MP_T *z = (MP_T *) item; ASSERT (io_read (FD (f), z, (size_t) get_mp_size (mode)) != -1); MP_STATUS (z) = (MP_T) INIT_MASK; } else if (mode == MODE (BOOL)) { A68_BOOL *z = (A68_BOOL *) item; ASSERT (io_read (FD (f), &(VALUE (z)), sizeof (VALUE (z))) != -1); STATUS (z) = INIT_MASK; } else if (mode == MODE (CHAR)) { A68_CHAR *z = (A68_CHAR *) item; ASSERT (io_read (FD (f), &(VALUE (z)), sizeof (VALUE (z))) != -1); STATUS (z) = INIT_MASK; } else if (mode == MODE (BITS)) { A68_BITS *z = (A68_BITS *) item; ASSERT (io_read (FD (f), &(VALUE (z)), sizeof (VALUE (z))) != -1); STATUS (z) = INIT_MASK; } else if (mode == MODE (LONG_BITS) || mode == MODE (LONGLONG_BITS)) { MP_T *z = (MP_T *) item; ASSERT (io_read (FD (f), z, (size_t) get_mp_size (mode)) != -1); MP_STATUS (z) = (MP_T) INIT_MASK; } else if (mode == MODE (ROW_CHAR) || mode == MODE (STRING)) { int len, k; ASSERT (io_read (FD (f), &(len), sizeof (len)) != -1); reset_transput_buffer (UNFORMATTED_BUFFER); for (k = 0; k < len; k++) { A68_CHAR z; ASSERT (io_read (FD (f), &(VALUE (&z)), sizeof (VALUE (&z))) != -1); add_char_transput_buffer (p, UNFORMATTED_BUFFER, (char) VALUE (&z)); } *(A68_REF *) item = c_to_a_string (p, get_transput_buffer (UNFORMATTED_BUFFER), DEFAULT_WIDTH); } else if (IS (mode, UNION_SYMBOL)) { A68_UNION *z = (A68_UNION *) item; if (!(STATUS (z) | INIT_MASK) || VALUE (z) == NULL) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_EMPTY_VALUE, mode); exit_genie (p, A68_RUNTIME_ERROR); } genie_read_bin_standard (p, (MOID_T *) (VALUE (z)), &item[A68_UNION_SIZE], ref_file); } else if (IS (mode, STRUCT_SYMBOL)) { PACK_T *q = PACK (mode); for (; q != NO_PACK; FORWARD (q)) { genie_read_bin_standard (p, MOID (q), &item[OFFSET (q)], ref_file); } } else if (IS (mode, ROW_SYMBOL) || IS (mode, FLEX_SYMBOL)) { MOID_T *deflexed = DEFLEX (mode); A68_ARRAY *arr; A68_TUPLE *tup; CHECK_INIT (p, INITIALISED ((A68_REF *) item), MODE (ROWS)); GET_DESCRIPTOR (arr, tup, (A68_REF *) item); if (get_row_size (tup, DIM (arr)) > 0) { BYTE_T *base_addr = DEREF (BYTE_T, &ARRAY (arr)); BOOL_T done = A68_FALSE; initialise_internal_index (tup, DIM (arr)); while (!done) { ADDR_T a68g_index = calculate_internal_index (tup, DIM (arr)); ADDR_T elem_addr = ROW_ELEMENT (arr, a68g_index); genie_read_bin_standard (p, SUB (deflexed), &base_addr[elem_addr], ref_file); done = increment_internal_index (tup, DIM (arr)); } } } if (errno != 0) { transput_error (p, ref_file, mode); } } /*! \brief PROC ([] SIMPLIN) VOID read bin \param p position in tree **/ void genie_read_bin (NODE_T * p) { A68_REF row; POP_REF (p, &row); genie_stand_back (p); PUSH_REF (p, row); genie_read_bin_file (p); } /*! \brief PROC (REF FILE, [] SIMPLIN) VOID get bin \param p position in tree **/ void genie_read_bin_file (NODE_T * p) { A68_REF ref_file; A68_FILE *file; A68_REF row; A68_ARRAY *arr; A68_TUPLE *tup; BYTE_T *base_address; int elems, k, elem_index; POP_REF (p, &row); CHECK_REF (p, row, MODE (ROW_SIMPLIN)); GET_DESCRIPTOR (arr, tup, &row); elems = ROW_SIZE (tup); POP_REF (p, &ref_file); ref_file = *(A68_REF *) STACK_TOP; CHECK_REF (p, ref_file, MODE (REF_FILE)); file = FILE_DEREF (&ref_file); CHECK_INIT (p, INITIALISED (file), MODE (FILE)); if (!OPENED (file)) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FILE_NOT_OPEN); exit_genie (p, A68_RUNTIME_ERROR); } if (DRAW_MOOD (file)) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "draw"); exit_genie (p, A68_RUNTIME_ERROR); } if (WRITE_MOOD (file)) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "write"); exit_genie (p, A68_RUNTIME_ERROR); } if (!GET (&CHANNEL (file))) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_CHANNEL_DOES_NOT_ALLOW, "getting"); exit_genie (p, A68_RUNTIME_ERROR); } if (!BIN (&CHANNEL (file))) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_CHANNEL_DOES_NOT_ALLOW, "binary getting"); exit_genie (p, A68_RUNTIME_ERROR); } if (!READ_MOOD (file) && !WRITE_MOOD (file)) { if ((FD (file) = open_physical_file (p, ref_file, A68_READ_ACCESS | O_BINARY, 0)) == A68_NO_FILENO) { open_error (p, ref_file, "binary getting"); } DRAW_MOOD (file) = A68_FALSE; READ_MOOD (file) = A68_TRUE; WRITE_MOOD (file) = A68_FALSE; CHAR_MOOD (file) = A68_FALSE; } if (CHAR_MOOD (file)) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "text"); exit_genie (p, A68_RUNTIME_ERROR); } /* Read */ if (elems <= 0) { return; } elem_index = 0; base_address = DEREF (BYTE_T, &ARRAY (arr)); for (k = 0; k < elems; k++) { A68_UNION *z = (A68_UNION *) & base_address[elem_index]; MOID_T *mode = (MOID_T *) (VALUE (z)); BYTE_T *item = (BYTE_T *) & base_address[elem_index + A68_UNION_SIZE]; if (mode == MODE (PROC_REF_FILE_VOID)) { genie_call_proc_ref_file_void (p, ref_file, *(A68_PROCEDURE *) item); } else if (mode == MODE (FORMAT)) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_UNDEFINED_TRANSPUT, MODE (FORMAT)); exit_genie (p, A68_RUNTIME_ERROR); } else if (mode == MODE (REF_SOUND)) { read_sound (p, ref_file, (A68_SOUND *) ADDRESS ((A68_REF *) item)); } else { if (END_OF_FILE (file)) { end_of_file_error (p, ref_file); } CHECK_REF (p, *(A68_REF *) item, mode); genie_read_bin_standard (p, SUB (mode), ADDRESS ((A68_REF *) item), ref_file); } elem_index += MOID_SIZE (MODE (SIMPLIN)); } } /*! \brief write object binary to file \param p position in tree \param mode mode to write \param item pointer to value \param ref_file fat pointer to A68 file **/ static void genie_write_bin_standard (NODE_T * p, MOID_T * mode, BYTE_T * item, A68_REF ref_file) { A68_FILE *f = FILE_DEREF (&ref_file); RESET_ERRNO; if (mode == MODE (INT)) { ASSERT (io_write (FD (f), &(VALUE ((A68_INT *) item)), sizeof (VALUE ((A68_INT *) item))) != -1); } else if (mode == MODE (LONG_INT) || mode == MODE (LONGLONG_INT)) { ASSERT (io_write (FD (f), (MP_T *) item, (size_t) get_mp_size (mode)) != -1); } else if (mode == MODE (REAL)) { ASSERT (io_write (FD (f), &(VALUE ((A68_REAL *) item)), sizeof (VALUE ((A68_REAL *) item))) != -1); } else if (mode == MODE (LONG_REAL) || mode == MODE (LONGLONG_REAL)) { ASSERT (io_write (FD (f), (MP_T *) item, (size_t) get_mp_size (mode)) != -1); } else if (mode == MODE (BOOL)) { ASSERT (io_write (FD (f), &(VALUE ((A68_BOOL *) item)), sizeof (VALUE ((A68_BOOL *) item))) != -1); } else if (mode == MODE (CHAR)) { ASSERT (io_write (FD (f), &(VALUE ((A68_CHAR *) item)), sizeof (VALUE ((A68_CHAR *) item))) != -1); } else if (mode == MODE (BITS)) { ASSERT (io_write (FD (f), &(VALUE ((A68_BITS *) item)), sizeof (VALUE ((A68_BITS *) item))) != -1); } else if (mode == MODE (LONG_BITS) || mode == MODE (LONGLONG_BITS)) { ASSERT (io_write (FD (f), (MP_T *) item, (size_t) get_mp_size (mode)) != -1); } else if (mode == MODE (ROW_CHAR) || mode == MODE (STRING)) { int len; reset_transput_buffer (UNFORMATTED_BUFFER); add_a_string_transput_buffer (p, UNFORMATTED_BUFFER, item); len = get_transput_buffer_index (UNFORMATTED_BUFFER); ASSERT (io_write (FD (f), &(len), sizeof (len)) != -1); WRITE (FD (f), get_transput_buffer (UNFORMATTED_BUFFER)); } else if (IS (mode, UNION_SYMBOL)) { A68_UNION *z = (A68_UNION *) item; genie_write_bin_standard (p, (MOID_T *) (VALUE (z)), &item[A68_UNION_SIZE], ref_file); } else if (IS (mode, STRUCT_SYMBOL)) { PACK_T *q = PACK (mode); for (; q != NO_PACK; FORWARD (q)) { BYTE_T *elem = &item[OFFSET (q)]; genie_check_initialisation (p, elem, MOID (q)); genie_write_bin_standard (p, MOID (q), elem, ref_file); } } else if (IS (mode, ROW_SYMBOL) || IS (mode, FLEX_SYMBOL)) { MOID_T *deflexed = DEFLEX (mode); A68_ARRAY *arr; A68_TUPLE *tup; CHECK_INIT (p, INITIALISED ((A68_REF *) item), MODE (ROWS)); GET_DESCRIPTOR (arr, tup, (A68_REF *) item); if (get_row_size (tup, DIM (arr)) > 0) { BYTE_T *base_addr = DEREF (BYTE_T, &ARRAY (arr)); BOOL_T done = A68_FALSE; initialise_internal_index (tup, DIM (arr)); while (!done) { ADDR_T a68g_index = calculate_internal_index (tup, DIM (arr)); ADDR_T elem_addr = ROW_ELEMENT (arr, a68g_index); BYTE_T *elem = &base_addr[elem_addr]; genie_check_initialisation (p, elem, SUB (deflexed)); genie_write_bin_standard (p, SUB (deflexed), elem, ref_file); done = increment_internal_index (tup, DIM (arr)); } } } if (errno != 0) { transput_error (p, ref_file, mode); } } /*! \brief PROC ([] SIMPLOUT) VOID write bin, print bin \param p position in tree **/ void genie_write_bin (NODE_T * p) { A68_REF row; POP_REF (p, &row); genie_stand_back (p); PUSH_REF (p, row); genie_write_bin_file (p); } /*! \brief PROC (REF FILE, [] SIMPLOUT) VOID put bin \param p position in tree **/ void genie_write_bin_file (NODE_T * p) { A68_REF ref_file, row; A68_FILE *file; A68_ARRAY *arr; A68_TUPLE *tup; BYTE_T *base_address; int elems, k, elem_index; POP_REF (p, &row); CHECK_REF (p, row, MODE (ROW_SIMPLOUT)); GET_DESCRIPTOR (arr, tup, &row); elems = ROW_SIZE (tup); POP_REF (p, &ref_file); ref_file = *(A68_REF *) STACK_TOP; CHECK_REF (p, ref_file, MODE (REF_FILE)); file = FILE_DEREF (&ref_file); CHECK_INIT (p, INITIALISED (file), MODE (FILE)); if (!OPENED (file)) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FILE_NOT_OPEN); exit_genie (p, A68_RUNTIME_ERROR); } if (DRAW_MOOD (file)) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "draw"); exit_genie (p, A68_RUNTIME_ERROR); } if (READ_MOOD (file)) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "read"); exit_genie (p, A68_RUNTIME_ERROR); } if (!PUT (&CHANNEL (file))) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_CHANNEL_DOES_NOT_ALLOW, "putting"); exit_genie (p, A68_RUNTIME_ERROR); } if (!BIN (&CHANNEL (file))) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_CHANNEL_DOES_NOT_ALLOW, "binary putting"); exit_genie (p, A68_RUNTIME_ERROR); } if (!READ_MOOD (file) && !WRITE_MOOD (file)) { if ((FD (file) = open_physical_file (p, ref_file, A68_WRITE_ACCESS | O_BINARY, A68_PROTECTION)) == A68_NO_FILENO) { open_error (p, ref_file, "binary putting"); } DRAW_MOOD (file) = A68_FALSE; READ_MOOD (file) = A68_FALSE; WRITE_MOOD (file) = A68_TRUE; CHAR_MOOD (file) = A68_FALSE; } if (CHAR_MOOD (file)) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "text"); exit_genie (p, A68_RUNTIME_ERROR); } if (elems <= 0) { return; } base_address = DEREF (BYTE_T, &ARRAY (arr)); elem_index = 0; for (k = 0; k < elems; k++) { A68_UNION *z = (A68_UNION *) & base_address[elem_index]; MOID_T *mode = (MOID_T *) (VALUE (z)); BYTE_T *item = (BYTE_T *) & base_address[elem_index + A68_UNION_SIZE]; if (mode == MODE (PROC_REF_FILE_VOID)) { genie_call_proc_ref_file_void (p, ref_file, *(A68_PROCEDURE *) item); } else if (mode == MODE (FORMAT)) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_UNDEFINED_TRANSPUT, MODE (FORMAT)); exit_genie (p, A68_RUNTIME_ERROR); } else if (mode == MODE (SOUND)) { write_sound (p, ref_file, (A68_SOUND *) item); } else { genie_write_bin_standard (p, mode, item, ref_file); } elem_index += MOID_SIZE (MODE (SIMPLOUT)); } } /* Next are formatting routines "whole", "fixed" and "float" for mode INT, LONG INT and LONG LONG INT, and REAL, LONG REAL and LONG LONG REAL. They are direct implementations of the routines described in the Revised Report, although those were only meant as a specification. The rest of Algol68G should only reference "genie_whole", "genie_fixed" or "genie_float" since internal routines like "sub_fixed" may leave the stack corrupted when called directly. */ /*! \brief generate a string of error chars \param s string to store error chars \param n number of error chars \return same **/ char *error_chars (char *s, int n) { int k = (n != 0 ? ABS (n) : 1); s[k] = NULL_CHAR; while (--k >= 0) { s[k] = ERROR_CHAR; } return (s); } /*! \brief convert temporary C string to A68 string \param p position in tree \param temp_string temporary C string \return same **/ A68_REF tmp_to_a68_string (NODE_T * p, char *temp_string) { A68_REF z; /* no compaction allowed since temp_string might be up for garbage collecting .. */ z = c_to_a_string (p, temp_string, DEFAULT_WIDTH); return (z); } /*! \brief add c to str, assuming that "str" is large enough \param c char to add before string \param str string to add in front of \return string **/ static char *plusto (char c, char *str) { MOVE (&str[1], &str[0], (unsigned) (strlen (str) + 1)); str[0] = c; return (str); } /*! \brief add c to str, assuming that "str" is large enough \param str string to add to \param c char to add \param strwid width of 'str' \return string **/ char *string_plusab_char (char *str, char c, int strwid) { char z[2]; z[0] = c; z[1] = NULL_CHAR; bufcat (str, z, strwid); return (str); } /*! \brief add leading spaces to str until length is width \param str string to add in front of \param width required width of 'str' \return string **/ static char *leading_spaces (char *str, int width) { int j = width - (int) strlen (str); while (--j >= 0) { (void) plusto (BLANK_CHAR, str); } return (str); } /*! \brief convert int to char using a table \param k int to convert \return character **/ static char digchar (int k) { char *s = "0123456789abcdef"; if (k >= 0 && k < (int) strlen (s)) { return (s[k]); } else { return (ERROR_CHAR); } } /*! \brief standard string for LONG INT \param p position in tree \param m mp number \param digits digits \param width width \return same **/ char *long_sub_whole (NODE_T * p, MP_T * m, int digits, int width) { ADDR_T pop_sp; char *s; MP_T *n; int len = 0; s = stack_string (p, 8 + width); s[0] = NULL_CHAR; pop_sp = stack_pointer; STACK_MP (n, p, digits); MOVE_MP (n, m, digits); do { if (len < width) { /* Sic transit gloria mundi */ int n_mod_10 = (int) MP_DIGIT (n, (int) (1 + MP_EXPONENT (n))) % 10; (void) plusto (digchar (n_mod_10), s); } len++; (void) over_mp_digit (p, n, n, (MP_T) 10, digits); } while (MP_DIGIT (n, 1) > 0); if (len > width) { (void) error_chars (s, width); } stack_pointer = pop_sp; return (s); } /*! \brief standard string for INT \param p position in tree \param n value \param width width \return same **/ char *sub_whole (NODE_T * p, int n, int width) { char *s = stack_string (p, 8 + width); int len = 0; s[0] = NULL_CHAR; do { if (len < width) { (void) plusto (digchar (n % 10), s); } len++; n /= 10; } while (n != 0); if (len > width) { (void) error_chars (s, width); } return (s); } /*! \brief formatted string for NUMBER \param p position in tree \return string **/ char *whole (NODE_T * p) { int pop_sp, arg_sp; A68_INT width; MOID_T *mode; POP_OBJECT (p, &width, A68_INT); arg_sp = stack_pointer; DECREMENT_STACK_POINTER (p, MOID_SIZE (MODE (NUMBER))); pop_sp = stack_pointer; mode = (MOID_T *) (VALUE ((A68_UNION *) STACK_TOP)); if (mode == MODE (INT)) { int x = VALUE ((A68_INT *) (STACK_OFFSET (A68_UNION_SIZE))); int length = ABS (VALUE (&width)) - (x < 0 || VALUE (&width) > 0 ? 1 : 0); int n = ABS (x); int size = (x < 0 ? 1 : (VALUE (&width) > 0 ? 1 : 0)); char *s; if (VALUE (&width) == 0) { int m = n; length = 0; while ((m /= 10, length++, m != 0)) { ; } } size += length; size = 8 + (size > VALUE (&width) ? size : VALUE (&width)); s = stack_string (p, size); bufcpy (s, sub_whole (p, n, length), size); if (length == 0 || a68g_strchr (s, ERROR_CHAR) != NO_TEXT) { (void) error_chars (s, VALUE (&width)); } else { if (x < 0) { (void) plusto ('-', s); } else if (VALUE (&width) > 0) { (void) plusto ('+', s); } if (VALUE (&width) != 0) { (void) leading_spaces (s, ABS (VALUE (&width))); } } return (s); } else if (mode == MODE (LONG_INT) || mode == MODE (LONGLONG_INT)) { int digits = get_mp_digits (mode); int length, size; char *s; MP_T *n = (MP_T *) (STACK_OFFSET (A68_UNION_SIZE)); BOOL_T ltz; stack_pointer = arg_sp; /* We keep the mp where it's at */ if (MP_EXPONENT (n) >= (MP_T) digits) { int max_length = (mode == MODE (LONG_INT) ? LONG_INT_WIDTH : LONGLONG_INT_WIDTH); length = (VALUE (&width) == 0 ? max_length : VALUE (&width)); s = stack_string (p, 1 + length); (void) error_chars (s, length); return (s); } ltz = (BOOL_T) (MP_DIGIT (n, 1) < 0); length = ABS (VALUE (&width)) - (ltz || VALUE (&width) > 0 ? 1 : 0); size = (ltz ? 1 : (VALUE (&width) > 0 ? 1 : 0)); MP_DIGIT (n, 1) = ABS (MP_DIGIT (n, 1)); if (VALUE (&width) == 0) { MP_T *m; STACK_MP (m, p, digits); MOVE_MP (m, n, digits); length = 0; while ((over_mp_digit (p, m, m, (MP_T) 10, digits), length++, MP_DIGIT (m, 1) != 0)) { ; } } size += length; size = 8 + (size > VALUE (&width) ? size : VALUE (&width)); s = stack_string (p, size); bufcpy (s, long_sub_whole (p, n, digits, length), size); if (length == 0 || a68g_strchr (s, ERROR_CHAR) != NO_TEXT) { (void) error_chars (s, VALUE (&width)); } else { if (ltz) { (void) plusto ('-', s); } else if (VALUE (&width) > 0) { (void) plusto ('+', s); } if (VALUE (&width) != 0) { (void) leading_spaces (s, ABS (VALUE (&width))); } } return (s); } else if (mode == MODE (REAL) || mode == MODE (LONG_REAL) || mode == MODE (LONGLONG_REAL)) { INCREMENT_STACK_POINTER (p, MOID_SIZE (MODE (NUMBER))); PUSH_PRIMITIVE (p, VALUE (&width), A68_INT); PUSH_PRIMITIVE (p, 0, A68_INT); return (fixed (p)); } return (NO_TEXT); } /*! \brief fetch next digit from LONG \param p position in tree \param y mp number \param digits digits \return next digit **/ static char long_choose_dig (NODE_T * p, MP_T * y, int digits) { /* Assuming positive "y" */ int pop_sp = stack_pointer, c; MP_T *t; STACK_MP (t, p, digits); (void) mul_mp_digit (p, y, y, (MP_T) 10, digits); c = MP_EXPONENT (y) == 0 ? (int) MP_DIGIT (y, 1) : 0; if (c > 9) { c = 9; } (void) set_mp_short (t, (MP_T) c, 0, digits); (void) sub_mp (p, y, y, t, digits); /* Reset the stack to prevent overflow, there may be many digits */ stack_pointer = pop_sp; return (digchar (c)); } /*! \brief standard string for LONG \param p position in tree \param x mp digit \param digits digits \param width width \param after after \return same **/ char *long_sub_fixed (NODE_T * p, MP_T * x, int digits, int width, int after) { int strwid = 8 + width; char *str = stack_string (p, strwid); int before = 0, j, len, pop_sp = stack_pointer; BOOL_T overflow; MP_T *y; MP_T *s; MP_T *t; STACK_MP (y, p, digits); STACK_MP (s, p, digits); STACK_MP (t, p, digits); (void) set_mp_short (t, (MP_T) (MP_RADIX / 10), -1, digits); (void) pow_mp_int (p, t, t, after, digits); (void) div_mp_digit (p, t, t, (MP_T) 2, digits); (void) add_mp (p, y, x, t, digits); (void) set_mp_short (s, (MP_T) 1, 0, digits); while ((sub_mp (p, t, y, s, digits), MP_DIGIT (t, 1) >= 0)) { before++; (void) mul_mp_digit (p, s, s, (MP_T) 10, digits); } (void) div_mp (p, y, y, s, digits); str[0] = NULL_CHAR; len = 0; overflow = A68_FALSE; for (j = 0; j < before && !overflow; j++) { if (!(overflow = (BOOL_T) (len >= width))) { (void) string_plusab_char (str, long_choose_dig (p, y, digits), strwid); len++; } } if (after > 0 && !(overflow = (BOOL_T) (len >= width))) { (void) string_plusab_char (str, POINT_CHAR, strwid); } for (j = 0; j < after && !overflow; j++) { if (!(overflow = (BOOL_T) (len >= width))) { (void) string_plusab_char (str, long_choose_dig (p, y, digits), strwid); len++; } } if (overflow || (int) strlen (str) > width) { (void) error_chars (str, width); } stack_pointer = pop_sp; return (str); } /*! \brief fetch next digit from REAL \param y value \return next digit **/ static char choose_dig (double *y) { /* Assuming positive "y" */ int c = (int) (*y *= 10); if (c > 9) { c = 9; } *y -= c; return (digchar (c)); } /*! \brief standard string for REAL \param p position in tree \param x value \param width width \param after after \return string **/ char *sub_fixed (NODE_T * p, double x, int width, int after) { int strwid = 8 + width; char *str = stack_string (p, strwid); int before = 0, j, len, expo; BOOL_T overflow; double y, z; /* Round and scale */ z = y = x + 0.5 * ten_up (-after); expo = 0; while (z >= 1) { expo++; z /= 10; } before += expo; /* Trick to avoid overflow */ if (expo > 30) { expo -= 30; y /= ten_up (30); } /* Scale number */ y /= ten_up (expo); len = 0; /* Put digits, prevent garbage from overstretching precision */ overflow = A68_FALSE; for (j = 0; j < before && !overflow; j++) { if (!(overflow = (BOOL_T) (len >= width))) { char ch = (char) (len < REAL_WIDTH ? choose_dig (&y) : '0'); (void) string_plusab_char (str, ch, strwid); len++; } } if (after > 0 && !(overflow = (BOOL_T) (len >= width))) { (void) string_plusab_char (str, POINT_CHAR, strwid); } for (j = 0; j < after && !overflow; j++) { if (!(overflow = (BOOL_T) (len >= width))) { char ch = (char) (len < REAL_WIDTH ? choose_dig (&y) : '0'); (void) string_plusab_char (str, ch, strwid); len++; } } if (overflow || (int) strlen (str) > width) { (void) error_chars (str, width); } return (str); } /*! \brief formatted string for NUMBER \param p position in tree \return string **/ char *fixed (NODE_T * p) { A68_INT width, after; MOID_T *mode; int pop_sp, arg_sp; POP_OBJECT (p, &after, A68_INT); POP_OBJECT (p, &width, A68_INT); arg_sp = stack_pointer; DECREMENT_STACK_POINTER (p, MOID_SIZE (MODE (NUMBER))); mode = (MOID_T *) (VALUE ((A68_UNION *) STACK_TOP)); pop_sp = stack_pointer; if (mode == MODE (REAL)) { double x = VALUE ((A68_REAL *) (STACK_OFFSET (A68_UNION_SIZE))); int length = ABS (VALUE (&width)) - (x < 0 || VALUE (&width) > 0 ? 1 : 0); char *s; CHECK_REAL_REPRESENTATION (p, x); stack_pointer = arg_sp; if (VALUE (&after) >= 0 && (length > VALUE (&after) || VALUE (&width) == 0)) { double y = ABS (x), z0, z1; if (VALUE (&width) == 0) { length = (VALUE (&after) == 0 ? 1 : 0); z0 = ten_up (-VALUE (&after)); z1 = ten_up (length); while (y + 0.5 * z0 > z1) { length++; z1 *= 10.0; } length += (VALUE (&after) == 0 ? 0 : VALUE (&after) + 1); } s = stack_string (p, 8 + length); s = sub_fixed (p, y, length, VALUE (&after)); if (a68g_strchr (s, ERROR_CHAR) == NO_TEXT) { if (length > (int) strlen (s) && (s[0] != NULL_CHAR ? s[0] == POINT_CHAR : A68_TRUE) && y < 1.0) { (void) plusto ('0', s); } if (x < 0) { (void) plusto ('-', s); } else if (VALUE (&width) > 0) { (void) plusto ('+', s); } if (VALUE (&width) != 0) { (void) leading_spaces (s, ABS (VALUE (&width))); } return (s); } else if (VALUE (&after) > 0) { stack_pointer = arg_sp; PUSH_PRIMITIVE (p, VALUE (&width), A68_INT); PUSH_PRIMITIVE (p, VALUE (&after) - 1, A68_INT); return (fixed (p)); } else { return (error_chars (s, VALUE (&width))); } } else { s = stack_string (p, 8 + ABS (VALUE (&width))); return (error_chars (s, VALUE (&width))); } } else if (mode == MODE (LONG_REAL) || mode == MODE (LONGLONG_REAL)) { int digits = get_mp_digits (mode); int length; BOOL_T ltz; char *s; MP_T *x = (MP_T *) (STACK_OFFSET (A68_UNION_SIZE)); stack_pointer = arg_sp; ltz = (BOOL_T) (MP_DIGIT (x, 1) < 0); MP_DIGIT (x, 1) = ABS (MP_DIGIT (x, 1)); length = ABS (VALUE (&width)) - (ltz || VALUE (&width) > 0 ? 1 : 0); if (VALUE (&after) >= 0 && (length > VALUE (&after) || VALUE (&width) == 0)) { MP_T *z0; MP_T *z1; MP_T *t; STACK_MP (z0, p, digits); STACK_MP (z1, p, digits); STACK_MP (t, p, digits); if (VALUE (&width) == 0) { length = (VALUE (&after) == 0 ? 1 : 0); (void) set_mp_short (z0, (MP_T) (MP_RADIX / 10), -1, digits); (void) set_mp_short (z1, (MP_T) 10, 0, digits); (void) pow_mp_int (p, z0, z0, VALUE (&after), digits); (void) pow_mp_int (p, z1, z1, length, digits); while ((div_mp_digit (p, t, z0, (MP_T) 2, digits), add_mp (p, t, x, t, digits), sub_mp (p, t, t, z1, digits), MP_DIGIT (t, 1) > 0)) { length++; (void) mul_mp_digit (p, z1, z1, (MP_T) 10, digits); } length += (VALUE (&after) == 0 ? 0 : VALUE (&after) + 1); } s = stack_string (p, 8 + length); s = long_sub_fixed (p, x, digits, length, VALUE (&after)); if (a68g_strchr (s, ERROR_CHAR) == NO_TEXT) { if (length > (int) strlen (s) && (s[0] != NULL_CHAR ? s[0] == POINT_CHAR : A68_TRUE) && (MP_EXPONENT (x) < 0 || MP_DIGIT (x, 1) == 0)) { (void) plusto ('0', s); } if (ltz) { (void) plusto ('-', s); } else if (VALUE (&width) > 0) { (void) plusto ('+', s); } if (VALUE (&width) != 0) { (void) leading_spaces (s, ABS (VALUE (&width))); } return (s); } else if (VALUE (&after) > 0) { stack_pointer = arg_sp; MP_DIGIT (x, 1) = ltz ? -ABS (MP_DIGIT (x, 1)) : ABS (MP_DIGIT (x, 1)); PUSH_PRIMITIVE (p, VALUE (&width), A68_INT); PUSH_PRIMITIVE (p, VALUE (&after) - 1, A68_INT); return (fixed (p)); } else { return (error_chars (s, VALUE (&width))); } } else { s = stack_string (p, 8 + ABS (VALUE (&width))); return (error_chars (s, VALUE (&width))); } } else if (mode == MODE (INT)) { int x = VALUE ((A68_INT *) (STACK_OFFSET (A68_UNION_SIZE))); PUSH_UNION (p, MODE (REAL)); PUSH_PRIMITIVE (p, (double) x, A68_REAL); INCREMENT_STACK_POINTER (p, MOID_SIZE (MODE (NUMBER)) - (A68_UNION_SIZE + ALIGNED_SIZE_OF (A68_REAL))); PUSH_PRIMITIVE (p, VALUE (&width), A68_INT); PUSH_PRIMITIVE (p, VALUE (&after), A68_INT); return (fixed (p)); } else if (mode == MODE (LONG_INT) || mode == MODE (LONGLONG_INT)) { stack_pointer = pop_sp; if (mode == MODE (LONG_INT)) { VALUE ((A68_UNION *) STACK_TOP) = (void *) MODE (LONG_REAL); } else { VALUE ((A68_UNION *) STACK_TOP) = (void *) MODE (LONGLONG_REAL); } INCREMENT_STACK_POINTER (p, MOID_SIZE (MODE (NUMBER))); PUSH_PRIMITIVE (p, VALUE (&width), A68_INT); PUSH_PRIMITIVE (p, VALUE (&after), A68_INT); return (fixed (p)); } return (NO_TEXT); } /*! \brief scale LONG for formatting \param p position in tree \param y mp number \param digits digits \param before before \param after after \param q int multiplier **/ void long_standardise (NODE_T * p, MP_T * y, int digits, int before, int after, int *q) { int j, pop_sp = stack_pointer; MP_T *f; MP_T *g; MP_T *h; MP_T *t; STACK_MP (f, p, digits); STACK_MP (g, p, digits); STACK_MP (h, p, digits); STACK_MP (t, p, digits); (void) set_mp_short (g, (MP_T) 1, 0, digits); for (j = 0; j < before; j++) { (void) mul_mp_digit (p, g, g, (MP_T) 10, digits); } (void) div_mp_digit (p, h, g, (MP_T) 10, digits); /* Speed huge exponents */ if ((MP_EXPONENT (y) - MP_EXPONENT (g)) > 1) { (*q) += LOG_MP_BASE * ((int) MP_EXPONENT (y) - (int) MP_EXPONENT (g) - 1); MP_EXPONENT (y) = MP_EXPONENT (g) + 1; } while ((sub_mp (p, t, y, g, digits), MP_DIGIT (t, 1) >= 0)) { (void) div_mp_digit (p, y, y, (MP_T) 10, digits); (*q)++; } if (MP_DIGIT (y, 1) != 0) { /* Speed huge exponents */ if ((MP_EXPONENT (y) - MP_EXPONENT (h)) < -1) { (*q) -= LOG_MP_BASE * ((int) MP_EXPONENT (h) - (int) MP_EXPONENT (y) - 1); MP_EXPONENT (y) = MP_EXPONENT (h) - 1; } while ((sub_mp (p, t, y, h, digits), MP_DIGIT (t, 1) < 0)) { (void) mul_mp_digit (p, y, y, (MP_T) 10, digits); (*q)--; } } (void) set_mp_short (f, (MP_T) 1, 0, digits); for (j = 0; j < after; j++) { (void) div_mp_digit (p, f, f, (MP_T) 10, digits); } (void) div_mp_digit (p, t, f, (MP_T) 2, digits); (void) add_mp (p, t, y, t, digits); (void) sub_mp (p, t, t, g, digits); if (MP_DIGIT (t, 1) >= 0) { MOVE_MP (y, h, digits); (*q)++; } stack_pointer = pop_sp; } /*! \brief scale REAL for formatting \param y value \param before before \param after after \param p int multiplier **/ void standardise (double *y, int before, int after, int *p) { int j; double f, g = 1.0, h; for (j = 0; j < before; j++) { g *= 10.0; } h = g / 10.0; while (*y >= g) { *y *= 0.1; (*p)++; } if (*y != 0.0) { while (*y < h) { *y *= 10.0; (*p)--; } } f = 1.0; for (j = 0; j < after; j++) { f *= 0.1; } if (*y + 0.5 * f >= g) { *y = h; (*p)++; } } /*! \brief formatted string for NUMBER \param p position in tree \return string **/ char *real (NODE_T * p) { int pop_sp, arg_sp; A68_INT width, after, expo, frmt; MOID_T *mode; /* POP arguments */ POP_OBJECT (p, &frmt, A68_INT); POP_OBJECT (p, &expo, A68_INT); POP_OBJECT (p, &after, A68_INT); POP_OBJECT (p, &width, A68_INT); arg_sp = stack_pointer; DECREMENT_STACK_POINTER (p, MOID_SIZE (MODE (NUMBER))); mode = (MOID_T *) (VALUE ((A68_UNION *) STACK_TOP)); pop_sp = stack_pointer; if (mode == MODE (REAL)) { double x = VALUE ((A68_REAL *) (STACK_OFFSET (A68_UNION_SIZE))); int before = ABS (VALUE (&width)) - ABS (VALUE (&expo)) - (VALUE (&after) != 0 ? VALUE (&after) + 1 : 0) - 2; CHECK_REAL_REPRESENTATION (p, x); stack_pointer = arg_sp; #if defined HAVE_IEEE_754 if (NOT_A_REAL (x)) { char *s = stack_string (p, 8 + ABS (VALUE (&width))); return (error_chars (s, VALUE (&width))); } #endif /* */ if (SIGN (before) + SIGN (VALUE (&after)) > 0) { int strwid; char *s, *t1, *t2; double y = ABS (x); int q = 0; standardise (&y, before, VALUE (&after), &q); if (VALUE (&frmt) > 0) { while (q % VALUE (&frmt) != 0) { y *= 10; q--; if (VALUE (&after) > 0) { VALUE (&after)--; } } } else { double upb = ten_up (-VALUE (&frmt)), lwb = ten_up (-VALUE (&frmt) - 1); while (y < lwb) { y *= 10; q--; if (VALUE (&after) > 0) { VALUE (&after)--; } } while (y > upb) { y /= 10; q++; if (VALUE (&after) > 0) { VALUE (&after)++; } } } PUSH_UNION (p, MODE (REAL)); PUSH_PRIMITIVE (p, SIGN (x) * y, A68_REAL); INCREMENT_STACK_POINTER (p, MOID_SIZE (MODE (NUMBER)) - (A68_UNION_SIZE + ALIGNED_SIZE_OF (A68_REAL))); PUSH_PRIMITIVE (p, SIGN (VALUE (&width)) * (ABS (VALUE (&width)) - ABS (VALUE (&expo)) - 1), A68_INT); PUSH_PRIMITIVE (p, VALUE (&after), A68_INT); t1 = fixed (p); PUSH_UNION (p, MODE (INT)); PUSH_PRIMITIVE (p, q, A68_INT); INCREMENT_STACK_POINTER (p, MOID_SIZE (MODE (NUMBER)) - (A68_UNION_SIZE + ALIGNED_SIZE_OF (A68_INT))); PUSH_PRIMITIVE (p, VALUE (&expo), A68_INT); t2 = whole (p); strwid = 8 + (int) strlen (t1) + 1 + (int) strlen (t2); s = stack_string (p, strwid); bufcpy (s, t1, strwid); (void) string_plusab_char (s, EXPONENT_CHAR, strwid); bufcat (s, t2, strwid); if (VALUE (&expo) == 0 || a68g_strchr (s, ERROR_CHAR) != NO_TEXT) { stack_pointer = arg_sp; PUSH_PRIMITIVE (p, VALUE (&width), A68_INT); PUSH_PRIMITIVE (p, VALUE (&after) != 0 ? VALUE (&after) - 1 : 0, A68_INT); PUSH_PRIMITIVE (p, VALUE (&expo) > 0 ? VALUE (&expo) + 1 : VALUE (&expo) - 1, A68_INT); PUSH_PRIMITIVE (p, VALUE (&frmt), A68_INT); return (real (p)); } else { return (s); } } else { char *s = stack_string (p, 8 + ABS (VALUE (&width))); return (error_chars (s, VALUE (&width))); } } else if (mode == MODE (LONG_REAL) || mode == MODE (LONGLONG_REAL)) { int digits = get_mp_digits (mode); int before; MP_T *x = (MP_T *) (STACK_OFFSET (A68_UNION_SIZE)); BOOL_T ltz = (BOOL_T) (MP_DIGIT (x, 1) < 0); stack_pointer = arg_sp; MP_DIGIT (x, 1) = ABS (MP_DIGIT (x, 1)); before = ABS (VALUE (&width)) - ABS (VALUE (&expo)) - (VALUE (&after) != 0 ? VALUE (&after) + 1 : 0) - 2; if (SIGN (before) + SIGN (VALUE (&after)) > 0) { int strwid; char *s, *t1, *t2; MP_T *z; int q = 0; STACK_MP (z, p, digits); MOVE_MP (z, x, digits); long_standardise (p, z, digits, before, VALUE (&after), &q); if (VALUE (&frmt) > 0) { while (q % VALUE (&frmt) != 0) { (void) mul_mp_digit (p, z, z, (MP_T) 10, digits); q--; if (VALUE (&after) > 0) { VALUE (&after)--; } } } else { MP_T *dif, *lim; ADDR_T sp1 = stack_pointer; STACK_MP (dif, p, digits); STACK_MP (lim, p, digits); (void) mp_ten_up (p, lim, -VALUE (&frmt) - 1, digits); (void) sub_mp (p, dif, z, lim, digits); while (MP_DIGIT (dif, 1) < 0) { (void) mul_mp_digit (p, z, z, (MP_T) 10, digits); q--; if (VALUE (&after) > 0) { VALUE (&after)--; } (void) sub_mp (p, dif, z, lim, digits); } (void) mul_mp_digit (p, lim, lim, (MP_T) 10, digits); (void) sub_mp (p, dif, z, lim, digits); while (MP_DIGIT (dif, 1) > 0) { (void) div_mp_digit (p, z, z, (MP_T) 10, digits); q++; if (VALUE (&after) > 0) { VALUE (&after)++; } (void) sub_mp (p, dif, z, lim, digits); } stack_pointer = sp1; } PUSH_UNION (p, mode); MP_DIGIT (z, 1) = (ltz ? -MP_DIGIT (z, 1) : MP_DIGIT (z, 1)); PUSH (p, z, SIZE_MP (digits)); INCREMENT_STACK_POINTER (p, MOID_SIZE (MODE (NUMBER)) - (A68_UNION_SIZE + SIZE_MP (digits))); PUSH_PRIMITIVE (p, SIGN (VALUE (&width)) * (ABS (VALUE (&width)) - ABS (VALUE (&expo)) - 1), A68_INT); PUSH_PRIMITIVE (p, VALUE (&after), A68_INT); t1 = fixed (p); PUSH_UNION (p, MODE (INT)); PUSH_PRIMITIVE (p, q, A68_INT); INCREMENT_STACK_POINTER (p, MOID_SIZE (MODE (NUMBER)) - (A68_UNION_SIZE + ALIGNED_SIZE_OF (A68_INT))); PUSH_PRIMITIVE (p, VALUE (&expo), A68_INT); t2 = whole (p); strwid = 8 + (int) strlen (t1) + 1 + (int) strlen (t2); s = stack_string (p, strwid); bufcpy (s, t1, strwid); (void) string_plusab_char (s, EXPONENT_CHAR, strwid); bufcat (s, t2, strwid); if (VALUE (&expo) == 0 || a68g_strchr (s, ERROR_CHAR) != NO_TEXT) { stack_pointer = arg_sp; PUSH_PRIMITIVE (p, VALUE (&width), A68_INT); PUSH_PRIMITIVE (p, VALUE (&after) != 0 ? VALUE (&after) - 1 : 0, A68_INT); PUSH_PRIMITIVE (p, VALUE (&expo) > 0 ? VALUE (&expo) + 1 : VALUE (&expo) - 1, A68_INT); PUSH_PRIMITIVE (p, VALUE (&frmt), A68_INT); return (real (p)); } else { return (s); } } else { char *s = stack_string (p, 8 + ABS (VALUE (&width))); return (error_chars (s, VALUE (&width))); } } else if (mode == MODE (INT)) { int x = VALUE ((A68_INT *) (STACK_OFFSET (A68_UNION_SIZE))); PUSH_UNION (p, MODE (REAL)); PUSH_PRIMITIVE (p, (double) x, A68_REAL); INCREMENT_STACK_POINTER (p, MOID_SIZE (MODE (NUMBER)) - (A68_UNION_SIZE + ALIGNED_SIZE_OF (A68_REAL))); PUSH_PRIMITIVE (p, VALUE (&width), A68_INT); PUSH_PRIMITIVE (p, VALUE (&after), A68_INT); PUSH_PRIMITIVE (p, VALUE (&expo), A68_INT); PUSH_PRIMITIVE (p, VALUE (&frmt), A68_INT); return (real (p)); } else if (mode == MODE (LONG_INT) || mode == MODE (LONGLONG_INT)) { stack_pointer = pop_sp; if (mode == MODE (LONG_INT)) { VALUE ((A68_UNION *) STACK_TOP) = (void *) MODE (LONG_REAL); } else { VALUE ((A68_UNION *) STACK_TOP) = (void *) MODE (LONGLONG_REAL); } INCREMENT_STACK_POINTER (p, MOID_SIZE (MODE (NUMBER))); PUSH_PRIMITIVE (p, VALUE (&width), A68_INT); PUSH_PRIMITIVE (p, VALUE (&after), A68_INT); PUSH_PRIMITIVE (p, VALUE (&expo), A68_INT); PUSH_PRIMITIVE (p, VALUE (&frmt), A68_INT); return (real (p)); } return (NO_TEXT); } /*! \brief PROC (NUMBER, INT) STRING whole \param p position in tree **/ void genie_whole (NODE_T * p) { int pop_sp = stack_pointer; A68_REF ref; char *str = whole (p); stack_pointer = pop_sp - ALIGNED_SIZE_OF (A68_INT) - MOID_SIZE (MODE (NUMBER)); ref = tmp_to_a68_string (p, str); PUSH_REF (p, ref); } /*! \brief PROC (NUMBER, INT, INT) STRING fixed \param p position in tree **/ void genie_fixed (NODE_T * p) { int pop_sp = stack_pointer; A68_REF ref; char *str = fixed (p); stack_pointer = pop_sp - 2 * ALIGNED_SIZE_OF (A68_INT) - MOID_SIZE (MODE (NUMBER)); ref = tmp_to_a68_string (p, str); PUSH_REF (p, ref); } /*! \brief PROC (NUMBER, INT, INT, INT) STRING eng \param p position in tree **/ void genie_real (NODE_T * p) { int pop_sp = stack_pointer; A68_REF ref; char *str = real (p); stack_pointer = pop_sp - 4 * ALIGNED_SIZE_OF (A68_INT) - MOID_SIZE (MODE (NUMBER)); ref = tmp_to_a68_string (p, str); PUSH_REF (p, ref); } /*! \brief PROC (NUMBER, INT, INT, INT) STRING float \param p position in tree **/ void genie_float (NODE_T * p) { PUSH_PRIMITIVE (p, 1, A68_INT); genie_real (p); } /* ALGOL68C routines */ /*! \brief PROC INT read int \param p position in tree **/ void genie_read_int (NODE_T * p) { open_for_reading (p, stand_in); genie_read_standard (p, MODE (INT), STACK_TOP, stand_in); INCREMENT_STACK_POINTER (p, ALIGNED_SIZE_OF (A68_INT)); } /*! \brief PROC LONG INT read long int \param p position in tree **/ void genie_read_long_int (NODE_T * p) { open_for_reading (p, stand_in); genie_read_standard (p, MODE (LONG_INT), STACK_TOP, stand_in); INCREMENT_STACK_POINTER (p, get_mp_size (MODE (LONG_INT))); } /*! \brief PROC LONG LONG INT read long long int \param p position in tree **/ void genie_read_longlong_int (NODE_T * p) { open_for_reading (p, stand_in); genie_read_standard (p, MODE (LONGLONG_INT), STACK_TOP, stand_in); INCREMENT_STACK_POINTER (p, get_mp_size (MODE (LONGLONG_INT))); } /*! \brief PROC REAL read real \param p position in tree **/ void genie_read_real (NODE_T * p) { open_for_reading (p, stand_in); genie_read_standard (p, MODE (REAL), STACK_TOP, stand_in); INCREMENT_STACK_POINTER (p, ALIGNED_SIZE_OF (A68_REAL)); } /*! \brief PROC LONG REAL read long real \param p position in tree **/ void genie_read_long_real (NODE_T * p) { open_for_reading (p, stand_in); genie_read_standard (p, MODE (LONG_REAL), STACK_TOP, stand_in); INCREMENT_STACK_POINTER (p, get_mp_size (MODE (LONG_REAL))); } /*! \brief PROC LONG LONG REAL read long long real \param p position in tree **/ void genie_read_longlong_real (NODE_T * p) { open_for_reading (p, stand_in); genie_read_standard (p, MODE (LONGLONG_REAL), STACK_TOP, stand_in); INCREMENT_STACK_POINTER (p, get_mp_size (MODE (LONGLONG_REAL))); } /*! \brief PROC COMPLEX read complex \param p position in tree **/ void genie_read_complex (NODE_T * p) { open_for_reading (p, stand_in); genie_read_real (p); genie_read_real (p); } /*! \brief PROC LONG COMPLEX read long complex \param p position in tree **/ void genie_read_long_complex (NODE_T * p) { open_for_reading (p, stand_in); genie_read_long_real (p); genie_read_long_real (p); } /*! \brief PROC LONG LONG COMPLEX read long long complex \param p position in tree **/ void genie_read_longlong_complex (NODE_T * p) { open_for_reading (p, stand_in); genie_read_longlong_real (p); genie_read_longlong_real (p); } /*! \brief PROC BOOL read bool \param p position in tree **/ void genie_read_bool (NODE_T * p) { open_for_reading (p, stand_in); genie_read_standard (p, MODE (BOOL), STACK_TOP, stand_in); INCREMENT_STACK_POINTER (p, ALIGNED_SIZE_OF (A68_BOOL)); } /*! \brief PROC BITS read bits \param p position in tree **/ void genie_read_bits (NODE_T * p) { open_for_reading (p, stand_in); genie_read_standard (p, MODE (BITS), STACK_TOP, stand_in); INCREMENT_STACK_POINTER (p, ALIGNED_SIZE_OF (A68_BITS)); } /*! \brief PROC LONG BITS read long bits \param p position in tree **/ void genie_read_long_bits (NODE_T * p) { MP_T *z; STACK_MP (z, p, get_mp_digits (MODE (LONG_BITS))); open_for_reading (p, stand_in); genie_read_standard (p, MODE (LONG_BITS), (BYTE_T *) z, stand_in); } /*! \brief PROC LONG LONG BITS read long long bits \param p position in tree **/ void genie_read_longlong_bits (NODE_T * p) { MP_T *z; STACK_MP (z, p, get_mp_digits (MODE (LONGLONG_BITS))); open_for_reading (p, stand_in); genie_read_standard (p, MODE (LONGLONG_BITS), (BYTE_T *) z, stand_in); } /*! \brief PROC CHAR read char \param p position in tree **/ void genie_read_char (NODE_T * p) { open_for_reading (p, stand_in); genie_read_standard (p, MODE (CHAR), STACK_TOP, stand_in); INCREMENT_STACK_POINTER (p, ALIGNED_SIZE_OF (A68_CHAR)); } /*! \brief PROC STRING read string \param p position in tree **/ void genie_read_string (NODE_T * p) { open_for_reading (p, stand_in); genie_read_standard (p, MODE (STRING), STACK_TOP, stand_in); INCREMENT_STACK_POINTER (p, A68_REF_SIZE); } /*! \brief PROC STRING read line \param p position in tree **/ void genie_read_line (NODE_T * p) { #if defined HAVE_READLINE char * line = readline (""); if (line != NO_TEXT && (int) strlen (line) > 0) { add_history (line); } PUSH_REF (p, c_to_a_string (p, line, DEFAULT_WIDTH)); free (line); #else genie_read_string (p); genie_stand_in (p); genie_new_line (p); #endif } /*! \brief PROC (INT) VOID print int \param p position in tree **/ void genie_print_int (NODE_T * p) { int size = MOID_SIZE (MODE (INT)); reset_transput_buffer (UNFORMATTED_BUFFER); open_for_writing (p, stand_out); genie_write_standard (p, MODE (INT), STACK_OFFSET (-size), stand_out); write_purge_buffer (p, stand_out, UNFORMATTED_BUFFER); DECREMENT_STACK_POINTER (p, size); } /*! \brief PROC (LONG INT) VOID print long int \param p position in tree **/ void genie_print_long_int (NODE_T * p) { int size = MOID_SIZE (MODE (LONG_INT)); reset_transput_buffer (UNFORMATTED_BUFFER); open_for_writing (p, stand_out); genie_write_standard (p, MODE (LONG_INT), STACK_OFFSET (-size), stand_out); write_purge_buffer (p, stand_out, UNFORMATTED_BUFFER); DECREMENT_STACK_POINTER (p, size); } /*! \brief PROC (LONG LONG INT) VOID print long long int \param p position in tree **/ void genie_print_longlong_int (NODE_T * p) { int size = MOID_SIZE (MODE (LONGLONG_INT)); reset_transput_buffer (UNFORMATTED_BUFFER); open_for_writing (p, stand_out); genie_write_standard (p, MODE (LONGLONG_INT), STACK_OFFSET (-size), stand_out); write_purge_buffer (p, stand_out, UNFORMATTED_BUFFER); DECREMENT_STACK_POINTER (p, size); } /*! \brief PROC (REAL) VOID print real \param p position in tree **/ void genie_print_real (NODE_T * p) { int size = MOID_SIZE (MODE (REAL)); reset_transput_buffer (UNFORMATTED_BUFFER); open_for_writing (p, stand_out); genie_write_standard (p, MODE (REAL), STACK_OFFSET (-size), stand_out); write_purge_buffer (p, stand_out, UNFORMATTED_BUFFER); DECREMENT_STACK_POINTER (p, size); } /*! \brief PROC (LONG REAL) VOID print long real \param p position in tree **/ void genie_print_long_real (NODE_T * p) { int size = MOID_SIZE (MODE (LONG_REAL)); reset_transput_buffer (UNFORMATTED_BUFFER); open_for_writing (p, stand_out); genie_write_standard (p, MODE (LONG_REAL), STACK_OFFSET (-size), stand_out); write_purge_buffer (p, stand_out, UNFORMATTED_BUFFER); DECREMENT_STACK_POINTER (p, size); } /*! \brief PROC (LONG LONG REAL) VOID print long long real \param p position in tree **/ void genie_print_longlong_real (NODE_T * p) { int size = MOID_SIZE (MODE (LONGLONG_REAL)); reset_transput_buffer (UNFORMATTED_BUFFER); open_for_writing (p, stand_out); genie_write_standard (p, MODE (LONGLONG_REAL), STACK_OFFSET (-size), stand_out); write_purge_buffer (p, stand_out, UNFORMATTED_BUFFER); DECREMENT_STACK_POINTER (p, size); } /*! \brief PROC (COMPLEX) VOID print complex \param p position in tree **/ void genie_print_complex (NODE_T * p) { int size = MOID_SIZE (MODE (COMPLEX)); reset_transput_buffer (UNFORMATTED_BUFFER); open_for_writing (p, stand_out); genie_write_standard (p, MODE (COMPLEX), STACK_OFFSET (-size), stand_out); write_purge_buffer (p, stand_out, UNFORMATTED_BUFFER); DECREMENT_STACK_POINTER (p, size); } /*! \brief PROC (LONG COMPLEX) VOID print long complex \param p position in tree **/ void genie_print_long_complex (NODE_T * p) { int size = MOID_SIZE (MODE (LONG_COMPLEX)); reset_transput_buffer (UNFORMATTED_BUFFER); open_for_writing (p, stand_out); genie_write_standard (p, MODE (LONG_COMPLEX), STACK_OFFSET (-size), stand_out); write_purge_buffer (p, stand_out, UNFORMATTED_BUFFER); DECREMENT_STACK_POINTER (p, size); } /*! \brief PROC (LONG LONG COMPLEX) VOID print long long complex \param p position in tree **/ void genie_print_longlong_complex (NODE_T * p) { int size = MOID_SIZE (MODE (LONGLONG_COMPLEX)); reset_transput_buffer (UNFORMATTED_BUFFER); open_for_writing (p, stand_out); genie_write_standard (p, MODE (LONGLONG_COMPLEX), STACK_OFFSET (-size), stand_out); write_purge_buffer (p, stand_out, UNFORMATTED_BUFFER); DECREMENT_STACK_POINTER (p, size); } /*! \brief PROC (CHAR) VOID print char \param p position in tree **/ void genie_print_char (NODE_T * p) { int size = MOID_SIZE (MODE (CHAR)); reset_transput_buffer (UNFORMATTED_BUFFER); open_for_writing (p, stand_out); genie_write_standard (p, MODE (CHAR), STACK_OFFSET (-size), stand_out); write_purge_buffer (p, stand_out, UNFORMATTED_BUFFER); DECREMENT_STACK_POINTER (p, size); } /*! \brief PROC (BITS) VOID print bits \param p position in tree **/ void genie_print_bits (NODE_T * p) { int size = MOID_SIZE (MODE (BITS)); reset_transput_buffer (UNFORMATTED_BUFFER); open_for_writing (p, stand_out); genie_write_standard (p, MODE (BITS), STACK_OFFSET (-size), stand_out); write_purge_buffer (p, stand_out, UNFORMATTED_BUFFER); DECREMENT_STACK_POINTER (p, size); } /*! \brief PROC (LONG BITS) VOID print long bits \param p position in tree **/ void genie_print_long_bits (NODE_T * p) { int size = MOID_SIZE (MODE (LONG_BITS)); reset_transput_buffer (UNFORMATTED_BUFFER); open_for_writing (p, stand_out); genie_write_standard (p, MODE (LONG_BITS), STACK_OFFSET (-size), stand_out); write_purge_buffer (p, stand_out, UNFORMATTED_BUFFER); DECREMENT_STACK_POINTER (p, size); } /*! \brief PROC (LONG LONG BITS) VOID print long long bits \param p position in tree **/ void genie_print_longlong_bits (NODE_T * p) { int size = MOID_SIZE (MODE (LONGLONG_BITS)); reset_transput_buffer (UNFORMATTED_BUFFER); open_for_writing (p, stand_out); genie_write_standard (p, MODE (LONGLONG_BITS), STACK_OFFSET (-size), stand_out); write_purge_buffer (p, stand_out, UNFORMATTED_BUFFER); DECREMENT_STACK_POINTER (p, size); } /*! \brief PROC (BOOL) VOID print bool \param p position in tree **/ void genie_print_bool (NODE_T * p) { int size = MOID_SIZE (MODE (BOOL)); reset_transput_buffer (UNFORMATTED_BUFFER); open_for_writing (p, stand_out); genie_write_standard (p, MODE (BOOL), STACK_OFFSET (-size), stand_out); write_purge_buffer (p, stand_out, UNFORMATTED_BUFFER); DECREMENT_STACK_POINTER (p, size); } /*! \brief PROC (STRING) VOID print string \param p position in tree **/ void genie_print_string (NODE_T * p) { reset_transput_buffer (UNFORMATTED_BUFFER); add_string_from_stack_transput_buffer (p, UNFORMATTED_BUFFER); open_for_writing (p, stand_out); write_purge_buffer (p, stand_out, UNFORMATTED_BUFFER); } /* Transput library - Formatted transput In Algol68G, a value of mode FORMAT looks like a routine text. The value comprises a pointer to its environment in the stack, and a pointer where the format text is at in the syntax tree. */ #define INT_DIGITS "0123456789" #define BITS_DIGITS "0123456789abcdefABCDEF" #define INT_DIGITS_BLANK " 0123456789" #define BITS_DIGITS_BLANK " 0123456789abcdefABCDEF" #define SIGN_DIGITS " +-" /*! \brief handle format error event \param p position in tree \param ref_file fat pointer to A68 file **/ void format_error (NODE_T * p, A68_REF ref_file, char *diag) { A68_FILE *f = FILE_DEREF (&ref_file); A68_BOOL z; on_event_handler (p, FORMAT_ERROR_MENDED (f), ref_file); POP_OBJECT (p, &z, A68_BOOL); if (VALUE (&z) == A68_FALSE) { diagnostic_node (A68_RUNTIME_ERROR, p, diag); exit_genie (p, A68_RUNTIME_ERROR); } } /*! \brief initialise processing of pictures \param p position in tree **/ static void initialise_collitems (NODE_T * p) { /* Every picture has a counter that says whether it has not been used OR the number of times it can still be used. */ for (; p != NO_NODE; FORWARD (p)) { if (IS (p, PICTURE)) { A68_COLLITEM *z = (A68_COLLITEM *) FRAME_LOCAL (frame_pointer, OFFSET (TAX (p))); STATUS (z) = INIT_MASK; COUNT (z) = ITEM_NOT_USED; } /* Don't dive into f, g, n frames and collections */ if (!(IS (p, ENCLOSED_CLAUSE) || IS (p, COLLECTION))) { initialise_collitems (SUB (p)); } } } /*! \brief initialise processing of format text \param file file \param fmt format \param embedded whether embedded format \param init whether to initialise collitems **/ static void open_format_frame (NODE_T * p, A68_REF ref_file, A68_FORMAT * fmt, BOOL_T embedded, BOOL_T init) { /* Open a new frame for the format text and save for return to embedding one */ A68_FILE *file = FILE_DEREF (&ref_file); NODE_T *dollar; A68_FORMAT *save; /* Integrity check */ if ((STATUS (fmt) & SKIP_FORMAT_MASK) || (BODY (fmt) == NO_NODE)) { format_error (p, ref_file, ERROR_FORMAT_UNDEFINED); } /* Ok, seems usable */ dollar = SUB (BODY (fmt)); OPEN_PROC_FRAME (dollar, ENVIRON (fmt)); INIT_STATIC_FRAME (dollar); /* Save old format */ save = (A68_FORMAT *) FRAME_LOCAL (frame_pointer, OFFSET (TAX (dollar))); *save = (embedded == EMBEDDED_FORMAT ? FORMAT (file) : nil_format); FORMAT (file) = *fmt; /* Reset all collitems */ if (init) { initialise_collitems (dollar); } } /*! \brief handle end-of-format event \param p position in tree \param ref_file fat pointer to A68 file \return whether format is embedded **/ int end_of_format (NODE_T * p, A68_REF ref_file) { /* Format-items return immediately to the embedding format text. The outermost format text calls "on format end". */ A68_FILE *file = FILE_DEREF (&ref_file); NODE_T *dollar = SUB (BODY (&FORMAT (file))); A68_FORMAT *save = (A68_FORMAT *) FRAME_LOCAL (frame_pointer, OFFSET (TAX (dollar))); if (IS_NIL_FORMAT (save)) { /* Not embedded, outermost format: execute event routine */ A68_BOOL z; on_event_handler (p, FORMAT_END_MENDED (FILE_DEREF (&ref_file)), ref_file); POP_OBJECT (p, &z, A68_BOOL); if (VALUE (&z) == A68_FALSE) { /* Restart format */ frame_pointer = FRAME_POINTER (file); stack_pointer = STACK_POINTER (file); open_format_frame (p, ref_file, &FORMAT (file), NOT_EMBEDDED_FORMAT, A68_TRUE); } return (NOT_EMBEDDED_FORMAT); } else { /* Embedded format, return to embedding format, cf. RR */ CLOSE_FRAME; FORMAT (file) = *save; return (EMBEDDED_FORMAT); } } /*! \brief return integral value of replicator \param p position in tree \return same **/ int get_replicator_value (NODE_T * p, BOOL_T check) { int z = 0; if (IS (p, STATIC_REPLICATOR)) { A68_INT u; if (genie_string_to_value_internal (p, MODE (INT), NSYMBOL (p), (BYTE_T *) & u) == A68_FALSE) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_IN_DENOTATION, MODE (INT)); exit_genie (p, A68_RUNTIME_ERROR); } z = VALUE (&u); } else if (IS (p, DYNAMIC_REPLICATOR)) { A68_INT u; EXECUTE_UNIT (NEXT_SUB (p)); POP_OBJECT (p, &u, A68_INT); z = VALUE (&u); } else if (IS (p, REPLICATOR)) { z = get_replicator_value (SUB (p), check); } if (check && z < 0) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FORMAT_INVALID_REPLICATOR); exit_genie (p, A68_RUNTIME_ERROR); } return (z); } /*! \brief return first available pattern \param p position in tree \param ref_file fat pointer to A68 file \return same **/ static NODE_T *scan_format_pattern (NODE_T * p, A68_REF ref_file) { for (; p != NO_NODE; FORWARD (p)) { if (IS (p, PICTURE_LIST)) { NODE_T *prio = scan_format_pattern (SUB (p), ref_file); if (prio != NO_NODE) { return (prio); } } if (IS (p, PICTURE)) { NODE_T *picture = SUB (p); A68_COLLITEM *collitem = (A68_COLLITEM *) FRAME_LOCAL (frame_pointer, OFFSET (TAX (p))); if (COUNT (collitem) != 0) { if (IS (picture, A68_PATTERN)) { COUNT (collitem) = 0; /* This pattern is now done */ picture = SUB (picture); if (ATTRIBUTE (picture) != FORMAT_PATTERN) { return (picture); } else { NODE_T *pat; A68_FORMAT z; A68_FILE *file = FILE_DEREF (&ref_file); EXECUTE_UNIT (NEXT_SUB (picture)); POP_OBJECT (p, &z, A68_FORMAT); open_format_frame (p, ref_file, &z, EMBEDDED_FORMAT, A68_TRUE); pat = scan_format_pattern (SUB (BODY (&FORMAT (file))), ref_file); if (pat != NO_NODE) { return (pat); } else { (void) end_of_format (p, ref_file); } } } else if (IS (picture, INSERTION)) { A68_FILE *file = FILE_DEREF (&ref_file); if (READ_MOOD (file)) { read_insertion (picture, ref_file); } else if (WRITE_MOOD (file)) { write_insertion (picture, ref_file, INSERTION_NORMAL); } else { ABEND (A68_TRUE, "undetermined mood for insertion", NO_TEXT); } COUNT (collitem) = 0; /* This insertion is now done */ } else if (IS (picture, REPLICATOR) || IS (picture, COLLECTION)) { BOOL_T go_on = A68_TRUE; NODE_T *a68g_select = NO_NODE; if (COUNT (collitem) == ITEM_NOT_USED) { if (IS (picture, REPLICATOR)) { COUNT (collitem) = get_replicator_value (SUB (p), A68_TRUE); go_on = (BOOL_T) (COUNT (collitem) > 0); FORWARD (picture); } else { COUNT (collitem) = 1; } initialise_collitems (NEXT_SUB (picture)); } else if (IS (picture, REPLICATOR)) { FORWARD (picture); } while (go_on) { /* Get format item from collection. If collection is done, but repitition is not, then re-initialise the collection and repeat */ a68g_select = scan_format_pattern (NEXT_SUB (picture), ref_file); if (a68g_select != NO_NODE) { return (a68g_select); } else { COUNT (collitem)--; go_on = (BOOL_T) (COUNT (collitem) > 0); if (go_on) { initialise_collitems (NEXT_SUB (picture)); } } } } } } } return (NO_NODE); } /*! \brief return first available pattern \param p position in tree \param ref_file fat pointer to A68 file \param mood mode of operation \return same **/ NODE_T *get_next_format_pattern (NODE_T * p, A68_REF ref_file, BOOL_T mood) { /* "mood" can be WANT_PATTERN: pattern needed by caller, so perform end-of-format if needed or SKIP_PATTERN: just emptying current pattern/collection/format. */ A68_FILE *file = FILE_DEREF (&ref_file); if (BODY (&FORMAT (file)) == NO_NODE) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FORMAT_EXHAUSTED); exit_genie (p, A68_RUNTIME_ERROR); return (NO_NODE); } else { NODE_T *pat = scan_format_pattern (SUB (BODY (&FORMAT (file))), ref_file); if (pat == NO_NODE) { if (mood == WANT_PATTERN) { int z; do { z = end_of_format (p, ref_file); pat = scan_format_pattern (SUB (BODY (&FORMAT (file))), ref_file); } while (z == EMBEDDED_FORMAT && pat == NO_NODE); if (pat == NO_NODE) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FORMAT_EXHAUSTED); exit_genie (p, A68_RUNTIME_ERROR); } } } return (pat); } } /*! \brief diagnostic_node in case mode does not match picture \param p position in tree \param mode mode of object read or written \param att attribute **/ void pattern_error (NODE_T * p, MOID_T * mode, int att) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FORMAT_CANNOT_TRANSPUT, mode, att); exit_genie (p, A68_RUNTIME_ERROR); } /*! \brief unite value at top of stack to NUMBER \param p position in tree \param mode mode of value \param item pointer to value **/ static void unite_to_number (NODE_T * p, MOID_T * mode, BYTE_T * item) { ADDR_T sp = stack_pointer; PUSH_UNION (p, mode); PUSH (p, item, (int) MOID_SIZE (mode)); stack_pointer = sp + MOID_SIZE (MODE (NUMBER)); } /*! \brief write a group of insertions \param p position in tree \param ref_file fat pointer to A68 file \param mood mode of operation in case of error **/ void write_insertion (NODE_T * p, A68_REF ref_file, unsigned mood) { for (; p != NO_NODE; FORWARD (p)) { write_insertion (SUB (p), ref_file, mood); if (IS (p, FORMAT_ITEM_L)) { add_char_transput_buffer (p, FORMATTED_BUFFER, NEWLINE_CHAR); write_purge_buffer (p, ref_file, FORMATTED_BUFFER); } else if (IS (p, FORMAT_ITEM_P)) { add_char_transput_buffer (p, FORMATTED_BUFFER, FORMFEED_CHAR); write_purge_buffer (p, ref_file, FORMATTED_BUFFER); } else if (IS (p, FORMAT_ITEM_X) || IS (p, FORMAT_ITEM_Q)) { add_char_transput_buffer (p, FORMATTED_BUFFER, BLANK_CHAR); } else if (IS (p, FORMAT_ITEM_Y)) { PUSH_REF (p, ref_file); PUSH_PRIMITIVE (p, -1, A68_INT); genie_set (p); } else if (IS (p, LITERAL)) { if (mood & INSERTION_NORMAL) { add_string_transput_buffer (p, FORMATTED_BUFFER, NSYMBOL (p)); } else if (mood & INSERTION_BLANK) { int j, k = (int) strlen (NSYMBOL (p)); for (j = 1; j <= k; j++) { add_char_transput_buffer (p, FORMATTED_BUFFER, BLANK_CHAR); } } } else if (IS (p, REPLICATOR)) { int j, k = get_replicator_value (SUB (p), A68_TRUE); if (ATTRIBUTE (SUB_NEXT (p)) != FORMAT_ITEM_K) { for (j = 1; j <= k; j++) { write_insertion (NEXT (p), ref_file, mood); } } else { int pos = get_transput_buffer_index (FORMATTED_BUFFER); for (j = 1; j < (k - pos); j++) { add_char_transput_buffer (p, FORMATTED_BUFFER, BLANK_CHAR); } } return; } } } /*! \brief convert to other radix, binary up to hexadecimal \param p position in tree \param z value to convert \param radix radix \param width width of converted number \return whether conversion is successful **/ static BOOL_T convert_radix (NODE_T * p, unsigned z, int radix, int width) { static char *images = "0123456789abcdef"; if (width > 0 && (radix >= 2 && radix <= 16)) { int digit = (int) (z % (unsigned) radix); BOOL_T success = convert_radix (p, z / (unsigned) radix, radix, width - 1); add_char_transput_buffer (p, EDIT_BUFFER, images[digit]); return (success); } else { return ((BOOL_T) (z == 0)); } } /*! \brief convert to other radix, binary up to hexadecimal \param p position in tree \param u mp number \param radix radix \param width width of converted number \param m mode of 'u' \param v work mp number \param w work mp number \return whether conversion is successful **/ static BOOL_T convert_radix_mp (NODE_T * p, MP_T * u, int radix, int width, MOID_T * m, MP_T * v, MP_T * w) { static char *images = "0123456789abcdef"; if (width > 0 && (radix >= 2 && radix <= 16)) { int digit, digits = get_mp_digits (m); BOOL_T success; MOVE_MP (w, u, digits); (void) over_mp_digit (p, u, u, (MP_T) radix, digits); (void) mul_mp_digit (p, v, u, (MP_T) radix, digits); (void) sub_mp (p, v, w, v, digits); digit = (int) MP_DIGIT (v, 1); success = convert_radix_mp (p, u, radix, width - 1, m, v, w); add_char_transput_buffer (p, EDIT_BUFFER, images[digit]); return (success); } else { return ((BOOL_T) (MP_DIGIT (u, 1) == 0)); } } /*! \brief write string to file following current format \param p position in tree \param mode mode of value \param ref_file fat pointer to A68 file \param str string to write **/ static void write_string_pattern (NODE_T * p, MOID_T * mode, A68_REF ref_file, char **str) { for (; p != NO_NODE; FORWARD (p)) { if (IS (p, INSERTION)) { write_insertion (SUB (p), ref_file, INSERTION_NORMAL); } else if (IS (p, FORMAT_ITEM_A)) { if ((*str)[0] != NULL_CHAR) { add_char_transput_buffer (p, FORMATTED_BUFFER, (*str)[0]); (*str)++; } else { value_error (p, mode, ref_file); } } else if (IS (p, FORMAT_ITEM_S)) { if ((*str)[0] != NULL_CHAR) { (*str)++; } else { value_error (p, mode, ref_file); } return; } else if (IS (p, REPLICATOR)) { int j, k = get_replicator_value (SUB (p), A68_TRUE); for (j = 1; j <= k; j++) { write_string_pattern (NEXT (p), mode, ref_file, str); } return; } else { write_string_pattern (SUB (p), mode, ref_file, str); } } } /*! \brief scan c_pattern \param p position in tree \param str string to write **/ void scan_c_pattern (NODE_T * p, BOOL_T * right_align, BOOL_T * sign, int *width, int *after, int *letter) { if (IS (p, FORMAT_ITEM_ESCAPE)) { FORWARD (p); } if (IS (p, FORMAT_ITEM_MINUS)) { *right_align = A68_FALSE; FORWARD (p); } else { *right_align = A68_TRUE; } if (IS (p, FORMAT_ITEM_PLUS)) { *sign = A68_TRUE; FORWARD (p); } else { *sign = A68_FALSE; } if (IS (p, REPLICATOR)) { *width = get_replicator_value (SUB (p), A68_TRUE); FORWARD (p); } if (IS (p, FORMAT_ITEM_POINT)) { FORWARD (p); } if (IS (p, REPLICATOR)) { *after = get_replicator_value (SUB (p), A68_TRUE); FORWARD (p); } *letter = ATTRIBUTE (p); } /*! \brief write appropriate insertion from a choice pattern \param p position in tree \param ref_file fat pointer to A68 file \param count count to reach **/ static void write_choice_pattern (NODE_T * p, A68_REF ref_file, int *count) { for (; p != NO_NODE; FORWARD (p)) { write_choice_pattern (SUB (p), ref_file, count); if (IS (p, PICTURE)) { (*count)--; if (*count == 0) { write_insertion (SUB (p), ref_file, INSERTION_NORMAL); } } } } /*! \brief write appropriate insertion from a boolean pattern \param p position in tree \param ref_file fat pointer to A68 file \param z BOOL value **/ static void write_boolean_pattern (NODE_T * p, A68_REF ref_file, BOOL_T z) { int k = (z ? 1 : 2); write_choice_pattern (p, ref_file, &k); } /*! \brief write value according to a general pattern \param p position in tree \param mode mode of value \param item pointer to value \param mod format modifier **/ static void write_number_generic (NODE_T * p, MOID_T * mode, BYTE_T * item, int mod) { A68_REF row; A68_ARRAY *arr; A68_TUPLE *tup; int size; /* Push arguments */ unite_to_number (p, mode, item); EXECUTE_UNIT (NEXT_SUB (p)); POP_REF (p, &row); GET_DESCRIPTOR (arr, tup, &row); size = ROW_SIZE (tup); if (size > 0) { int i; BYTE_T *base_address = DEREF (BYTE_T, &ARRAY (arr)); for (i = LWB (tup); i <= UPB (tup); i++) { int addr = INDEX_1_DIM (arr, tup, i); int arg = VALUE ((A68_INT *) & (base_address[addr])); PUSH_PRIMITIVE (p, arg, A68_INT); } } /* Make a string */ if (mod == FORMAT_ITEM_G) { switch (size) { case 1: { genie_whole (p); break; } case 2: { genie_fixed (p); break; } case 3: { genie_float (p); break; } default: { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FORMAT_INTS_REQUIRED, MODE (INT)); exit_genie (p, A68_RUNTIME_ERROR); break; } } } else if (mod == FORMAT_ITEM_H) { int def_expo = 0, def_mult; A68_INT a_width, a_after, a_expo, a_mult; STATUS (&a_width) = INIT_MASK; VALUE (&a_width) = 0; STATUS (&a_after) = INIT_MASK; VALUE (&a_after) = 0; STATUS (&a_expo) = INIT_MASK; VALUE (&a_expo) = 0; STATUS (&a_mult) = INIT_MASK; VALUE (&a_mult) = 0; /* * Set default values */ if (mode == MODE (REAL) || mode == MODE (INT)) { def_expo = EXP_WIDTH + 1; } else if (mode == MODE (LONG_REAL) || mode == MODE (LONG_INT)) { def_expo = LONG_EXP_WIDTH + 1; } else if (mode == MODE (LONGLONG_REAL) || mode == MODE (LONGLONG_INT)) { def_expo = LONGLONG_EXP_WIDTH + 1; } def_mult = 3; /* * Pop user values */ switch (size) { case 1: { POP_OBJECT (p, &a_after, A68_INT); VALUE (&a_width) = VALUE (&a_after) + def_expo + 4; VALUE (&a_expo) = def_expo; VALUE (&a_mult) = def_mult; break; } case 2: { POP_OBJECT (p, &a_mult, A68_INT); POP_OBJECT (p, &a_after, A68_INT); VALUE (&a_width) = VALUE (&a_after) + def_expo + 4; VALUE (&a_expo) = def_expo; break; } case 3: { POP_OBJECT (p, &a_mult, A68_INT); POP_OBJECT (p, &a_after, A68_INT); POP_OBJECT (p, &a_width, A68_INT); VALUE (&a_expo) = def_expo; break; } case 4: { POP_OBJECT (p, &a_mult, A68_INT); POP_OBJECT (p, &a_expo, A68_INT); POP_OBJECT (p, &a_after, A68_INT); POP_OBJECT (p, &a_width, A68_INT); break; } default: { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FORMAT_INTS_REQUIRED, MODE (INT)); exit_genie (p, A68_RUNTIME_ERROR); break; } } PUSH_PRIMITIVE (p, VALUE (&a_width), A68_INT); PUSH_PRIMITIVE (p, VALUE (&a_after), A68_INT); PUSH_PRIMITIVE (p, VALUE (&a_expo), A68_INT); PUSH_PRIMITIVE (p, VALUE (&a_mult), A68_INT); genie_real (p); } add_string_from_stack_transput_buffer (p, FORMATTED_BUFFER); } /*! \brief write %[-][+][w][.][d]s/d/i/f/e/b/o/x formats \param p position in tree \param mode mode of value \param item pointer to value \param ref_file fat pointer to A68 file **/ static void write_c_pattern (NODE_T * p, MOID_T * mode, BYTE_T * item, A68_REF ref_file) { BOOL_T right_align, sign; int width, after, letter; ADDR_T pop_sp = stack_pointer; char *str = NO_TEXT; if (IS (p, CHAR_C_PATTERN)) { A68_CHAR *z = (A68_CHAR *) item; char q[2]; q[0] = (char) VALUE (z); q[1] = NULL_CHAR; str = (char *) &q; width = (int) strlen (str); scan_c_pattern (SUB (p), &right_align, &sign, &width, &after, &letter); } else if (IS (p, STRING_C_PATTERN)) { str = (char *) item; width = (int) strlen (str); scan_c_pattern (SUB (p), &right_align, &sign, &width, &after, &letter); } else if (IS (p, INTEGRAL_C_PATTERN)) { width = 0; scan_c_pattern (SUB (p), &right_align, &sign, &width, &after, &letter); unite_to_number (p, mode, item); PUSH_PRIMITIVE (p, (sign ? width : -width), A68_INT); str = whole (p); } else if (IS (p, FIXED_C_PATTERN) || IS (p, FLOAT_C_PATTERN) || IS (p, GENERAL_C_PATTERN)) { int att = ATTRIBUTE (p), expval = 0, expo = 0; if (att == FLOAT_C_PATTERN || att == GENERAL_C_PATTERN) { int digits = 0; if (mode == MODE (REAL) || mode == MODE (INT)) { width = REAL_WIDTH + EXP_WIDTH + 4; after = REAL_WIDTH - 1; expo = EXP_WIDTH + 1; } else if (mode == MODE (LONG_REAL) || mode == MODE (LONG_INT)) { width = LONG_REAL_WIDTH + LONG_EXP_WIDTH + 4; after = LONG_REAL_WIDTH - 1; expo = LONG_EXP_WIDTH + 1; } else if (mode == MODE (LONGLONG_REAL) || mode == MODE (LONGLONG_INT)) { width = LONGLONG_REAL_WIDTH + LONGLONG_EXP_WIDTH + 4; after = LONGLONG_REAL_WIDTH - 1; expo = LONGLONG_EXP_WIDTH + 1; } scan_c_pattern (SUB (p), &right_align, &sign, &digits, &after, &letter); if (digits == 0 && after > 0) { width = after + expo + 4; } else if (digits > 0) { width = digits; } unite_to_number (p, mode, item); PUSH_PRIMITIVE (p, (sign ? width : -width), A68_INT); PUSH_PRIMITIVE (p, after, A68_INT); PUSH_PRIMITIVE (p, expo, A68_INT); PUSH_PRIMITIVE (p, 1, A68_INT); str = real (p); stack_pointer = pop_sp; } if (att == GENERAL_C_PATTERN) { char *expch = strchr (str, EXPONENT_CHAR); if (expch != NO_TEXT) { expval = (int) strtol (&(expch[1]), NO_VAR, 10); } } if ((att == FIXED_C_PATTERN) || (att == GENERAL_C_PATTERN && (expval > -4 && expval <= after))) { int digits = 0; if (mode == MODE (REAL) || mode == MODE (INT)) { width = REAL_WIDTH + 2; after = REAL_WIDTH - 1; } else if (mode == MODE (LONG_REAL) || mode == MODE (LONG_INT)) { width = LONG_REAL_WIDTH + 2; after = LONG_REAL_WIDTH - 1; } else if (mode == MODE (LONGLONG_REAL) || mode == MODE (LONGLONG_INT)) { width = LONGLONG_REAL_WIDTH + 2; after = LONGLONG_REAL_WIDTH - 1; } scan_c_pattern (SUB (p), &right_align, &sign, &digits, &after, &letter); if (digits == 0 && after > 0) { width = after + 2; } else if (digits > 0) { width = digits; } unite_to_number (p, mode, item); PUSH_PRIMITIVE (p, (sign ? width : -width), A68_INT); PUSH_PRIMITIVE (p, after, A68_INT); str = fixed (p); stack_pointer = pop_sp; } } else if (IS (p, BITS_C_PATTERN)) { int radix = 10, nibble = 1; width = 0; scan_c_pattern (SUB (p), &right_align, &sign, &width, &after, &letter); if (letter == FORMAT_ITEM_B) { radix = 2; nibble = 1; } else if (letter == FORMAT_ITEM_O) { radix = 8; nibble = 3; } else if (letter == FORMAT_ITEM_X) { radix = 16; nibble = 4; } if (width == 0) { if (mode == MODE (BITS)) { width = (int) ceil ((double) BITS_WIDTH / (double) nibble); } else if (mode == MODE (LONG_BITS) || mode == MODE (LONGLONG_BITS)) { width = (int) ceil ((double) get_mp_bits_width (mode) / (double) nibble); } } if (mode == MODE (BITS)) { A68_BITS *z = (A68_BITS *) item; reset_transput_buffer (EDIT_BUFFER); if (!convert_radix (p, VALUE (z), radix, width)) { errno = EDOM; value_error (p, mode, ref_file); } str = get_transput_buffer (EDIT_BUFFER); } else if (mode == MODE (LONG_BITS) || mode == MODE (LONGLONG_BITS)) { int digits = get_mp_digits (mode); MP_T *u = (MP_T *) item; MP_T *v; MP_T *w; STACK_MP (v, p, digits); STACK_MP (w, p, digits); reset_transput_buffer (EDIT_BUFFER); if (!convert_radix_mp (p, u, radix, width, mode, v, w)) { errno = EDOM; value_error (p, mode, ref_file); } str = get_transput_buffer (EDIT_BUFFER); } } /* Did the conversion succeed? */ if (a68g_strchr (str, ERROR_CHAR) != NO_TEXT) { value_error (p, mode, ref_file); (void) error_chars (get_transput_buffer (FORMATTED_BUFFER), width); } else { /* Align and output */ if (width == 0) { add_string_transput_buffer (p, FORMATTED_BUFFER, str); } else { if (right_align == A68_TRUE) { int blanks = width - (int) strlen (str); if (blanks >= 0) { while (blanks--) { add_char_transput_buffer (p, FORMATTED_BUFFER, BLANK_CHAR); } add_string_transput_buffer (p, FORMATTED_BUFFER, str); } else { value_error (p, mode, ref_file); (void) error_chars (get_transput_buffer (FORMATTED_BUFFER), width); } } else { int blanks; while (str[0] == BLANK_CHAR) { str++; } blanks = width - (int) strlen (str); if (blanks >= 0) { add_string_transput_buffer (p, FORMATTED_BUFFER, str); while (blanks--) { add_char_transput_buffer (p, FORMATTED_BUFFER, BLANK_CHAR); } } else { value_error (p, mode, ref_file); (void) error_chars (get_transput_buffer (FORMATTED_BUFFER), width); } } } } } /*! \brief read one char from file \param p position in tree \param ref_file fat pointer to A68 file \return same **/ static char read_single_char (NODE_T * p, A68_REF ref_file) { A68_FILE *file = FILE_DEREF (&ref_file); int ch = char_scanner (file); if (ch == EOF_CHAR) { end_of_file_error (p, ref_file); } return ((char) ch); } /*! \brief scan n chars from file to input buffer \param p position in tree \param n chars to scan \param m mode being scanned \param ref_file fat pointer to A68 file **/ static void scan_n_chars (NODE_T * p, int n, MOID_T * m, A68_REF ref_file) { int k; (void) m; for (k = 0; k < n; k++) { int ch = read_single_char (p, ref_file); add_char_transput_buffer (p, INPUT_BUFFER, (char) ch); } } /*! \brief read %[-][+][w][.][d]s/d/i/f/e/b/o/x formats \param p position in tree \param mode mode of value \param item pointer to value \param ref_file fat pointer to A68 file **/ static void read_c_pattern (NODE_T * p, MOID_T * mode, BYTE_T * item, A68_REF ref_file) { BOOL_T right_align, sign; int width, after, letter; ADDR_T pop_sp = stack_pointer; reset_transput_buffer (INPUT_BUFFER); if (IS (p, CHAR_C_PATTERN)) { width = 0; scan_c_pattern (SUB (p), &right_align, &sign, &width, &after, &letter); if (width == 0) { genie_read_standard (p, mode, item, ref_file); } else { scan_n_chars (p, width, mode, ref_file); if (width > 1 && right_align == A68_FALSE) { for (; width > 1; width--) { (void) pop_char_transput_buffer (INPUT_BUFFER); } } genie_string_to_value (p, mode, item, ref_file); } } else if (IS (p, STRING_C_PATTERN)) { width = 0; scan_c_pattern (SUB (p), &right_align, &sign, &width, &after, &letter); if (width == 0) { genie_read_standard (p, mode, item, ref_file); } else { scan_n_chars (p, width, mode, ref_file); genie_string_to_value (p, mode, item, ref_file); } } else if (IS (p, INTEGRAL_C_PATTERN)) { if (mode != MODE (INT) && mode != MODE (LONG_INT) && mode != MODE (LONGLONG_INT)) { pattern_error (p, mode, ATTRIBUTE (p)); } else { width = 0; scan_c_pattern (SUB (p), &right_align, &sign, &width, &after, &letter); if (width == 0) { genie_read_standard (p, mode, item, ref_file); } else { scan_n_chars (p, (sign != 0) ? width + 1 : width, mode, ref_file); genie_string_to_value (p, mode, item, ref_file); } } } else if (IS (p, FIXED_C_PATTERN) || IS (p, FLOAT_C_PATTERN) || IS (p, GENERAL_C_PATTERN)) { if (mode != MODE (REAL) && mode != MODE (LONG_REAL) && mode != MODE (LONGLONG_REAL)) { pattern_error (p, mode, ATTRIBUTE (p)); } else { width = 0; scan_c_pattern (SUB (p), &right_align, &sign, &width, &after, &letter); if (width == 0) { genie_read_standard (p, mode, item, ref_file); } else { scan_n_chars (p, (sign != 0) ? width + 1 : width, mode, ref_file); genie_string_to_value (p, mode, item, ref_file); } } } else if (IS (p, BITS_C_PATTERN)) { if (mode != MODE (BITS) && mode != MODE (LONG_BITS) && mode != MODE (LONGLONG_BITS)) { pattern_error (p, mode, ATTRIBUTE (p)); } else { int radix = 10; char *str; width = 0; scan_c_pattern (SUB (p), &right_align, &sign, &width, &after, &letter); if (letter == FORMAT_ITEM_B) { radix = 2; } else if (letter == FORMAT_ITEM_O) { radix = 8; } else if (letter == FORMAT_ITEM_X) { radix = 16; } str = get_transput_buffer (INPUT_BUFFER); if (width == 0) { A68_FILE *file = FILE_DEREF (&ref_file); int ch; ASSERT (snprintf (str, (size_t) TRANSPUT_BUFFER_SIZE, "%dr", radix) >= 0); set_transput_buffer_index (INPUT_BUFFER, (int) strlen (str)); ch = char_scanner (file); while (ch != EOF_CHAR && (IS_SPACE (ch) || IS_NL_FF (ch))) { if (IS_NL_FF (ch)) { skip_nl_ff (p, &ch, ref_file); } else { ch = char_scanner (file); } } while (ch != EOF_CHAR && IS_XDIGIT (ch)) { add_char_transput_buffer (p, INPUT_BUFFER, (char) ch); ch = char_scanner (file); } unchar_scanner (p, file, (char) ch); } else { ASSERT (snprintf (str, (size_t) TRANSPUT_BUFFER_SIZE, "%dr", radix) >= 0); set_transput_buffer_index (INPUT_BUFFER, (int) strlen (str)); scan_n_chars (p, width, mode, ref_file); } genie_string_to_value (p, mode, item, ref_file); } } stack_pointer = pop_sp; } /* INTEGRAL, REAL, COMPLEX and BITS patterns */ /*! \brief count Z and D frames in a mould \param p position in tree \param z counting integer **/ static void count_zd_frames (NODE_T * p, int *z) { for (; p != NO_NODE; FORWARD (p)) { if (IS (p, FORMAT_ITEM_D) || IS (p, FORMAT_ITEM_Z)) { (*z)++; } else if (IS (p, REPLICATOR)) { int j, k = get_replicator_value (SUB (p), A68_TRUE); for (j = 1; j <= k; j++) { count_zd_frames (NEXT (p), z); } return; } else { count_zd_frames (SUB (p), z); } } } /*! \brief get sign from sign mould \param p position in tree \return position of sign in tree or NULL **/ static NODE_T *get_sign (NODE_T * p) { for (; p != NO_NODE; FORWARD (p)) { NODE_T *q = get_sign (SUB (p)); if (q != NO_NODE) { return (q); } else if (IS (p, FORMAT_ITEM_PLUS) || IS (p, FORMAT_ITEM_MINUS)) { return (p); } } return (NO_NODE); } /*! \brief shift sign through Z frames until non-zero digit or D frame \param p position in tree \param q string to propagate sign through **/ static void shift_sign (NODE_T * p, char **q) { for (; p != NO_NODE && (*q) != NO_TEXT; FORWARD (p)) { shift_sign (SUB (p), q); if (IS (p, FORMAT_ITEM_Z)) { if (((*q)[0] == '+' || (*q)[0] == '-') && (*q)[1] == '0') { char ch = (*q)[0]; (*q)[0] = (*q)[1]; (*q)[1] = ch; (*q)++; } } else if (IS (p, FORMAT_ITEM_D)) { (*q) = NO_TEXT; } else if (IS (p, REPLICATOR)) { int j, k = get_replicator_value (SUB (p), A68_TRUE); for (j = 1; j <= k; j++) { shift_sign (NEXT (p), q); } return; } } } /*! \brief pad trailing blanks to integral until desired width \param p position in tree \param n number of zeroes to pad **/ static void put_zeroes_to_integral (NODE_T * p, int n) { for (; n > 0; n--) { add_char_transput_buffer (p, EDIT_BUFFER, '0'); } } /*! \brief pad a sign to integral representation \param p position in tree \param sign sign **/ static void put_sign_to_integral (NODE_T * p, int sign) { NODE_T *sign_node = get_sign (SUB (p)); if (IS (sign_node, FORMAT_ITEM_PLUS)) { add_char_transput_buffer (p, EDIT_BUFFER, (char) (sign >= 0 ? '+' : '-')); } else { add_char_transput_buffer (p, EDIT_BUFFER, (char) (sign >= 0 ? BLANK_CHAR : '-')); } } /*! \brief write point, exponent or plus-i-times symbol \param p position in tree \param ref_file fat pointer to A68 file \param att attribute \param sym symbol to print when matched **/ static void write_pie_frame (NODE_T * p, A68_REF ref_file, int att, int sym) { for (; p != NO_NODE; FORWARD (p)) { if (IS (p, INSERTION)) { write_insertion (p, ref_file, INSERTION_NORMAL); } else if (IS (p, att)) { write_pie_frame (SUB (p), ref_file, att, sym); return; } else if (IS (p, sym)) { add_string_transput_buffer (p, FORMATTED_BUFFER, NSYMBOL (p)); } else if (IS (p, FORMAT_ITEM_S)) { return; } } } /*! \brief write sign when appropriate \param p position in tree \param q string to write **/ static void write_mould_put_sign (NODE_T * p, char **q) { if ((*q)[0] == '+' || (*q)[0] == '-' || (*q)[0] == BLANK_CHAR) { add_char_transput_buffer (p, FORMATTED_BUFFER, (*q)[0]); (*q)++; } } /*! \brief write string according to a mould \param p position in tree \param ref_file fat pointer to A68 file \param type pattern type \param q string to write \param mood mode of operation **/ static void add_char_mould (NODE_T *p, char ch, char **q) { if (ch != NULL_CHAR) { add_char_transput_buffer (p, FORMATTED_BUFFER, ch); (*q)++; } } static void write_mould (NODE_T * p, A68_REF ref_file, int type, char **q, unsigned *mood) { for (; p != NO_NODE; FORWARD (p)) { /* Insertions are inserted straight away. Note that we can suppress them using "mood", which is not standard A68 */ if (IS (p, INSERTION)) { write_insertion (SUB (p), ref_file, *mood); } else { write_mould (SUB (p), ref_file, type, q, mood); /* Z frames print blanks until first non-zero digits comes */ if (IS (p, FORMAT_ITEM_Z)) { write_mould_put_sign (p, q); if ((*q)[0] == '0') { if (*mood & DIGIT_BLANK) { add_char_mould (p, BLANK_CHAR, q); *mood = (*mood & ~INSERTION_NORMAL) | INSERTION_BLANK; } else if (*mood & DIGIT_NORMAL) { add_char_mould (p, '0', q); *mood = (unsigned) (DIGIT_NORMAL | INSERTION_NORMAL); } } else { add_char_mould (p, (*q)[0], q); *mood = (unsigned) (DIGIT_NORMAL | INSERTION_NORMAL); } } /* D frames print a digit */ else if (IS (p, FORMAT_ITEM_D)) { write_mould_put_sign (p, q); add_char_mould (p, (*q)[0], q); *mood = (unsigned) (DIGIT_NORMAL | INSERTION_NORMAL); } /* Suppressible frames */ else if (IS (p, FORMAT_ITEM_S)) { /* Suppressible frames are ignored in a sign-mould */ if (type == SIGN_MOULD) { write_mould (NEXT (p), ref_file, type, q, mood); } else if (type == INTEGRAL_MOULD) { if ((*q)[0] != NULL_CHAR) { (*q)++; } } return; } /* Replicator */ else if (IS (p, REPLICATOR)) { int j, k = get_replicator_value (SUB (p), A68_TRUE); for (j = 1; j <= k; j++) { write_mould (NEXT (p), ref_file, type, q, mood); } return; } } } } /*! \brief write INT value using int pattern \param p position in tree \param mode mode of value \param item pointer to value \param ref_file fat pointer to A68 file **/ static void write_integral_pattern (NODE_T * p, MOID_T * mode, MOID_T * root, BYTE_T * item, A68_REF ref_file) { RESET_ERRNO; if (!(mode == MODE (INT) || mode == MODE (LONG_INT) || mode == MODE (LONGLONG_INT))) { pattern_error (p, root, ATTRIBUTE (p)); } else { ADDR_T old_stack_pointer = stack_pointer; char *str; int width = 0, sign = 0; unsigned mood; /* Dive into the pattern if needed */ if (IS (p, INTEGRAL_PATTERN)) { p = SUB (p); } /* Find width */ count_zd_frames (p, &width); /* Make string */ reset_transput_buffer (EDIT_BUFFER); if (mode == MODE (INT)) { A68_INT *z = (A68_INT *) item; sign = SIGN (VALUE (z)); str = sub_whole (p, ABS (VALUE (z)), width); } else if (mode == MODE (LONG_INT) || mode == MODE (LONGLONG_INT)) { MP_T *z = (MP_T *) item; sign = SIGN (z[2]); z[2] = ABS (z[2]); str = long_sub_whole (p, z, get_mp_digits (mode), width); } /* Edit string and output */ if (a68g_strchr (str, ERROR_CHAR) != NO_TEXT) { value_error (p, root, ref_file); } if (IS (p, SIGN_MOULD)) { put_sign_to_integral (p, sign); } else if (sign < 0) { value_sign_error (p, root, ref_file); } put_zeroes_to_integral (p, width - (int) strlen (str)); add_string_transput_buffer (p, EDIT_BUFFER, str); str = get_transput_buffer (EDIT_BUFFER); mood = (unsigned) (DIGIT_BLANK | INSERTION_NORMAL); if (IS (p, SIGN_MOULD)) { if (str[0] == '+' || str[0] == '-') { shift_sign (SUB (p), &str); } str = get_transput_buffer (EDIT_BUFFER); write_mould (SUB (p), ref_file, SIGN_MOULD, &str, &mood); FORWARD (p); } if (IS (p, INTEGRAL_MOULD)) { /* This *should* be the case */ write_mould (SUB (p), ref_file, INTEGRAL_MOULD, &str, &mood); } stack_pointer = old_stack_pointer; } } /*! \brief write REAL value using real pattern \param p position in tree \param mode mode of value \param item pointer to value \param ref_file fat pointer to A68 file **/ static void write_real_pattern (NODE_T * p, MOID_T * mode, MOID_T * root, BYTE_T * item, A68_REF ref_file) { RESET_ERRNO; if (!(mode == MODE (REAL) || mode == MODE (LONG_REAL) || mode == MODE (LONGLONG_REAL) || mode == MODE (INT) || mode == MODE (LONG_INT) || mode == MODE (LONGLONG_INT))) { pattern_error (p, root, ATTRIBUTE (p)); } else { ADDR_T old_stack_pointer = stack_pointer; int sign_digits, stag_digits = 0, frac_digits = 0, expo_digits = 0; int mant_length, sign = 0, exp_value; NODE_T *q, *sign_mould = NO_NODE, *stag_mould = NO_NODE, *point_frame = NO_NODE, *frac_mould = NO_NODE, *e_frame = NO_NODE, *expo_mould = NO_NODE; char *str = NO_TEXT, *stag_str = NO_TEXT, *frac_str = NO_TEXT; unsigned mood; /* Dive into pattern */ q = ((IS (p, REAL_PATTERN)) ? SUB (p) : p); /* Dissect pattern and establish widths */ if (q != NO_NODE && IS (q, SIGN_MOULD)) { sign_mould = q; count_zd_frames (SUB (sign_mould), &stag_digits); FORWARD (q); } sign_digits = stag_digits; if (q != NO_NODE && IS (q, INTEGRAL_MOULD)) { stag_mould = q; count_zd_frames (SUB (stag_mould), &stag_digits); FORWARD (q); } if (q != NO_NODE && IS (q, FORMAT_POINT_FRAME)) { point_frame = q; FORWARD (q); } if (q != NO_NODE && IS (q, INTEGRAL_MOULD)) { frac_mould = q; count_zd_frames (SUB (frac_mould), &frac_digits); FORWARD (q); } if (q != NO_NODE && IS (q, EXPONENT_FRAME)) { e_frame = SUB (q); expo_mould = NEXT_SUB (q); q = expo_mould; if (IS (q, SIGN_MOULD)) { count_zd_frames (SUB (q), &expo_digits); FORWARD (q); } if (IS (q, INTEGRAL_MOULD)) { count_zd_frames (SUB (q), &expo_digits); } } /* Make string representation */ if (point_frame == NO_NODE) { mant_length = stag_digits; } else { mant_length = 1 + stag_digits + frac_digits; } if (mode == MODE (REAL) || mode == MODE (INT)) { double x; if (mode == MODE (REAL)) { x = VALUE ((A68_REAL *) item); } else { x = (double) VALUE ((A68_INT *) item); } #if defined HAVE_IEEE_754 if (NOT_A_REAL (x)) { char *s = stack_string (p, 8 + mant_length); (void) error_chars (s, mant_length); add_string_transput_buffer (p, FORMATTED_BUFFER, s); stack_pointer = old_stack_pointer; return; } #endif exp_value = 0; sign = SIGN (x); if (sign_mould != NO_NODE) { put_sign_to_integral (sign_mould, sign); } x = ABS (x); if (expo_mould != NO_NODE) { standardise (&x, stag_digits, frac_digits, &exp_value); } str = sub_fixed (p, x, mant_length, frac_digits); } else if (mode == MODE (LONG_REAL) || mode == MODE (LONGLONG_REAL) || mode == MODE (LONG_INT) || mode == MODE (LONGLONG_INT)) { ADDR_T old_stack_pointer2 = stack_pointer; int digits = get_mp_digits (mode); MP_T *x; STACK_MP (x, p, digits); MOVE_MP (x, (MP_T *) item, digits); exp_value = 0; sign = SIGN (x[2]); if (sign_mould != NO_NODE) { put_sign_to_integral (sign_mould, sign); } x[2] = ABS (x[2]); if (expo_mould != NO_NODE) { long_standardise (p, x, get_mp_digits (mode), stag_digits, frac_digits, &exp_value); } str = long_sub_fixed (p, x, get_mp_digits (mode), mant_length, frac_digits); stack_pointer = old_stack_pointer2; } /* Edit and output the string */ if (a68g_strchr (str, ERROR_CHAR) != NO_TEXT) { value_error (p, root, ref_file); } reset_transput_buffer (STRING_BUFFER); add_string_transput_buffer (p, STRING_BUFFER, str); stag_str = get_transput_buffer (STRING_BUFFER); if (a68g_strchr (stag_str, ERROR_CHAR) != NO_TEXT) { value_error (p, root, ref_file); } str = a68g_strchr (stag_str, POINT_CHAR); if (str != NO_TEXT) { frac_str = &str[1]; str[0] = NULL_CHAR; } else { frac_str = NO_TEXT; } /* Stagnant part */ reset_transput_buffer (EDIT_BUFFER); if (sign_mould != NO_NODE) { put_sign_to_integral (sign_mould, sign); } else if (sign < 0) { value_sign_error (sign_mould, root, ref_file); } put_zeroes_to_integral (p, stag_digits - (int) strlen (stag_str)); add_string_transput_buffer (p, EDIT_BUFFER, stag_str); stag_str = get_transput_buffer (EDIT_BUFFER); mood = (unsigned) (DIGIT_BLANK | INSERTION_NORMAL); if (sign_mould != NO_NODE) { if (stag_str[0] == '+' || stag_str[0] == '-') { shift_sign (SUB (p), &stag_str); } stag_str = get_transput_buffer (EDIT_BUFFER); write_mould (SUB (sign_mould), ref_file, SIGN_MOULD, &stag_str, &mood); } if (stag_mould != NO_NODE) { write_mould (SUB (stag_mould), ref_file, INTEGRAL_MOULD, &stag_str, &mood); } /* Point frame */ if (point_frame != NO_NODE) { write_pie_frame (point_frame, ref_file, FORMAT_POINT_FRAME, FORMAT_ITEM_POINT); } /* Fraction */ if (frac_mould != NO_NODE) { reset_transput_buffer (EDIT_BUFFER); add_string_transput_buffer (p, EDIT_BUFFER, frac_str); frac_str = get_transput_buffer (EDIT_BUFFER); mood = (unsigned) (DIGIT_NORMAL | INSERTION_NORMAL); write_mould (SUB (frac_mould), ref_file, INTEGRAL_MOULD, &frac_str, &mood); } /* Exponent */ if (expo_mould != NO_NODE) { A68_INT z; STATUS (&z) = INIT_MASK; VALUE (&z) = exp_value; if (e_frame != NO_NODE) { write_pie_frame (e_frame, ref_file, FORMAT_E_FRAME, FORMAT_ITEM_E); } write_integral_pattern (expo_mould, MODE (INT), root, (BYTE_T *) & z, ref_file); } stack_pointer = old_stack_pointer; } } /*! \brief write COMPLEX value using complex pattern \param p position in tree \param comp mode of complex number \param re pointer to real part \param im pointer to imaginary part \param ref_file fat pointer to A68 file **/ static void write_complex_pattern (NODE_T * p, MOID_T * comp, MOID_T * root, BYTE_T * re, BYTE_T * im, A68_REF ref_file) { NODE_T *reel, *plus_i_times, *imag; RESET_ERRNO; /* Dissect pattern */ reel = SUB (p); plus_i_times = NEXT (reel); imag = NEXT (plus_i_times); /* Write pattern */ write_real_pattern (reel, comp, root, re, ref_file); write_pie_frame (plus_i_times, ref_file, FORMAT_I_FRAME, FORMAT_ITEM_I); write_real_pattern (imag, comp, root, im, ref_file); } /*! \brief write BITS value using bits pattern \param p position in tree \param mode mode of value \param item pointer to value \param ref_file fat pointer to A68 file **/ static void write_bits_pattern (NODE_T * p, MOID_T * mode, BYTE_T * item, A68_REF ref_file) { if (mode == MODE (BITS)) { int width = 0, radix; unsigned mood; A68_BITS *z = (A68_BITS *) item; char *str; /* Establish width and radix */ count_zd_frames (SUB (p), &width); radix = get_replicator_value (SUB_SUB (p), A68_TRUE); if (radix < 2 || radix > 16) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_INVALID_RADIX, radix); exit_genie (p, A68_RUNTIME_ERROR); } /* Generate string of correct width */ reset_transput_buffer (EDIT_BUFFER); if (!convert_radix (p, VALUE (z), radix, width)) { errno = EDOM; value_error (p, mode, ref_file); } /* Output the edited string */ mood = (unsigned) (DIGIT_BLANK | INSERTION_NORMAL); str = get_transput_buffer (EDIT_BUFFER); write_mould (NEXT_SUB (p), ref_file, INTEGRAL_MOULD, &str, &mood); } else if (mode == MODE (LONG_BITS) || mode == MODE (LONGLONG_BITS)) { ADDR_T pop_sp = stack_pointer; int width = 0, radix, digits = get_mp_digits (mode); unsigned mood; MP_T *u = (MP_T *) item; MP_T *v; MP_T *w; char *str; STACK_MP (v, p, digits); STACK_MP (w, p, digits); /* Establish width and radix */ count_zd_frames (SUB (p), &width); radix = get_replicator_value (SUB_SUB (p), A68_TRUE); if (radix < 2 || radix > 16) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_INVALID_RADIX, radix); exit_genie (p, A68_RUNTIME_ERROR); } /* Generate string of correct width */ reset_transput_buffer (EDIT_BUFFER); if (!convert_radix_mp (p, u, radix, width, mode, v, w)) { errno = EDOM; value_error (p, mode, ref_file); } /* Output the edited string */ mood = (unsigned) (DIGIT_BLANK | INSERTION_NORMAL); str = get_transput_buffer (EDIT_BUFFER); write_mould (NEXT_SUB (p), ref_file, INTEGRAL_MOULD, &str, &mood); stack_pointer = pop_sp; } } /*! \brief write value to file \param p position in tree \param item pointer to value \param ref_file fat pointer to A68 file **/ static void genie_write_real_format (NODE_T * p, BYTE_T * item, A68_REF ref_file) { if (IS (p, GENERAL_PATTERN) && NEXT_SUB (p) == NO_NODE) { genie_value_to_string (p, MODE (REAL), item, ATTRIBUTE (SUB (p))); add_string_from_stack_transput_buffer (p, FORMATTED_BUFFER); } else if (IS (p, GENERAL_PATTERN) && NEXT_SUB (p) != NO_NODE) { write_number_generic (p, MODE (REAL), item, ATTRIBUTE (SUB (p))); } else if (IS (p, FIXED_C_PATTERN) || IS (p, FLOAT_C_PATTERN) || IS (p, GENERAL_C_PATTERN)) { write_c_pattern (p, MODE (REAL), item, ref_file); } else if (IS (p, REAL_PATTERN)) { write_real_pattern (p, MODE (REAL), MODE (REAL), item, ref_file); } else if (IS (p, COMPLEX_PATTERN)) { A68_REAL im; STATUS (&im) = INIT_MASK; VALUE (&im) = 0.0; write_complex_pattern (p, MODE (REAL), MODE (COMPLEX), (BYTE_T *) item, (BYTE_T *) & im, ref_file); } else { pattern_error (p, MODE (REAL), ATTRIBUTE (p)); } } /*! \brief write value to file \param p position in tree \param item pointer to value \param ref_file fat pointer to A68 file **/ static void genie_write_long_real_format (NODE_T * p, BYTE_T * item, A68_REF ref_file) { if (IS (p, GENERAL_PATTERN) && NEXT_SUB (p) == NO_NODE) { genie_value_to_string (p, MODE (LONG_REAL), item, ATTRIBUTE (SUB (p))); add_string_from_stack_transput_buffer (p, FORMATTED_BUFFER); } else if (IS (p, GENERAL_PATTERN) && NEXT_SUB (p) != NO_NODE) { write_number_generic (p, MODE (LONG_REAL), item, ATTRIBUTE (SUB (p))); } else if (IS (p, FIXED_C_PATTERN) || IS (p, FLOAT_C_PATTERN) || IS (p, GENERAL_C_PATTERN)) { write_c_pattern (p, MODE (LONG_REAL), item, ref_file); } else if (IS (p, REAL_PATTERN)) { write_real_pattern (p, MODE (LONG_REAL), MODE (LONG_REAL), item, ref_file); } else if (IS (p, COMPLEX_PATTERN)) { ADDR_T old_stack_pointer = stack_pointer; MP_T *z; STACK_MP (z, p, get_mp_digits (MODE (LONG_REAL))); SET_MP_ZERO (z, get_mp_digits (MODE (LONG_REAL))); z[0] = (MP_T) INIT_MASK; write_complex_pattern (p, MODE (LONG_REAL), MODE (LONG_COMPLEX), item, (BYTE_T *) z, ref_file); stack_pointer = old_stack_pointer; } else { pattern_error (p, MODE (LONG_REAL), ATTRIBUTE (p)); } } /*! \brief write value to file \param p position in tree \param item pointer to value \param ref_file fat pointer to A68 file **/ static void genie_write_longlong_real_format (NODE_T * p, BYTE_T * item, A68_REF ref_file) { if (IS (p, GENERAL_PATTERN) && NEXT_SUB (p) == NO_NODE) { genie_value_to_string (p, MODE (LONGLONG_REAL), item, ATTRIBUTE (SUB (p))); add_string_from_stack_transput_buffer (p, FORMATTED_BUFFER); } else if (IS (p, GENERAL_PATTERN) && NEXT_SUB (p) != NO_NODE) { write_number_generic (p, MODE (LONGLONG_REAL), item, ATTRIBUTE (SUB (p))); } else if (IS (p, FIXED_C_PATTERN) || IS (p, FLOAT_C_PATTERN) || IS (p, GENERAL_C_PATTERN)) { write_c_pattern (p, MODE (LONGLONG_REAL), item, ref_file); } else if (IS (p, REAL_PATTERN)) { write_real_pattern (p, MODE (LONGLONG_REAL), MODE (LONGLONG_REAL), item, ref_file); } else if (IS (p, COMPLEX_PATTERN)) { ADDR_T old_stack_pointer = stack_pointer; MP_T *z; STACK_MP (z, p, get_mp_digits (MODE (LONGLONG_REAL))); SET_MP_ZERO (z, get_mp_digits (MODE (LONGLONG_REAL))); z[0] = (MP_T) INIT_MASK; write_complex_pattern (p, MODE (LONGLONG_REAL), MODE (LONGLONG_COMPLEX), item, (BYTE_T *) z, ref_file); stack_pointer = old_stack_pointer; } else { pattern_error (p, MODE (LONGLONG_REAL), ATTRIBUTE (p)); } } /*! \brief write value to file \param p position in tree \param mode mode of value \param item pointer to value \param ref_file fat pointer to A68 file **/ static void genie_write_standard_format (NODE_T * p, MOID_T * mode, BYTE_T * item, A68_REF ref_file) { RESET_ERRNO; if (mode == MODE (INT)) { NODE_T *pat = get_next_format_pattern (p, ref_file, WANT_PATTERN); if (IS (pat, GENERAL_PATTERN) && NEXT_SUB (pat) == NO_NODE) { genie_value_to_string (p, mode, item, ATTRIBUTE (SUB (pat))); add_string_from_stack_transput_buffer (p, FORMATTED_BUFFER); } else if (IS (pat, GENERAL_PATTERN) && NEXT_SUB (pat) != NO_NODE) { write_number_generic (pat, MODE (INT), item, ATTRIBUTE (SUB (pat))); } else if (IS (pat, INTEGRAL_C_PATTERN) || IS (pat, FIXED_C_PATTERN) || IS (pat, FLOAT_C_PATTERN) || IS (pat, GENERAL_C_PATTERN)) { write_c_pattern (pat, MODE (INT), item, ref_file); } else if (IS (pat, INTEGRAL_PATTERN)) { write_integral_pattern (pat, MODE (INT), MODE (INT), item, ref_file); } else if (IS (pat, REAL_PATTERN)) { write_real_pattern (pat, MODE (INT), MODE (INT), item, ref_file); } else if (IS (pat, COMPLEX_PATTERN)) { A68_REAL re, im; STATUS (&re) = INIT_MASK; VALUE (&re) = (double) VALUE ((A68_INT *) item); STATUS (&im) = INIT_MASK; VALUE (&im) = 0.0; write_complex_pattern (pat, MODE (REAL), MODE (COMPLEX), (BYTE_T *) & re, (BYTE_T *) & im, ref_file); } else if (IS (pat, CHOICE_PATTERN)) { int k = VALUE ((A68_INT *) item); write_choice_pattern (NEXT_SUB (pat), ref_file, &k); } else { pattern_error (p, mode, ATTRIBUTE (pat)); } } else if (mode == MODE (LONG_INT)) { NODE_T *pat = get_next_format_pattern (p, ref_file, WANT_PATTERN); if (IS (pat, GENERAL_PATTERN) && NEXT_SUB (pat) == NO_NODE) { genie_value_to_string (p, mode, item, ATTRIBUTE (SUB (pat))); add_string_from_stack_transput_buffer (p, FORMATTED_BUFFER); } else if (IS (pat, GENERAL_PATTERN) && NEXT_SUB (pat) != NO_NODE) { write_number_generic (pat, MODE (LONG_INT), item, ATTRIBUTE (SUB (pat))); } else if (IS (pat, INTEGRAL_C_PATTERN) || IS (pat, FIXED_C_PATTERN) || IS (pat, FLOAT_C_PATTERN) || IS (pat, GENERAL_C_PATTERN)) { write_c_pattern (pat, MODE (LONG_INT), item, ref_file); } else if (IS (pat, INTEGRAL_PATTERN)) { write_integral_pattern (pat, MODE (LONG_INT), MODE (LONG_INT), item, ref_file); } else if (IS (pat, REAL_PATTERN)) { write_real_pattern (pat, MODE (LONG_INT), MODE (LONG_INT), item, ref_file); } else if (IS (pat, COMPLEX_PATTERN)) { ADDR_T old_stack_pointer = stack_pointer; MP_T *z; STACK_MP (z, p, get_mp_digits (mode)); SET_MP_ZERO (z, get_mp_digits (mode)); z[0] = (MP_T) INIT_MASK; write_complex_pattern (pat, MODE (LONG_REAL), MODE (LONG_COMPLEX), item, (BYTE_T *) z, ref_file); stack_pointer = old_stack_pointer; } else if (IS (pat, CHOICE_PATTERN)) { int k = mp_to_int (p, (MP_T *) item, get_mp_digits (mode)); write_choice_pattern (NEXT_SUB (pat), ref_file, &k); } else { pattern_error (p, mode, ATTRIBUTE (pat)); } } else if (mode == MODE (LONGLONG_INT)) { NODE_T *pat = get_next_format_pattern (p, ref_file, WANT_PATTERN); if (IS (pat, GENERAL_PATTERN) && NEXT_SUB (pat) == NO_NODE) { genie_value_to_string (p, mode, item, ATTRIBUTE (SUB (pat))); add_string_from_stack_transput_buffer (p, FORMATTED_BUFFER); } else if (IS (pat, GENERAL_PATTERN) && NEXT_SUB (pat) != NO_NODE) { write_number_generic (pat, MODE (LONGLONG_INT), item, ATTRIBUTE (SUB (pat))); } else if (IS (pat, INTEGRAL_C_PATTERN) || IS (pat, FIXED_C_PATTERN) || IS (pat, FLOAT_C_PATTERN) || IS (pat, GENERAL_C_PATTERN)) { write_c_pattern (pat, MODE (LONGLONG_INT), item, ref_file); } else if (IS (pat, INTEGRAL_PATTERN)) { write_integral_pattern (pat, MODE (LONGLONG_INT), MODE (LONGLONG_INT), item, ref_file); } else if (IS (pat, REAL_PATTERN)) { write_real_pattern (pat, MODE (INT), MODE (INT), item, ref_file); } else if (IS (pat, REAL_PATTERN)) { write_real_pattern (pat, MODE (LONGLONG_INT), MODE (LONGLONG_INT), item, ref_file); } else if (IS (pat, COMPLEX_PATTERN)) { ADDR_T old_stack_pointer = stack_pointer; MP_T *z; STACK_MP (z, p, get_mp_digits (MODE (LONGLONG_REAL))); SET_MP_ZERO (z, get_mp_digits (mode)); z[0] = (MP_T) INIT_MASK; write_complex_pattern (pat, MODE (LONGLONG_REAL), MODE (LONGLONG_COMPLEX), item, (BYTE_T *) z, ref_file); stack_pointer = old_stack_pointer; } else if (IS (pat, CHOICE_PATTERN)) { int k = mp_to_int (p, (MP_T *) item, get_mp_digits (mode)); write_choice_pattern (NEXT_SUB (pat), ref_file, &k); } else { pattern_error (p, mode, ATTRIBUTE (pat)); } } else if (mode == MODE (REAL)) { NODE_T *pat = get_next_format_pattern (p, ref_file, WANT_PATTERN); genie_write_real_format (pat, item, ref_file); } else if (mode == MODE (LONG_REAL)) { NODE_T *pat = get_next_format_pattern (p, ref_file, WANT_PATTERN); genie_write_long_real_format (pat, item, ref_file); } else if (mode == MODE (LONGLONG_REAL)) { NODE_T *pat = get_next_format_pattern (p, ref_file, WANT_PATTERN); genie_write_longlong_real_format (pat, item, ref_file); } else if (mode == MODE (COMPLEX)) { NODE_T *pat = get_next_format_pattern (p, ref_file, WANT_PATTERN); if (IS (pat, COMPLEX_PATTERN)) { write_complex_pattern (pat, MODE (REAL), MODE (COMPLEX), &item[0], &item[MOID_SIZE (MODE (REAL))], ref_file); } else { /* Try writing as two REAL values */ genie_write_real_format (pat, item, ref_file); genie_write_standard_format (p, MODE (REAL), &item[MOID_SIZE (MODE (REAL))], ref_file); } } else if (mode == MODE (LONG_COMPLEX)) { NODE_T *pat = get_next_format_pattern (p, ref_file, WANT_PATTERN); if (IS (pat, COMPLEX_PATTERN)) { write_complex_pattern (pat, MODE (LONG_REAL), MODE (LONG_COMPLEX), &item[0], &item[MOID_SIZE (MODE (LONG_REAL))], ref_file); } else { /* Try writing as two LONG REAL values */ genie_write_long_real_format (pat, item, ref_file); genie_write_standard_format (p, MODE (LONG_REAL), &item[MOID_SIZE (MODE (LONG_REAL))], ref_file); } } else if (mode == MODE (LONGLONG_COMPLEX)) { NODE_T *pat = get_next_format_pattern (p, ref_file, WANT_PATTERN); if (IS (pat, COMPLEX_PATTERN)) { write_complex_pattern (pat, MODE (LONGLONG_REAL), MODE (LONGLONG_COMPLEX), &item[0], &item[MOID_SIZE (MODE (LONGLONG_REAL))], ref_file); } else { /* Try writing as two LONG LONG REAL values */ genie_write_longlong_real_format (pat, item, ref_file); genie_write_standard_format (p, MODE (LONGLONG_REAL), &item[MOID_SIZE (MODE (LONGLONG_REAL))], ref_file); } } else if (mode == MODE (BOOL)) { A68_BOOL *z = (A68_BOOL *) item; NODE_T *pat = get_next_format_pattern (p, ref_file, WANT_PATTERN); if (IS (pat, GENERAL_PATTERN) && NEXT_SUB (pat) == NO_NODE) { add_char_transput_buffer (p, FORMATTED_BUFFER, (char) (VALUE (z) == A68_TRUE ? FLIP_CHAR : FLOP_CHAR)); } else if (IS (pat, BOOLEAN_PATTERN)) { if (NEXT_SUB (pat) == NO_NODE) { add_char_transput_buffer (p, FORMATTED_BUFFER, (char) (VALUE (z) == A68_TRUE ? FLIP_CHAR : FLOP_CHAR)); } else { write_boolean_pattern (pat, ref_file, (BOOL_T) (VALUE (z) == A68_TRUE)); } } else { pattern_error (p, mode, ATTRIBUTE (pat)); } } else if (mode == MODE (BITS)) { NODE_T *pat = get_next_format_pattern (p, ref_file, WANT_PATTERN); if (IS (pat, GENERAL_PATTERN) && NEXT_SUB (pat) == NO_NODE) { char *str = (char *) STACK_TOP; genie_value_to_string (p, mode, item, ATTRIBUTE (SUB (p))); add_string_transput_buffer (p, FORMATTED_BUFFER, str); } else if (IS (pat, BITS_PATTERN)) { write_bits_pattern (pat, MODE (BITS), item, ref_file); } else if (IS (pat, BITS_C_PATTERN)) { write_c_pattern (pat, MODE (BITS), item, ref_file); } else { pattern_error (p, mode, ATTRIBUTE (pat)); } } else if (mode == MODE (LONG_BITS) || mode == MODE (LONGLONG_BITS)) { NODE_T *pat = get_next_format_pattern (p, ref_file, WANT_PATTERN); if (IS (pat, GENERAL_PATTERN) && NEXT_SUB (pat) == NO_NODE) { char *str = (char *) STACK_TOP; genie_value_to_string (p, mode, item, ATTRIBUTE (SUB (p))); add_string_transput_buffer (p, FORMATTED_BUFFER, str); } else if (IS (pat, BITS_PATTERN)) { write_bits_pattern (pat, mode, item, ref_file); } else if (IS (pat, BITS_C_PATTERN)) { write_c_pattern (pat, mode, item, ref_file); } else { pattern_error (p, mode, ATTRIBUTE (pat)); } } else if (mode == MODE (CHAR)) { A68_CHAR *z = (A68_CHAR *) item; NODE_T *pat = get_next_format_pattern (p, ref_file, WANT_PATTERN); if (IS (pat, GENERAL_PATTERN) && NEXT_SUB (pat) == NO_NODE) { add_char_transput_buffer (p, FORMATTED_BUFFER, (char) VALUE (z)); } else if (IS (pat, STRING_PATTERN)) { char *q = get_transput_buffer (EDIT_BUFFER); reset_transput_buffer (EDIT_BUFFER); add_char_transput_buffer (p, EDIT_BUFFER, (char) VALUE (z)); write_string_pattern (pat, mode, ref_file, &q); if (q[0] != NULL_CHAR) { value_error (p, mode, ref_file); } } else if (IS (pat, STRING_C_PATTERN)) { write_c_pattern (pat, mode, (BYTE_T *) z, ref_file); } else { pattern_error (p, mode, ATTRIBUTE (pat)); } } else if (mode == MODE (ROW_CHAR) || mode == MODE (STRING)) { /* Handle these separately instead of printing [] CHAR */ A68_REF row = *(A68_REF *) item; NODE_T *pat = get_next_format_pattern (p, ref_file, WANT_PATTERN); if (IS (pat, GENERAL_PATTERN) && NEXT_SUB (pat) == NO_NODE) { PUSH_REF (p, row); add_string_from_stack_transput_buffer (p, FORMATTED_BUFFER); } else if (IS (pat, STRING_PATTERN)) { char *q; PUSH_REF (p, row); reset_transput_buffer (EDIT_BUFFER); add_string_from_stack_transput_buffer (p, EDIT_BUFFER); q = get_transput_buffer (EDIT_BUFFER); write_string_pattern (pat, mode, ref_file, &q); if (q[0] != NULL_CHAR) { value_error (p, mode, ref_file); } } else if (IS (pat, STRING_C_PATTERN)) { char *q; PUSH_REF (p, row); reset_transput_buffer (EDIT_BUFFER); add_string_from_stack_transput_buffer (p, EDIT_BUFFER); q = get_transput_buffer (EDIT_BUFFER); write_c_pattern (pat, mode, (BYTE_T *) q, ref_file); } else { pattern_error (p, mode, ATTRIBUTE (pat)); } } else if (IS (mode, UNION_SYMBOL)) { A68_UNION *z = (A68_UNION *) item; genie_write_standard_format (p, (MOID_T *) (VALUE (z)), &item[A68_UNION_SIZE], ref_file); } else if (IS (mode, STRUCT_SYMBOL)) { PACK_T *q = PACK (mode); for (; q != NO_PACK; FORWARD (q)) { BYTE_T *elem = &item[OFFSET (q)]; genie_check_initialisation (p, elem, MOID (q)); genie_write_standard_format (p, MOID (q), elem, ref_file); } } else if (IS (mode, ROW_SYMBOL) || IS (mode, FLEX_SYMBOL)) { MOID_T *deflexed = DEFLEX (mode); A68_ARRAY *arr; A68_TUPLE *tup; CHECK_INIT (p, INITIALISED ((A68_REF *) item), MODE (ROWS)); GET_DESCRIPTOR (arr, tup, (A68_REF *) item); if (get_row_size (tup, DIM (arr)) > 0) { BYTE_T *base_addr = DEREF (BYTE_T, &ARRAY (arr)); BOOL_T done = A68_FALSE; initialise_internal_index (tup, DIM (arr)); while (!done) { ADDR_T a68g_index = calculate_internal_index (tup, DIM (arr)); ADDR_T elem_addr = ROW_ELEMENT (arr, a68g_index); BYTE_T *elem = &base_addr[elem_addr]; genie_check_initialisation (p, elem, SUB (deflexed)); genie_write_standard_format (p, SUB (deflexed), elem, ref_file); done = increment_internal_index (tup, DIM (arr)); } } } if (errno != 0) { transput_error (p, ref_file, mode); } } /*! \brief at end of write purge all insertions \param p position in tree \param ref_file fat pointer to A68 file **/ static void purge_format_write (NODE_T * p, A68_REF ref_file) { /* Problem here is shutting down embedded formats */ BOOL_T go_on; do { A68_FILE *file; NODE_T *dollar, *pat; A68_FORMAT *old_fmt; while ((pat = get_next_format_pattern (p, ref_file, SKIP_PATTERN)) != NO_NODE) { format_error (p, ref_file, ERROR_FORMAT_PICTURES); } file = FILE_DEREF (&ref_file); dollar = SUB (BODY (&FORMAT (file))); old_fmt = (A68_FORMAT *) FRAME_LOCAL (frame_pointer, OFFSET (TAX (dollar))); go_on = (BOOL_T) ! IS_NIL_FORMAT (old_fmt); if (go_on) { /* Pop embedded format and proceed */ (void) end_of_format (p, ref_file); } } while (go_on); } /*! \brief PROC ([] SIMPLOUT) VOID print f, write f \param p position in tree **/ void genie_write_format (NODE_T * p) { A68_REF row; POP_REF (p, &row); genie_stand_out (p); PUSH_REF (p, row); genie_write_file_format (p); } /*! \brief PROC (REF FILE, [] SIMPLOUT) VOID put f \param p position in tree **/ void genie_write_file_format (NODE_T * p) { A68_REF ref_file; A68_FILE *file; A68_REF row; A68_ARRAY *arr; A68_TUPLE *tup; BYTE_T *base_address; int elems, k, elem_index, formats; ADDR_T save_frame_pointer, save_stack_pointer; POP_REF (p, &row); CHECK_REF (p, row, MODE (ROW_SIMPLOUT)); GET_DESCRIPTOR (arr, tup, &row); elems = ROW_SIZE (tup); POP_REF (p, &ref_file); CHECK_REF (p, ref_file, MODE (REF_FILE)); file = FILE_DEREF (&ref_file); CHECK_INIT (p, INITIALISED (file), MODE (FILE)); if (!OPENED (file)) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FILE_NOT_OPEN); exit_genie (p, A68_RUNTIME_ERROR); } if (DRAW_MOOD (file)) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "draw"); exit_genie (p, A68_RUNTIME_ERROR); } if (READ_MOOD (file)) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "read"); exit_genie (p, A68_RUNTIME_ERROR); } if (!PUT (&CHANNEL (file))) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_CHANNEL_DOES_NOT_ALLOW, "putting"); exit_genie (p, A68_RUNTIME_ERROR); } if (!READ_MOOD (file) && !WRITE_MOOD (file)) { if (IS_NIL (STRING (file))) { if ((FD (file) = open_physical_file (p, ref_file, A68_WRITE_ACCESS, A68_PROTECTION)) == A68_NO_FILENO) { open_error (p, ref_file, "putting"); } } else { FD (file) = open_physical_file (p, ref_file, A68_READ_ACCESS, 0); } DRAW_MOOD (file) = A68_FALSE; READ_MOOD (file) = A68_FALSE; WRITE_MOOD (file) = A68_TRUE; CHAR_MOOD (file) = A68_TRUE; } if (!CHAR_MOOD (file)) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "binary"); exit_genie (p, A68_RUNTIME_ERROR); } /* Save stack state since formats have frames */ save_frame_pointer = FRAME_POINTER (file); save_stack_pointer = STACK_POINTER (file); FRAME_POINTER (file) = frame_pointer; STACK_POINTER (file) = stack_pointer; /* Process [] SIMPLOUT */ if (BODY (&FORMAT (file)) != NO_NODE) { open_format_frame (p, ref_file, &FORMAT (file), NOT_EMBEDDED_FORMAT, A68_FALSE); } if (elems <= 0) { return; } formats = 0; base_address = DEREF (BYTE_T, &ARRAY (arr)); elem_index = 0; for (k = 0; k < elems; k++) { A68_UNION *z = (A68_UNION *) & (base_address[elem_index]); MOID_T *mode = (MOID_T *) (VALUE (z)); BYTE_T *item = &(base_address[elem_index + A68_UNION_SIZE]); if (mode == MODE (FORMAT)) { /* Forget about eventual active formats and set up new one */ if (formats > 0) { purge_format_write (p, ref_file); } formats++; frame_pointer = FRAME_POINTER (file); stack_pointer = STACK_POINTER (file); open_format_frame (p, ref_file, (A68_FORMAT *) item, NOT_EMBEDDED_FORMAT, A68_TRUE); } else if (mode == MODE (PROC_REF_FILE_VOID)) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_UNDEFINED_TRANSPUT, MODE (PROC_REF_FILE_VOID)); exit_genie (p, A68_RUNTIME_ERROR); } else if (mode == MODE (SOUND)) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_UNDEFINED_TRANSPUT, MODE (SOUND)); exit_genie (p, A68_RUNTIME_ERROR); } else { genie_write_standard_format (p, mode, item, ref_file); } elem_index += MOID_SIZE (MODE (SIMPLOUT)); } /* Empty the format to purge insertions */ purge_format_write (p, ref_file); BODY (&FORMAT (file)) = NO_NODE; /* Dump the buffer */ write_purge_buffer (p, ref_file, FORMATTED_BUFFER); /* Forget about active formats */ frame_pointer = FRAME_POINTER (file); stack_pointer = STACK_POINTER (file); FRAME_POINTER (file) = save_frame_pointer; STACK_POINTER (file) = save_stack_pointer; } /*! \brief give a value error in case a character is not among expected ones \param p position in tree \param m mode of value read or written \param ref_file fat pointer to A68 file \param items expected characters \param ch actual character \return whether character is expected **/ static BOOL_T expect (NODE_T * p, MOID_T * m, A68_REF ref_file, const char *items, char ch) { if (a68g_strchr ((char *) items, ch) == NO_TEXT) { value_error (p, m, ref_file); return (A68_FALSE); } else { return (A68_TRUE); } } /*! \brief read a group of insertions \param p position in tree \param ref_file fat pointer to A68 file **/ void read_insertion (NODE_T * p, A68_REF ref_file) { /* Algol68G does not check whether the insertions are textually there. It just skips them. This because we blank literals in sign moulds before the sign is put, which is non-standard Algol68, but convenient. */ A68_FILE *file = FILE_DEREF (&ref_file); for (; p != NO_NODE; FORWARD (p)) { read_insertion (SUB (p), ref_file); if (IS (p, FORMAT_ITEM_L)) { BOOL_T go_on = (BOOL_T) ! END_OF_FILE (file); while (go_on) { int ch = read_single_char (p, ref_file); go_on = (BOOL_T) ((ch != NEWLINE_CHAR) && (ch != EOF_CHAR) && !END_OF_FILE (file)); } } else if (IS (p, FORMAT_ITEM_P)) { BOOL_T go_on = (BOOL_T) ! END_OF_FILE (file); while (go_on) { int ch = read_single_char (p, ref_file); go_on = (BOOL_T) ((ch != FORMFEED_CHAR) && (ch != EOF_CHAR) && !END_OF_FILE (file)); } } else if (IS (p, FORMAT_ITEM_X) || IS (p, FORMAT_ITEM_Q)) { if (!END_OF_FILE (file)) { (void) read_single_char (p, ref_file); } } else if (IS (p, FORMAT_ITEM_Y)) { PUSH_REF (p, ref_file); PUSH_PRIMITIVE (p, -1, A68_INT); genie_set (p); } else if (IS (p, LITERAL)) { /* Skip characters, but don't check the literal. */ int len = (int) strlen (NSYMBOL (p)); while (len-- && !END_OF_FILE (file)) { (void) read_single_char (p, ref_file); } } else if (IS (p, REPLICATOR)) { int j, k = get_replicator_value (SUB (p), A68_TRUE); if (ATTRIBUTE (SUB_NEXT (p)) != FORMAT_ITEM_K) { for (j = 1; j <= k; j++) { read_insertion (NEXT (p), ref_file); } } else { int pos = get_transput_buffer_index (INPUT_BUFFER); for (j = 1; j < (k - pos); j++) { if (!END_OF_FILE (file)) { (void) read_single_char (p, ref_file); } } } return; /* Don't delete this! */ } } } /*! \brief read string from file according current format \param p position in tree \param m mode being read \param ref_file fat pointer to A68 file **/ static void read_string_pattern (NODE_T * p, MOID_T * m, A68_REF ref_file) { for (; p != NO_NODE; FORWARD (p)) { if (IS (p, INSERTION)) { read_insertion (SUB (p), ref_file); } else if (IS (p, FORMAT_ITEM_A)) { scan_n_chars (p, 1, m, ref_file); } else if (IS (p, FORMAT_ITEM_S)) { add_char_transput_buffer (p, INPUT_BUFFER, BLANK_CHAR); return; } else if (IS (p, REPLICATOR)) { int j, k = get_replicator_value (SUB (p), A68_TRUE); for (j = 1; j <= k; j++) { read_string_pattern (NEXT (p), m, ref_file); } return; } else { read_string_pattern (SUB (p), m, ref_file); } } } /*! \brief traverse choice pattern \param p position in tree \param str string to match \param len length to match \param count counts literals \param matches matching literals \param first_match first matching literal \param full_match whether match is complete (beyond 'len') **/ static void traverse_choice_pattern (NODE_T * p, char *str, int len, int *count, int *matches, int *first_match, BOOL_T * full_match) { for (; p != NO_NODE; FORWARD (p)) { traverse_choice_pattern (SUB (p), str, len, count, matches, first_match, full_match); if (IS (p, LITERAL)) { (*count)++; if (strncmp (NSYMBOL (p), str, (size_t) len) == 0) { (*matches)++; (*full_match) = (BOOL_T) ((*full_match) | (strcmp (NSYMBOL (p), str) == 0)); if (*first_match == 0 && *full_match) { *first_match = *count; } } } } } /*! \brief read appropriate insertion from a choice pattern \param p position in tree \param ref_file fat pointer to A68 file \return length of longest match **/ static int read_choice_pattern (NODE_T * p, A68_REF ref_file) { /* This implementation does not have the RR peculiarity that longest matching literal must be first, in case of non-unique first chars. */ A68_FILE *file = FILE_DEREF (&ref_file); BOOL_T cont = A68_TRUE; int longest_match = 0, longest_match_len = 0; while (cont) { int ch = char_scanner (file); if (!END_OF_FILE (file)) { int len, count = 0, matches = 0, first_match = 0; BOOL_T full_match = A68_FALSE; add_char_transput_buffer (p, INPUT_BUFFER, (char) ch); len = get_transput_buffer_index (INPUT_BUFFER); traverse_choice_pattern (p, get_transput_buffer (INPUT_BUFFER), len, &count, &matches, &first_match, &full_match); if (full_match && matches == 1 && first_match > 0) { return (first_match); } else if (full_match && matches > 1 && first_match > 0) { longest_match = first_match; longest_match_len = len; } else if (matches == 0) { cont = A68_FALSE; } } else { cont = A68_FALSE; } } if (longest_match > 0) { /* Push back look-ahead chars */ if (get_transput_buffer_index (INPUT_BUFFER) > 0) { char *z = get_transput_buffer (INPUT_BUFFER); END_OF_FILE (file) = A68_FALSE; add_string_transput_buffer (p, TRANSPUT_BUFFER (file), &z[longest_match_len]); } return (longest_match); } else { value_error (p, MODE (INT), ref_file); return (0); } } /*! \brief read value according to a general-pattern \param p position in tree \param mode mode of value \param item pointer to value \param ref_file fat pointer to A68 file **/ static void read_number_generic (NODE_T * p, MOID_T * mode, BYTE_T * item, A68_REF ref_file) { A68_REF row; EXECUTE_UNIT (NEXT_SUB (p)); /* RR says to ignore parameters just calculated, so we will */ POP_REF (p, &row); genie_read_standard (p, mode, item, ref_file); } /* INTEGRAL, REAL, COMPLEX and BITS patterns */ /*! \brief read sign-mould according current format \param p position in tree \param m mode of value \param ref_file fat pointer to A68 file \param sign value of sign (-1, 0, 1) **/ static void read_sign_mould (NODE_T * p, MOID_T * m, A68_REF ref_file, int *sign) { for (; p != NO_NODE; FORWARD (p)) { if (IS (p, INSERTION)) { read_insertion (SUB (p), ref_file); } else if (IS (p, REPLICATOR)) { int j, k = get_replicator_value (SUB (p), A68_TRUE); for (j = 1; j <= k; j++) { read_sign_mould (NEXT (p), m, ref_file, sign); } return; /* Leave this! */ } else { switch (ATTRIBUTE (p)) { case FORMAT_ITEM_Z: case FORMAT_ITEM_D: case FORMAT_ITEM_S: case FORMAT_ITEM_PLUS: case FORMAT_ITEM_MINUS: { int ch = read_single_char (p, ref_file); /* When a sign has been read, digits are expected */ if (*sign != 0) { if (expect (p, m, ref_file, INT_DIGITS, (char) ch)) { add_char_transput_buffer (p, INPUT_BUFFER, (char) ch); } else { add_char_transput_buffer (p, INPUT_BUFFER, '0'); } /* When a sign has not been read, a sign is expected. If there is a digit in stead of a sign, the digit is accepted and '+' is assumed; RR demands a space to preceed the digit, Algol68G does not */ } else { if (a68g_strchr (SIGN_DIGITS, ch) != NO_TEXT) { if (ch == '+') { *sign = 1; } else if (ch == '-') { *sign = -1; } else if (ch == BLANK_CHAR) { /* * skip. */ ; } } else if (expect (p, m, ref_file, INT_DIGITS, (char) ch)) { add_char_transput_buffer (p, INPUT_BUFFER, (char) ch); *sign = 1; } } break; } default: { read_sign_mould (SUB (p), m, ref_file, sign); break; } } } } } /*! \brief read mould according current format \param p position in tree \param m mode of value \param ref_file fat pointer to A68 file **/ static void read_integral_mould (NODE_T * p, MOID_T * m, A68_REF ref_file) { for (; p != NO_NODE; FORWARD (p)) { if (IS (p, INSERTION)) { read_insertion (SUB (p), ref_file); } else if (IS (p, REPLICATOR)) { int j, k = get_replicator_value (SUB (p), A68_TRUE); for (j = 1; j <= k; j++) { read_integral_mould (NEXT (p), m, ref_file); } return; /* Leave this! */ } else if (IS (p, FORMAT_ITEM_Z)) { int ch = read_single_char (p, ref_file); const char *digits = (m == MODE (BITS) || m == MODE (LONG_BITS) || m == MODE (LONGLONG_BITS)) ? BITS_DIGITS_BLANK : INT_DIGITS_BLANK; if (expect (p, m, ref_file, digits, (char) ch)) { add_char_transput_buffer (p, INPUT_BUFFER, (char) ((ch == BLANK_CHAR) ? '0' : ch)); } else { add_char_transput_buffer (p, INPUT_BUFFER, '0'); } } else if (IS (p, FORMAT_ITEM_D)) { int ch = read_single_char (p, ref_file); const char *digits = (m == MODE (BITS) || m == MODE (LONG_BITS) || m == MODE (LONGLONG_BITS)) ? BITS_DIGITS : INT_DIGITS; if (expect (p, m, ref_file, digits, (char) ch)) { add_char_transput_buffer (p, INPUT_BUFFER, (char) ch); } else { add_char_transput_buffer (p, INPUT_BUFFER, '0'); } } else if (IS (p, FORMAT_ITEM_S)) { add_char_transput_buffer (p, INPUT_BUFFER, '0'); } else { read_integral_mould (SUB (p), m, ref_file); } } } /*! \brief read mould according current format \param p position in tree \param m mode of value \param item pointer to value \param ref_file fat pointer to A68 file **/ static void read_integral_pattern (NODE_T * p, MOID_T * m, BYTE_T * item, A68_REF ref_file) { NODE_T *q = SUB (p); if (q != NO_NODE && IS (q, SIGN_MOULD)) { int sign = 0; char *z; add_char_transput_buffer (p, INPUT_BUFFER, BLANK_CHAR); read_sign_mould (SUB (q), m, ref_file, &sign); z = get_transput_buffer (INPUT_BUFFER); z[0] = (char) ((sign == -1) ? '-' : '+'); FORWARD (q); } if (q != NO_NODE && IS (q, INTEGRAL_MOULD)) { read_integral_mould (SUB (q), m, ref_file); } genie_string_to_value (p, m, item, ref_file); } /*! \brief read point, exponent or i-frame \param p position in tree \param m mode of value \param ref_file fat pointer to A68 file \param att frame attribute \param item format item \param ch representation of 'item' **/ static void read_pie_frame (NODE_T * p, MOID_T * m, A68_REF ref_file, int att, int item, char ch) { /* Widen ch to a stringlet */ char sym[3]; sym[0] = ch; sym[1] = (char) TO_LOWER (ch); sym[2] = NULL_CHAR; /* Now read the frame */ for (; p != NO_NODE; FORWARD (p)) { if (IS (p, INSERTION)) { read_insertion (p, ref_file); } else if (IS (p, att)) { read_pie_frame (SUB (p), m, ref_file, att, item, ch); return; } else if (IS (p, FORMAT_ITEM_S)) { add_char_transput_buffer (p, INPUT_BUFFER, sym[0]); return; } else if (IS (p, item)) { int ch0 = read_single_char (p, ref_file); if (expect (p, m, ref_file, sym, (char) ch0)) { add_char_transput_buffer (p, INPUT_BUFFER, sym[0]); } else { add_char_transput_buffer (p, INPUT_BUFFER, sym[0]); } } } } /*! \brief read REAL value using real pattern \param p position in tree \param m mode of value \param item pointer to value \param ref_file fat pointer to A68 file **/ static void read_real_pattern (NODE_T * p, MOID_T * m, BYTE_T * item, A68_REF ref_file) { /* Dive into pattern */ NODE_T *q = (IS (p, REAL_PATTERN)) ? SUB (p) : p; /* Dissect pattern */ if (q != NO_NODE && IS (q, SIGN_MOULD)) { int sign = 0; char *z; add_char_transput_buffer (p, INPUT_BUFFER, BLANK_CHAR); read_sign_mould (SUB (q), m, ref_file, &sign); z = get_transput_buffer (INPUT_BUFFER); z[0] = (char) ((sign == -1) ? '-' : '+'); FORWARD (q); } if (q != NO_NODE && IS (q, INTEGRAL_MOULD)) { read_integral_mould (SUB (q), m, ref_file); FORWARD (q); } if (q != NO_NODE && IS (q, FORMAT_POINT_FRAME)) { read_pie_frame (SUB (q), m, ref_file, FORMAT_POINT_FRAME, FORMAT_ITEM_POINT, POINT_CHAR); FORWARD (q); } if (q != NO_NODE && IS (q, INTEGRAL_MOULD)) { read_integral_mould (SUB (q), m, ref_file); FORWARD (q); } if (q != NO_NODE && IS (q, EXPONENT_FRAME)) { read_pie_frame (SUB (q), m, ref_file, FORMAT_E_FRAME, FORMAT_ITEM_E, EXPONENT_CHAR); q = NEXT_SUB (q); if (q != NO_NODE && IS (q, SIGN_MOULD)) { int k, sign = 0; char *z; add_char_transput_buffer (p, INPUT_BUFFER, BLANK_CHAR); k = get_transput_buffer_index (INPUT_BUFFER); read_sign_mould (SUB (q), m, ref_file, &sign); z = get_transput_buffer (INPUT_BUFFER); z[k - 1] = (char) ((sign == -1) ? '-' : '+'); FORWARD (q); } if (q != NO_NODE && IS (q, INTEGRAL_MOULD)) { read_integral_mould (SUB (q), m, ref_file); FORWARD (q); } } genie_string_to_value (p, m, item, ref_file); } /*! \brief read COMPLEX value using complex pattern \param p position in tree \param comp mode of complex value \param m mode of value fields \param re pointer to real part \param im pointer to imaginary part \param ref_file fat pointer to A68 file **/ static void read_complex_pattern (NODE_T * p, MOID_T * comp, MOID_T * m, BYTE_T * re, BYTE_T * im, A68_REF ref_file) { NODE_T *reel, *plus_i_times, *imag; /* Dissect pattern */ reel = SUB (p); plus_i_times = NEXT (reel); imag = NEXT (plus_i_times); /* Read pattern */ read_real_pattern (reel, m, re, ref_file); reset_transput_buffer (INPUT_BUFFER); read_pie_frame (plus_i_times, comp, ref_file, FORMAT_I_FRAME, FORMAT_ITEM_I, 'I'); reset_transput_buffer (INPUT_BUFFER); read_real_pattern (imag, m, im, ref_file); } /*! \brief read BITS value according pattern \param p position in tree \param m mode of value \param item pointer to value \param ref_file fat pointer to A68 file **/ static void read_bits_pattern (NODE_T * p, MOID_T * m, BYTE_T * item, A68_REF ref_file) { int radix; char *z; radix = get_replicator_value (SUB_SUB (p), A68_TRUE); if (radix < 2 || radix > 16) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_INVALID_RADIX, radix); exit_genie (p, A68_RUNTIME_ERROR); } z = get_transput_buffer (INPUT_BUFFER); ASSERT (snprintf (z, (size_t) TRANSPUT_BUFFER_SIZE, "%dr", radix) >= 0); set_transput_buffer_index (INPUT_BUFFER, (int) strlen (z)); read_integral_mould (NEXT_SUB (p), m, ref_file); genie_string_to_value (p, m, item, ref_file); } /*! \brief read object with from file and store \param p position in tree \param mode mode of value \param item pointer to value \param ref_file fat pointer to A68 file **/ static void genie_read_real_format (NODE_T * p, MOID_T * mode, BYTE_T * item, A68_REF ref_file) { if (IS (p, GENERAL_PATTERN) && NEXT_SUB (p) == NO_NODE) { genie_read_standard (p, mode, item, ref_file); } else if (IS (p, GENERAL_PATTERN) && NEXT_SUB (p) != NO_NODE) { read_number_generic (p, mode, item, ref_file); } else if (IS (p, FIXED_C_PATTERN) || IS (p, FLOAT_C_PATTERN) || IS (p, GENERAL_C_PATTERN)) { read_c_pattern (p, mode, item, ref_file); } else if (IS (p, REAL_PATTERN)) { read_real_pattern (p, mode, item, ref_file); } else { pattern_error (p, mode, ATTRIBUTE (p)); } } /*! \brief read object with from file and store \param p position in tree \param mode mode of value \param item pointer to value \param ref_file fat pointer to A68 file **/ static void genie_read_standard_format (NODE_T * p, MOID_T * mode, BYTE_T * item, A68_REF ref_file) { RESET_ERRNO; reset_transput_buffer (INPUT_BUFFER); if (mode == MODE (INT) || mode == MODE (LONG_INT) || mode == MODE (LONGLONG_INT)) { NODE_T *pat = get_next_format_pattern (p, ref_file, WANT_PATTERN); if (IS (pat, GENERAL_PATTERN) && NEXT_SUB (pat) == NO_NODE) { genie_read_standard (pat, mode, item, ref_file); } else if (IS (pat, GENERAL_PATTERN) && NEXT_SUB (pat) != NO_NODE) { read_number_generic (pat, mode, item, ref_file); } else if (IS (pat, INTEGRAL_C_PATTERN)) { read_c_pattern (pat, mode, item, ref_file); } else if (IS (pat, INTEGRAL_PATTERN)) { read_integral_pattern (pat, mode, item, ref_file); } else if (IS (pat, CHOICE_PATTERN)) { int k = read_choice_pattern (pat, ref_file); if (mode == MODE (INT)) { A68_INT *z = (A68_INT *) item; VALUE (z) = k; STATUS (z) = (STATUS_MASK) ((VALUE (z) > 0) ? INIT_MASK : NULL_MASK); } else { MP_T *z = (MP_T *) item; if (k > 0) { (void) int_to_mp (p, z, k, get_mp_digits (mode)); z[0] = (MP_T) INIT_MASK; } else { z[0] = (MP_T) NULL_MASK; } } } else { pattern_error (p, mode, ATTRIBUTE (pat)); } } else if (mode == MODE (REAL) || mode == MODE (LONG_REAL) || mode == MODE (LONGLONG_REAL)) { NODE_T *pat = get_next_format_pattern (p, ref_file, WANT_PATTERN); genie_read_real_format (pat, mode, item, ref_file); } else if (mode == MODE (COMPLEX)) { NODE_T *pat = get_next_format_pattern (p, ref_file, WANT_PATTERN); if (IS (pat, COMPLEX_PATTERN)) { read_complex_pattern (pat, mode, MODE (REAL), item, &item[MOID_SIZE (MODE (REAL))], ref_file); } else { /* Try reading as two REAL values */ genie_read_real_format (pat, MODE (REAL), item, ref_file); genie_read_standard_format (p, MODE (REAL), &item[MOID_SIZE (MODE (REAL))], ref_file); } } else if (mode == MODE (LONG_COMPLEX)) { NODE_T *pat = get_next_format_pattern (p, ref_file, WANT_PATTERN); if (IS (pat, COMPLEX_PATTERN)) { read_complex_pattern (pat, mode, MODE (LONG_REAL), item, &item[MOID_SIZE (MODE (LONG_REAL))], ref_file); } else { /* Try reading as two LONG REAL values */ genie_read_real_format (pat, MODE (LONG_REAL), item, ref_file); genie_read_standard_format (p, MODE (LONG_REAL), &item[MOID_SIZE (MODE (LONG_REAL))], ref_file); } } else if (mode == MODE (LONGLONG_COMPLEX)) { NODE_T *pat = get_next_format_pattern (p, ref_file, WANT_PATTERN); if (IS (pat, COMPLEX_PATTERN)) { read_complex_pattern (pat, mode, MODE (LONGLONG_REAL), item, &item[MOID_SIZE (MODE (LONGLONG_REAL))], ref_file); } else { /* Try reading as two LONG LONG REAL values */ genie_read_real_format (pat, MODE (LONGLONG_REAL), item, ref_file); genie_read_standard_format (p, MODE (LONGLONG_REAL), &item[MOID_SIZE (MODE (LONGLONG_REAL))], ref_file); } } else if (mode == MODE (BOOL)) { NODE_T *pat = get_next_format_pattern (p, ref_file, WANT_PATTERN); if (IS (pat, GENERAL_PATTERN) && NEXT_SUB (pat) == NO_NODE) { genie_read_standard (p, mode, item, ref_file); } else if (IS (pat, BOOLEAN_PATTERN)) { if (NEXT_SUB (pat) == NO_NODE) { genie_read_standard (p, mode, item, ref_file); } else { A68_BOOL *z = (A68_BOOL *) item; int k = read_choice_pattern (pat, ref_file); if (k == 1 || k == 2) { VALUE (z) = (BOOL_T) ((k == 1) ? A68_TRUE : A68_FALSE); STATUS (z) = INIT_MASK; } else { STATUS (z) = NULL_MASK; } } } else { pattern_error (p, mode, ATTRIBUTE (pat)); } } else if (mode == MODE (BITS) || mode == MODE (LONG_BITS) || mode == MODE (LONGLONG_BITS)) { NODE_T *pat = get_next_format_pattern (p, ref_file, WANT_PATTERN); if (IS (pat, GENERAL_PATTERN) && NEXT_SUB (pat) == NO_NODE) { genie_read_standard (p, mode, item, ref_file); } else if (IS (pat, BITS_PATTERN)) { read_bits_pattern (pat, mode, item, ref_file); } else if (IS (pat, BITS_C_PATTERN)) { read_c_pattern (pat, mode, item, ref_file); } else { pattern_error (p, mode, ATTRIBUTE (pat)); } } else if (mode == MODE (CHAR)) { NODE_T *pat = get_next_format_pattern (p, ref_file, WANT_PATTERN); if (IS (pat, GENERAL_PATTERN) && NEXT_SUB (pat) == NO_NODE) { genie_read_standard (p, mode, item, ref_file); } else if (IS (pat, STRING_PATTERN)) { read_string_pattern (pat, MODE (CHAR), ref_file); genie_string_to_value (p, mode, item, ref_file); } else if (IS (pat, CHAR_C_PATTERN)) { read_c_pattern (pat, mode, item, ref_file); } else { pattern_error (p, mode, ATTRIBUTE (pat)); } } else if (mode == MODE (ROW_CHAR) || mode == MODE (STRING)) { /* Handle these separately instead of reading [] CHAR */ NODE_T *pat = get_next_format_pattern (p, ref_file, WANT_PATTERN); if (IS (pat, GENERAL_PATTERN) && NEXT_SUB (pat) == NO_NODE) { genie_read_standard (p, mode, item, ref_file); } else if (IS (pat, STRING_PATTERN)) { read_string_pattern (pat, mode, ref_file); genie_string_to_value (p, mode, item, ref_file); } else if (IS (pat, STRING_C_PATTERN)) { read_c_pattern (pat, mode, item, ref_file); } else { pattern_error (p, mode, ATTRIBUTE (pat)); } } else if (IS (mode, UNION_SYMBOL)) { A68_UNION *z = (A68_UNION *) item; genie_read_standard_format (p, (MOID_T *) (VALUE (z)), &item[A68_UNION_SIZE], ref_file); } else if (IS (mode, STRUCT_SYMBOL)) { PACK_T *q = PACK (mode); for (; q != NO_PACK; FORWARD (q)) { BYTE_T *elem = &item[OFFSET (q)]; genie_read_standard_format (p, MOID (q), elem, ref_file); } } else if (IS (mode, ROW_SYMBOL) || IS (mode, FLEX_SYMBOL)) { MOID_T *deflexed = DEFLEX (mode); A68_ARRAY *arr; A68_TUPLE *tup; CHECK_INIT (p, INITIALISED ((A68_REF *) item), MODE (ROWS)); GET_DESCRIPTOR (arr, tup, (A68_REF *) item); if (get_row_size (tup, DIM (arr)) > 0) { BYTE_T *base_addr = DEREF (BYTE_T, &ARRAY (arr)); BOOL_T done = A68_FALSE; initialise_internal_index (tup, DIM (arr)); while (!done) { ADDR_T a68g_index = calculate_internal_index (tup, DIM (arr)); ADDR_T elem_addr = ROW_ELEMENT (arr, a68g_index); BYTE_T *elem = &base_addr[elem_addr]; genie_read_standard_format (p, SUB (deflexed), elem, ref_file); done = increment_internal_index (tup, DIM (arr)); } } } if (errno != 0) { transput_error (p, ref_file, mode); } } /*! \brief at end of read purge all insertions \param p position in tree \param ref_file fat pointer to A68 file **/ static void purge_format_read (NODE_T * p, A68_REF ref_file) { BOOL_T go_on; do { A68_FILE *file; NODE_T *dollar, *pat; A68_FORMAT *old_fmt; /* while (get_next_format_pattern (p, ref_file, SKIP_PATTERN) != NO_NODE) { ; } */ while ((pat = get_next_format_pattern (p, ref_file, SKIP_PATTERN)) != NO_NODE) { format_error (p, ref_file, ERROR_FORMAT_PICTURES); } file = FILE_DEREF (&ref_file); dollar = SUB (BODY (&FORMAT (file))); old_fmt = (A68_FORMAT *) FRAME_LOCAL (frame_pointer, OFFSET (TAX (dollar))); go_on = (BOOL_T) ! IS_NIL_FORMAT (old_fmt); if (go_on) { /* Pop embedded format and proceed */ (void) end_of_format (p, ref_file); } } while (go_on); } /*! \brief PROC ([] SIMPLIN) VOID read f \param p position in tree **/ void genie_read_format (NODE_T * p) { A68_REF row; POP_REF (p, &row); genie_stand_in (p); PUSH_REF (p, row); genie_read_file_format (p); } /*! \brief PROC (REF FILE, [] SIMPLIN) VOID get f \param p position in tree **/ void genie_read_file_format (NODE_T * p) { A68_REF ref_file; A68_FILE *file; A68_REF row; A68_ARRAY *arr; A68_TUPLE *tup; BYTE_T *base_address; int elems, k, elem_index, formats; ADDR_T save_frame_pointer, save_stack_pointer; POP_REF (p, &row); CHECK_REF (p, row, MODE (ROW_SIMPLIN)); GET_DESCRIPTOR (arr, tup, &row); elems = ROW_SIZE (tup); POP_REF (p, &ref_file); CHECK_REF (p, ref_file, MODE (REF_FILE)); file = FILE_DEREF (&ref_file); CHECK_INIT (p, INITIALISED (file), MODE (FILE)); if (!OPENED (file)) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FILE_NOT_OPEN); exit_genie (p, A68_RUNTIME_ERROR); } if (DRAW_MOOD (file)) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "draw"); exit_genie (p, A68_RUNTIME_ERROR); } if (WRITE_MOOD (file)) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "write"); exit_genie (p, A68_RUNTIME_ERROR); } if (!GET (&CHANNEL (file))) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_CHANNEL_DOES_NOT_ALLOW, "getting"); exit_genie (p, A68_RUNTIME_ERROR); } if (!READ_MOOD (file) && !WRITE_MOOD (file)) { if (IS_NIL (STRING (file))) { if ((FD (file) = open_physical_file (p, ref_file, A68_READ_ACCESS, 0)) == A68_NO_FILENO) { open_error (p, ref_file, "getting"); } } else { FD (file) = open_physical_file (p, ref_file, A68_READ_ACCESS, 0); } DRAW_MOOD (file) = A68_FALSE; READ_MOOD (file) = A68_TRUE; WRITE_MOOD (file) = A68_FALSE; CHAR_MOOD (file) = A68_TRUE; } if (!CHAR_MOOD (file)) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "binary"); exit_genie (p, A68_RUNTIME_ERROR); } /* Save stack state since formats have frames */ save_frame_pointer = FRAME_POINTER (file); save_stack_pointer = STACK_POINTER (file); FRAME_POINTER (file) = frame_pointer; STACK_POINTER (file) = stack_pointer; /* Process [] SIMPLIN */ if (BODY (&FORMAT (file)) != NO_NODE) { open_format_frame (p, ref_file, &FORMAT (file), NOT_EMBEDDED_FORMAT, A68_FALSE); } if (elems <= 0) { return; } formats = 0; base_address = DEREF (BYTE_T, &ARRAY (arr)); elem_index = 0; for (k = 0; k < elems; k++) { A68_UNION *z = (A68_UNION *) & (base_address[elem_index]); MOID_T *mode = (MOID_T *) (VALUE (z)); BYTE_T *item = (BYTE_T *) & (base_address[elem_index + A68_UNION_SIZE]); if (mode == MODE (FORMAT)) { /* Forget about eventual active formats and set up new one */ if (formats > 0) { purge_format_read (p, ref_file); } formats++; frame_pointer = FRAME_POINTER (file); stack_pointer = STACK_POINTER (file); open_format_frame (p, ref_file, (A68_FORMAT *) item, NOT_EMBEDDED_FORMAT, A68_TRUE); } else if (mode == MODE (PROC_REF_FILE_VOID)) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_UNDEFINED_TRANSPUT, MODE (PROC_REF_FILE_VOID)); exit_genie (p, A68_RUNTIME_ERROR); } else if (mode == MODE (REF_SOUND)) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_UNDEFINED_TRANSPUT, MODE (REF_SOUND)); exit_genie (p, A68_RUNTIME_ERROR); } else { CHECK_REF (p, *(A68_REF *) item, mode); genie_read_standard_format (p, SUB (mode), ADDRESS ((A68_REF *) item), ref_file); } elem_index += MOID_SIZE (MODE (SIMPLIN)); } /* Empty the format to purge insertions */ purge_format_read (p, ref_file); BODY (&FORMAT (file)) = NO_NODE; /* Forget about active formats */ frame_pointer = FRAME_POINTER (file); stack_pointer = STACK_POINTER (file); FRAME_POINTER (file) = save_frame_pointer; STACK_POINTER (file) = save_stack_pointer; } /*********************/ /* Numerical library */ /*********************/ /* Note that the interpreter has its own routines for these simple tasks that often are optimised to work with values pushed on the stack, and that perform runtime checks. These functions are not mangled to fit below routines. */ /*! \brief sqrt (x^2 + y^2) that does not needlessly overflow \param x x \param y y \return same **/ double a68g_hypot (double x, double y) { double xabs = ABS (x), yabs = ABS (y); double min, max; if (xabs < yabs) { min = xabs; max = yabs; } else { min = yabs; max = xabs; } if (min == 0.0) { return (max); } else { double u = min / max; return (max * sqrt (1.0 + u * u)); } } /*! \brief log (1 + x) with anti-cancellation for IEEE 754 \param x x \return same **/ double a68g_log1p (double x) { volatile double y; y = 1 + x; return log (y) - ((y - 1) - x) / y; /* cancel errors with IEEE arithmetic */ } /*! \brief OP ROUND = (REAL) INT **/ int a68g_round (double x) { if (x >= 0) { return ((int) (x + 0.5)); } else { return ((int) (x - 0.5)); } } /*! PROC exp = (REAL) REAL **/ double a68g_exp (double x) { if (x < log (DBL_MIN)) { return (0.0); } else { return (exp (x)); } } /*! \brief PROC atan2 (REAL, REAL) REAL **/ double a68g_atan2 (double x, double y) { if (x == 0.0 && y == 0.0) { errno = EDOM; return (0.0); } else { BOOL_T flip = (BOOL_T) (y < 0.0); double z; y = ABS (y); if (x == 0.0) { z = A68_PI / 2.0; } else { BOOL_T flop = (BOOL_T) (x < 0.0); x = ABS (x); z = atan (y / x); if (flop) { z = A68_PI - z; } } if (flip) { z = -z; } return (z); } } /*! \brief PROC asinh = (REAL) REAL **/ double a68g_asinh (double x) { double a = ABS (x), s = (x < 0.0 ? -1.0 : 1.0); if (a > 1.0 / sqrt (DBL_EPSILON)) { return (s * (log (a) + log (2.0))); } else if (a > 2.0) { return (s * log (2.0 * a + 1.0 / (a + sqrt (a * a + 1.0)))); } else if (a > sqrt (DBL_EPSILON)) { double a2 = a * a; return (s * a68g_log1p (a + a2 / (1.0 + sqrt (1.0 + a2)))); } else { return (x); } } /*! \brief PROC acosh = (REAL) REAL **/ double a68g_acosh (double x) { if (x > 1.0 / sqrt (DBL_EPSILON)) { return (log (x) + log (2.0)); } else if (x > 2.0) { return (log (2.0 * x - 1.0 / (sqrt (x * x - 1.0) + x))); } else if (x > 1.0) { double t = x - 1.0; return (a68g_log1p (t + sqrt (2.0 * t + t * t))); } else if (x == 1.0) { return (0.0); } else { errno = EDOM; return (0.0); } } /*! \brief PROC atanh = (REAL) REAL **/ double a68g_atanh (double x) { double a = ABS (x); double s = (double) (x < 0 ? -1 : 1); if (a >= 1.0) { errno = EDOM; return (0.0); } else if (a >= 0.5) { return (s * 0.5 * a68g_log1p (2 * a / (1.0 - a))); } else if (a > DBL_EPSILON) { return (s * 0.5 * a68g_log1p (2.0 * a + 2.0 * a * a / (1.0 - a))); } else { return (x); } } /*! \brief OP ** = (REAL, REAL) REAL **/ double a68g_pow_real (double x, double y) { return (exp (y * log (x))); } /*! \brief OP ** = (REAL, INT) REAL **/ double a68g_pow_real_int (double x, int n) { switch (n) { case 2: return (x * x); case 3: return (x * x * x); case 4: {double y = x * x; return (y * y);} case 5: {double y = x * x; return (x * y * y);} case 6: {double y = x * x * x; return (y * y);} default: { int expo = 1, m = (int) labs (n); BOOL_T cont = (m > 0); double mult = x, prod = 1; while (cont) { if ((m & expo) != 0) { prod *= mult; } expo *= 2; cont = (expo <= m); if (cont) { mult *= mult; } } return (n < 0 ? 1 / prod : prod); } } } /*! \brief OP / = (COMPLEX, COMPLEX) COMPLEX **/ void a68g_div_complex (A68_REAL * z, A68_REAL * x, A68_REAL * y) { if (RE (y) == 0 && IM (y) == 0) { RE (z) = 0.0; IM (z) = 0.0; errno = EDOM; } else if (fabs (RE (y)) >= fabs (IM (y))) { double r = IM (y) / RE (y), den = RE (y) + r * IM (y); STATUS_RE (z) = INIT_MASK; STATUS_IM (z) = INIT_MASK; RE (z) = (RE (x) + r * IM (x)) / den; IM (z) = (IM (x) - r * RE (x)) / den; } else { double r = RE (y) / IM (y), den = IM (y) + r * RE (y); STATUS_RE (z) = INIT_MASK; STATUS_IM (z) = INIT_MASK; RE (z) = (RE (x) * r + IM (x)) / den; IM (z) = (IM (x) * r - RE (x)) / den; } } /*! \brief PROC csqrt = (COMPLEX) COMPLEX **/ void a68g_sqrt_complex (A68_REAL * z, A68_REAL * x) { STATUS_RE (z) = INIT_MASK; STATUS_IM (z) = INIT_MASK; if (RE (x) == 0.0 && IM (x) == 0.0) { RE (z) = 0.0; IM (z) = 0.0; } else { double re = fabs (RE (x)), im = fabs (IM (x)), w; if (re >= im) { double t = im / re; w = sqrt (re) * sqrt (0.5 * (1.0 + sqrt (1.0 + t * t))); } else { double t = re / im; w = sqrt (im) * sqrt (0.5 * (t + sqrt (1.0 + t * t))); } if (RE (x) >= 0.0) { RE (z) = w; IM (z) = IM (x) / (2.0 * w); } else { double ai = IM (x); double vi = (ai >= 0.0 ? w : -w); RE (z) = ai / (2.0 * vi); IM (z) = vi; } } } /*! \brief PROC cexp = (COMPLEX) COMPLEX **/ void a68g_exp_complex (A68_REAL * z, A68_REAL * x) { double r = exp (RE (x)); STATUS_RE (z) = INIT_MASK; STATUS_IM (z) = INIT_MASK; RE (z) = r * cos (IM (x)); IM (z) = r * sin (IM (x)); } /*! \brief PROC cln = (COMPLEX) COMPLEX **/ void a68g_ln_complex (A68_REAL * z, A68_REAL * x) { STATUS_RE (z) = INIT_MASK; STATUS_IM (z) = INIT_MASK; RE (z) = log (a68g_abs_complex (x)); IM (z) = a68g_arg_complex (x); } /*! \brief PROC csin = (COMPLEX) COMPLEX **/ void a68g_sin_complex (A68_REAL * z, A68_REAL * x) { STATUS_RE (z) = INIT_MASK; STATUS_IM (z) = INIT_MASK; if (IM (x) == 0) { RE (z) = sin (RE (x)); IM (z) = 0; } else { RE (z) = sin (RE (x)) * cosh (IM (x)); IM (z) = cos (RE (x)) * sinh (IM (x)); } } /*! \brief PROC ccos = (COMPLEX) COMPLEX **/ void a68g_cos_complex (A68_REAL * z, A68_REAL * x) { STATUS_RE (z) = INIT_MASK; STATUS_IM (z) = INIT_MASK; if (IM (x) == 0) { RE (z) = cos (RE (x)); IM (z) = 0; } else { RE (z) = cos (RE (x)) * cosh (IM (x)); IM (z) = sin (RE (x)) * sinh (-IM (x)); } } /*! \brief PROC ctan = (COMPLEX) COMPLEX **/ void a68g_tan_complex (A68_REAL * z, A68_REAL * x) { A68_COMPLEX u, v; STATUS_RE (u) = INIT_MASK; STATUS_IM (u) = INIT_MASK; STATUS_RE (v) = INIT_MASK; STATUS_IM (v) = INIT_MASK; if (IM (x) == 0) { RE (u) = sin (RE (x)); IM (u) = 0; RE (v) = cos (RE (x)); IM (v) = 0; } else { RE (u) = sin (RE (x)) * cosh (IM (x)); IM (u) = cos (RE (x)) * sinh (IM (x)); RE (v) = cos (RE (x)) * cosh (IM (x)); IM (v) = sin (RE (x)) * sinh (-IM (x)); } a68g_div_complex (z, u, v); } /*! \brief PROC casin = (COMPLEX) COMPLEX **/ void a68g_arcsin_complex (A68_REAL * z, A68_REAL * x) { double r = RE (x), i = IM (x); if (i == 0) { RE (z) = asin (r); IM (z) = 0; } else { double u = a68g_hypot (r + 1, i), v = a68g_hypot (r - 1, i); double a = 0.5 * (u + v), b = 0.5 * (u - v); RE (z) = asin (b); IM (z) = log (a + sqrt (a * a - 1)); } } /*! \brief PROC cacos = (COMPLEX) COMPLEX **/ void a68g_arccos_complex (A68_REAL * z, A68_REAL * x) { double r = RE (x), i = IM (x); if (i == 0) { RE (z) = acos (r); IM (z) = 0; } else { double u = a68g_hypot (r + 1, i), v = a68g_hypot (r - 1, i); double a = 0.5 * (u + v), b = 0.5 * (u - v); RE (z) = acos (b); IM (z) = -log (a + sqrt (a * a - 1)); } } /*! \brief PROC catan = (COMPLEX) COMPLEX **/ void a68g_arctan_complex (A68_REAL * z, A68_REAL * x) { double r = RE (x), i = IM (x); if (i == 0) { RE (z) = atan (r); IM (z) = 0; } else { double a = a68g_hypot (r, i + 1), b = a68g_hypot (r, i - 1); RE (z) = 0.5 * atan (2 * r / (1 - r * r - i * i)); IM (z) = 0.5 * log (a / b); } } /* Operators for ROWS */ /*! \brief OP ELEMS = (ROWS) INT \param p position in syntax tree **/ void genie_monad_elems (NODE_T * p) { A68_REF z; A68_ARRAY *x; A68_TUPLE *t; POP_REF (p, &z); /* Decrease pointer since a UNION is on the stack */ DECREMENT_STACK_POINTER (p, A68_UNION_SIZE); CHECK_REF (p, z, MODE (ROWS)); GET_DESCRIPTOR (x, t, &z); PUSH_PRIMITIVE (p, get_row_size (t, DIM (x)), A68_INT); } /*! \brief OP LWB = (ROWS) INT \param p position in syntax tree **/ void genie_monad_lwb (NODE_T * p) { A68_REF z; A68_ARRAY *x; A68_TUPLE *t; POP_REF (p, &z); /* Decrease pointer since a UNION is on the stack */ DECREMENT_STACK_POINTER (p, A68_UNION_SIZE); CHECK_REF (p, z, MODE (ROWS)); GET_DESCRIPTOR (x, t, &z); PUSH_PRIMITIVE (p, LWB (t), A68_INT); } /*! \brief OP UPB = (ROWS) INT \param p position in syntax tree **/ void genie_monad_upb (NODE_T * p) { A68_REF z; A68_ARRAY *x; A68_TUPLE *t; POP_REF (p, &z); /* Decrease pointer since a UNION is on the stack */ DECREMENT_STACK_POINTER (p, A68_UNION_SIZE); CHECK_REF (p, z, MODE (ROWS)); GET_DESCRIPTOR (x, t, &z); PUSH_PRIMITIVE (p, UPB (t), A68_INT); } /*! \brief OP ELEMS = (INT, ROWS) INT \param p position in syntax tree **/ void genie_dyad_elems (NODE_T * p) { A68_REF z; A68_ARRAY *x; A68_TUPLE *t, *u; A68_INT k; POP_REF (p, &z); /* Decrease pointer since a UNION is on the stack */ DECREMENT_STACK_POINTER (p, A68_UNION_SIZE); CHECK_REF (p, z, MODE (ROWS)); POP_OBJECT (p, &k, A68_INT); GET_DESCRIPTOR (x, t, &z); if (VALUE (&k) < 1 || VALUE (&k) > DIM (x)) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_INVALID_DIMENSION, (int) VALUE (&k)); exit_genie (p, A68_RUNTIME_ERROR); } u = &(t[VALUE (&k) - 1]); PUSH_PRIMITIVE (p, ROW_SIZE (u), A68_INT); } /*! \brief OP LWB = (INT, ROWS) INT \param p position in syntax tree **/ void genie_dyad_lwb (NODE_T * p) { A68_REF z; A68_ARRAY *x; A68_TUPLE *t; A68_INT k; POP_REF (p, &z); /* Decrease pointer since a UNION is on the stack */ DECREMENT_STACK_POINTER (p, A68_UNION_SIZE); CHECK_REF (p, z, MODE (ROWS)); POP_OBJECT (p, &k, A68_INT); GET_DESCRIPTOR (x, t, &z); if (VALUE (&k) < 1 || VALUE (&k) > DIM (x)) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_INVALID_DIMENSION, (int) VALUE (&k)); exit_genie (p, A68_RUNTIME_ERROR); } PUSH_PRIMITIVE (p, LWB (&(t[VALUE (&k) - 1])), A68_INT); } /*! \brief OP UPB = (INT, ROWS) INT \param p position in syntax tree **/ void genie_dyad_upb (NODE_T * p) { A68_REF z; A68_ARRAY *x; A68_TUPLE *t; A68_INT k; POP_REF (p, &z); /* Decrease pointer since a UNION is on the stack */ DECREMENT_STACK_POINTER (p, A68_UNION_SIZE); CHECK_REF (p, z, MODE (ROWS)); POP_OBJECT (p, &k, A68_INT); GET_DESCRIPTOR (x, t, &z); if (VALUE (&k) < 1 || VALUE (&k) > DIM (x)) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_INVALID_DIMENSION, (int) VALUE (&k)); exit_genie (p, A68_RUNTIME_ERROR); } PUSH_PRIMITIVE (p, UPB (&(t[VALUE (&k) - 1])), A68_INT); } /* Implements SOUND values. */ #define MAX_BYTES 4 #define A68_LITTLE_ENDIAN A68_TRUE #define A68_BIG_ENDIAN A68_FALSE /* From public Microsoft RIFF documentation */ #define WAVE_FORMAT_UNKNOWN (0x0000) #define WAVE_FORMAT_PCM (0x0001) #define WAVE_FORMAT_ADPCM (0x0002) #define WAVE_FORMAT_IEEE_FLOAT (0x0003) #define WAVE_FORMAT_IBM_FORMAT_CVSD (0x0005) #define WAVE_FORMAT_ALAW (0x0006) #define WAVE_FORMAT_MULAW (0x0007) #define WAVE_FORMAT_OKI_ADPCM (0x0010) #define WAVE_FORMAT_DVI_ADPCM (0x0011) #define WAVE_FORMAT_MEDIASPACE_ADPCM (0x0012) #define WAVE_FORMAT_SIERRA_ADPCM (0x0013) #define WAVE_FORMAT_G723_ADPCM (0X0014) #define WAVE_FORMAT_DIGISTD (0x0015) #define WAVE_FORMAT_DIGIFIX (0x0016) #define WAVE_FORMAT_YAMAHA_ADPCM (0x0020) #define WAVE_FORMAT_SONARC (0x0021) #define WAVE_FORMAT_DSPGROUP_TRUESPEECH (0x0022) #define WAVE_FORMAT_ECHOSCI1 (0x0023) #define WAVE_FORMAT_AUDIOFILE_AF36 (0x0024) #define WAVE_FORMAT_APTX (0x0025) #define WAVE_FORMAT_AUDIOFILE_AF10 (0x0026) #define WAVE_FORMAT_DOLBY_AC2 (0x0030) #define WAVE_FORMAT_GSM610 (0x0031) #define WAVE_FORMAT_ANTEX_ADPCME (0x0033) #define WAVE_FORMAT_CONTROL_RES_VQLPC (0x0034) #define WAVE_FORMAT_DIGIREAL (0x0035) #define WAVE_FORMAT_DIGIADPCM (0x0036) #define WAVE_FORMAT_CONTROL_RES_CR10 (0x0037) #define WAVE_FORMAT_NMS_VBXADPCM (0x0038) #define WAVE_FORMAT_ROCKWELL_ADPCM (0x003b) #define WAVE_FORMAT_ROCKWELL_DIGITALK (0x003c) #define WAVE_FORMAT_G721_ADPCM (0x0040) #define WAVE_FORMAT_G728_CELP (0x0041) #define WAVE_FORMAT_MPEG (0x0050) #define WAVE_FORMAT_MPEGLAYER3 (0x0055) #define WAVE_FORMAT_G726_ADPCM (0x0064) #define WAVE_FORMAT_G722_ADPCM (0x0065) #define WAVE_FORMAT_IBM_FORMAT_MULAW (0x0101) #define WAVE_FORMAT_IBM_FORMAT_ALAW (0x0102) #define WAVE_FORMAT_IBM_FORMAT_ADPCM (0x0103) #define WAVE_FORMAT_CREATIVE_ADPCM (0x0200) #define WAVE_FORMAT_FM_TOWNS_SND (0x0300) #define WAVE_FORMAT_OLIGSM (0x1000) #define WAVE_FORMAT_OLIADPCM (0x1001) #define WAVE_FORMAT_OLICELP (0x1002) #define WAVE_FORMAT_OLISBC (0x1003) #define WAVE_FORMAT_OLIOPR (0x1004) #define WAVE_FORMAT_EXTENSIBLE (0xfffe) static unsigned pow256[] = { 1, 256, 65536, 16777216 }; /*! \brief test bits per sample \param p position in tree \param bps bits per second **/ static void test_bits_per_sample (NODE_T * p, unsigned bps) { if (bps <= 0 || bps > 24) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_SOUND_INTERNAL, MODE (SOUND), "unsupported number of bits per sample"); exit_genie (p, A68_RUNTIME_ERROR); } } /*! \brief code string into big-endian unsigned \param p position in tree \param s string to code \param n chars to code **/ static unsigned code_string (NODE_T * p, char *s, int n) { unsigned v; int k, m; if (n > MAX_BYTES) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_SOUND_INTERNAL, MODE (SOUND), "too long word length"); exit_genie (p, A68_RUNTIME_ERROR); } for (k = 0, m = n - 1, v = 0; k < n; k++, m--) { v += ((unsigned) s[k]) * pow256[m]; } return (v); } /*! \brief code unsigned into string \param p position in tree \param n value to code **/ static char *code_unsigned (NODE_T * p, unsigned n) { static char text[MAX_BYTES + 1]; int k; (void) p; for (k = 0; k < MAX_BYTES; k++) { char ch = (char) (n % 0x100); if (ch == NULL_CHAR) { ch = BLANK_CHAR; } else if (ch < BLANK_CHAR) { ch = '?'; } text[MAX_BYTES - k - 1] = ch; n >>= 8; } text[MAX_BYTES] = NULL_CHAR; return (text); } /*! \brief WAVE format category \param n category number **/ static char *format_category (unsigned n) { switch (n) { case WAVE_FORMAT_UNKNOWN: { return ("WAVE_FORMAT_UNKNOWN"); } case WAVE_FORMAT_PCM: { return ("WAVE_FORMAT_PCM "); } case WAVE_FORMAT_ADPCM: { return ("WAVE_FORMAT_ADPCM"); } case WAVE_FORMAT_IEEE_FLOAT: { return ("WAVE_FORMAT_IEEE_FLOAT"); } case WAVE_FORMAT_IBM_FORMAT_CVSD: { return ("WAVE_FORMAT_IBM_FORMAT_CVSD"); } case WAVE_FORMAT_ALAW: { return ("WAVE_FORMAT_ALAW"); } case WAVE_FORMAT_MULAW: { return ("WAVE_FORMAT_MULAW"); } case WAVE_FORMAT_OKI_ADPCM: { return ("WAVE_FORMAT_OKI_ADPCM"); } case WAVE_FORMAT_DVI_ADPCM: { return ("WAVE_FORMAT_DVI_ADPCM"); } case WAVE_FORMAT_MEDIASPACE_ADPCM: { return ("WAVE_FORMAT_MEDIASPACE_ADPCM"); } case WAVE_FORMAT_SIERRA_ADPCM: { return ("WAVE_FORMAT_SIERRA_ADPCM"); } case WAVE_FORMAT_G723_ADPCM: { return ("WAVE_FORMAT_G723_ADPCM"); } case WAVE_FORMAT_DIGISTD: { return ("WAVE_FORMAT_DIGISTD"); } case WAVE_FORMAT_DIGIFIX: { return ("WAVE_FORMAT_DIGIFIX"); } case WAVE_FORMAT_YAMAHA_ADPCM: { return ("WAVE_FORMAT_YAMAHA_ADPCM"); } case WAVE_FORMAT_SONARC: { return ("WAVE_FORMAT_SONARC"); } case WAVE_FORMAT_DSPGROUP_TRUESPEECH: { return ("WAVE_FORMAT_DSPGROUP_TRUESPEECH"); } case WAVE_FORMAT_ECHOSCI1: { return ("WAVE_FORMAT_ECHOSCI1"); } case WAVE_FORMAT_AUDIOFILE_AF36: { return ("WAVE_FORMAT_AUDIOFILE_AF36"); } case WAVE_FORMAT_APTX: { return ("WAVE_FORMAT_APTX"); } case WAVE_FORMAT_AUDIOFILE_AF10: { return ("WAVE_FORMAT_AUDIOFILE_AF10"); } case WAVE_FORMAT_DOLBY_AC2: { return ("WAVE_FORMAT_DOLBY_AC2"); } case WAVE_FORMAT_GSM610: { return ("WAVE_FORMAT_GSM610 "); } case WAVE_FORMAT_ANTEX_ADPCME: { return ("WAVE_FORMAT_ANTEX_ADPCME"); } case WAVE_FORMAT_CONTROL_RES_VQLPC: { return ("WAVE_FORMAT_CONTROL_RES_VQLPC"); } case WAVE_FORMAT_DIGIREAL: { return ("WAVE_FORMAT_DIGIREAL"); } case WAVE_FORMAT_DIGIADPCM: { return ("WAVE_FORMAT_DIGIADPCM"); } case WAVE_FORMAT_CONTROL_RES_CR10: { return ("WAVE_FORMAT_CONTROL_RES_CR10"); } case WAVE_FORMAT_NMS_VBXADPCM: { return ("WAVE_FORMAT_NMS_VBXADPCM"); } case WAVE_FORMAT_ROCKWELL_ADPCM: { return ("WAVE_FORMAT_ROCKWELL_ADPCM"); } case WAVE_FORMAT_ROCKWELL_DIGITALK: { return ("WAVE_FORMAT_ROCKWELL_DIGITALK"); } case WAVE_FORMAT_G721_ADPCM: { return ("WAVE_FORMAT_G721_ADPCM"); } case WAVE_FORMAT_G728_CELP: { return ("WAVE_FORMAT_G728_CELP"); } case WAVE_FORMAT_MPEG: { return ("WAVE_FORMAT_MPEG"); } case WAVE_FORMAT_MPEGLAYER3: { return ("WAVE_FORMAT_MPEGLAYER3"); } case WAVE_FORMAT_G726_ADPCM: { return ("WAVE_FORMAT_G726_ADPCM"); } case WAVE_FORMAT_G722_ADPCM: { return ("WAVE_FORMAT_G722_ADPCM"); } case WAVE_FORMAT_IBM_FORMAT_MULAW: { return ("WAVE_FORMAT_IBM_FORMAT_MULAW"); } case WAVE_FORMAT_IBM_FORMAT_ALAW: { return ("WAVE_FORMAT_IBM_FORMAT_ALAW"); } case WAVE_FORMAT_IBM_FORMAT_ADPCM: { return ("WAVE_FORMAT_IBM_FORMAT_ADPCM"); } case WAVE_FORMAT_CREATIVE_ADPCM: { return ("WAVE_FORMAT_CREATIVE_ADPCM"); } case WAVE_FORMAT_FM_TOWNS_SND: { return ("WAVE_FORMAT_FM_TOWNS_SND"); } case WAVE_FORMAT_OLIGSM: { return ("WAVE_FORMAT_OLIGSM"); } case WAVE_FORMAT_OLIADPCM: { return ("WAVE_FORMAT_OLIADPCM"); } case WAVE_FORMAT_OLICELP: { return ("WAVE_FORMAT_OLICELP"); } case WAVE_FORMAT_OLISBC: { return ("WAVE_FORMAT_OLISBC"); } case WAVE_FORMAT_OLIOPR: { return ("WAVE_FORMAT_OLIOPR"); } case WAVE_FORMAT_EXTENSIBLE: { return ("WAVE_FORMAT_EXTENSIBLE"); } default: { return ("other"); } } } /*! \brief read RIFF item \param p position in tree \param fd file number \param n word length \param little whether little-endian **/ static unsigned read_riff_item (NODE_T * p, FILE_T fd, int n, BOOL_T little) { unsigned v, z; int k, m, r; if (n > MAX_BYTES) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_SOUND_INTERNAL, MODE (SOUND), "too long word length"); exit_genie (p, A68_RUNTIME_ERROR); } if (little) { for (k = 0, m = 0, v = 0; k < n; k++, m++) { z = 0; r = (int) io_read (fd, &z, (size_t) 1); if (r != 1 || errno != 0) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_SOUND_INTERNAL, MODE (SOUND), "error while reading file"); exit_genie (p, A68_RUNTIME_ERROR); } v += z * pow256[m]; } } else { for (k = 0, m = n - 1, v = 0; k < n; k++, m--) { z = 0; r = (int) io_read (fd, &z, (size_t) 1); if (r != 1 || errno != 0) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_SOUND_INTERNAL, MODE (SOUND), "error while reading file"); exit_genie (p, A68_RUNTIME_ERROR); } v += z * pow256[m]; } } return (v); } /*! \brief read sound from file \param p position in tree \param ref_file pointer to file \param w sound object **/ void read_sound (NODE_T * p, A68_REF ref_file, A68_SOUND * w) { A68_FILE *f = FILE_DEREF (&ref_file); int r; unsigned fmt_cat; unsigned blockalign, byterate, chunksize, subchunk2size, z; BOOL_T data_read = A68_FALSE; if (read_riff_item (p, FD (f), 4, A68_BIG_ENDIAN) != code_string (p, "RIFF", 4)) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_SOUND_INTERNAL, MODE (SOUND), "file format is not RIFF"); exit_genie (p, A68_RUNTIME_ERROR); } chunksize = read_riff_item (p, FD (f), 4, A68_LITTLE_ENDIAN); if ((z = read_riff_item (p, FD (f), 4, A68_BIG_ENDIAN)) != code_string (p, "WAVE", 4)) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_SOUND_INTERNAL_STRING, MODE (SOUND), "file format is not \"WAVE\" but", code_unsigned (p, z)); exit_genie (p, A68_RUNTIME_ERROR); } /* Now read chunks */ while (data_read == A68_FALSE) { z = read_riff_item (p, FD (f), 4, A68_BIG_ENDIAN); if (z == code_string (p, "fmt ", 4)) { /* Read fmt chunk */ int k, skip; z = read_riff_item (p, FD (f), 4, A68_LITTLE_ENDIAN); skip = (int) z - 0x10; /* Bytes to skip in extended wave format */ fmt_cat = read_riff_item (p, FD (f), 2, A68_LITTLE_ENDIAN); if (fmt_cat != WAVE_FORMAT_PCM) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_SOUND_INTERNAL_STRING, MODE (SOUND), "category is not WAVE_FORMAT_PCM but", format_category (fmt_cat)); exit_genie (p, A68_RUNTIME_ERROR); } NUM_CHANNELS (w) = read_riff_item (p, FD (f), 2, A68_LITTLE_ENDIAN); SAMPLE_RATE (w) = read_riff_item (p, FD (f), 4, A68_LITTLE_ENDIAN); byterate = read_riff_item (p, FD (f), 4, A68_LITTLE_ENDIAN); blockalign = read_riff_item (p, FD (f), 2, A68_LITTLE_ENDIAN); BITS_PER_SAMPLE (w) = read_riff_item (p, FD (f), 2, A68_LITTLE_ENDIAN); test_bits_per_sample (p, BITS_PER_SAMPLE (w)); for (k = 0; k < skip; k++) { z = read_riff_item (p, FD (f), 1, A68_LITTLE_ENDIAN); } } else if (z == code_string (p, "LIST", 4)) { /* Skip a LIST chunk */ int k, skip; z = read_riff_item (p, FD (f), 4, A68_LITTLE_ENDIAN); skip = (int) z; for (k = 0; k < skip; k++) { z = read_riff_item (p, FD (f), 1, A68_LITTLE_ENDIAN); } } else if (z == code_string (p, "cue ", 4)) { /* Skip a cue chunk */ int k, skip; z = read_riff_item (p, FD (f), 4, A68_LITTLE_ENDIAN); skip = (int) z; for (k = 0; k < skip; k++) { z = read_riff_item (p, FD (f), 1, A68_LITTLE_ENDIAN); } } else if (z == code_string (p, "fact", 4)) { /* Skip a fact chunk */ int k, skip; z = read_riff_item (p, FD (f), 4, A68_LITTLE_ENDIAN); skip = (int) z; for (k = 0; k < skip; k++) { z = read_riff_item (p, FD (f), 1, A68_LITTLE_ENDIAN); } } else if (z == code_string (p, "data", 4)) { /* Read data chunk */ subchunk2size = read_riff_item (p, FD (f), 4, A68_LITTLE_ENDIAN); NUM_SAMPLES (w) = subchunk2size / NUM_CHANNELS (w) / (unsigned) A68_SOUND_BYTES (w); DATA (w) = heap_generator (p, MODE (SOUND_DATA), (int) subchunk2size); r = (int) io_read (FD (f), ADDRESS (&(DATA (w))), subchunk2size); if (r != (int) subchunk2size) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_SOUND_INTERNAL, MODE (SOUND), "cannot read all of the data"); exit_genie (p, A68_RUNTIME_ERROR); } data_read = A68_TRUE; } else { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_SOUND_INTERNAL_STRING, MODE (SOUND), "chunk is", code_unsigned (p, z)); exit_genie (p, A68_RUNTIME_ERROR); } } STATUS (w) = INIT_MASK; } /*! \brief write RIFF item \param p position in tree \param fd file number \param z item \param n number of chars \param little whether little endian **/ void write_riff_item (NODE_T * p, FILE_T fd, unsigned z, int n, BOOL_T little) { int k, r; unsigned char y[MAX_BYTES]; if (n > MAX_BYTES) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_SOUND_INTERNAL, MODE (SOUND), "too long word length"); exit_genie (p, A68_RUNTIME_ERROR); } for (k = 0; k < n; k++) { y[k] = (unsigned char) (z & 0xff); z >>= 8; } if (little) { for (k = 0; k < n; k++) { ASSERT (io_write (fd, &(y[k]), 1) != -1); } } else { for (k = n - 1; k >= 0; k--) { r = (int) io_write (fd, &(y[k]), 1); if (r != 1) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_SOUND_INTERNAL, MODE (SOUND), "error while writing file"); exit_genie (p, A68_RUNTIME_ERROR); } } } } /*! \brief write sound to file \param p position in tree \param ref_file pointer to file \param w sound object **/ void write_sound (NODE_T * p, A68_REF ref_file, A68_SOUND * w) { A68_FILE *f = FILE_DEREF (&ref_file); int r; unsigned blockalign = NUM_CHANNELS (w) * (unsigned) (A68_SOUND_BYTES (w)); unsigned byterate = SAMPLE_RATE (w) * blockalign; unsigned subchunk2size = NUM_SAMPLES (w) * blockalign; unsigned chunksize = 4 + (8 + 16) + (8 + subchunk2size); write_riff_item (p, FD (f), code_string (p, "RIFF", 4), 4, A68_BIG_ENDIAN); write_riff_item (p, FD (f), chunksize, 4, A68_LITTLE_ENDIAN); write_riff_item (p, FD (f), code_string (p, "WAVE", 4), 4, A68_BIG_ENDIAN); write_riff_item (p, FD (f), code_string (p, "fmt ", 4), 4, A68_BIG_ENDIAN); write_riff_item (p, FD (f), 16, 4, A68_LITTLE_ENDIAN); write_riff_item (p, FD (f), 1, 2, A68_LITTLE_ENDIAN); write_riff_item (p, FD (f), NUM_CHANNELS (w), 2, A68_LITTLE_ENDIAN); write_riff_item (p, FD (f), SAMPLE_RATE (w), 4, A68_LITTLE_ENDIAN); write_riff_item (p, FD (f), byterate, 4, A68_LITTLE_ENDIAN); write_riff_item (p, FD (f), blockalign, 2, A68_LITTLE_ENDIAN); write_riff_item (p, FD (f), BITS_PER_SAMPLE (w), 2, A68_LITTLE_ENDIAN); write_riff_item (p, FD (f), code_string (p, "data", 4), 4, A68_BIG_ENDIAN); write_riff_item (p, FD (f), subchunk2size, 4, A68_LITTLE_ENDIAN); if (IS_NIL (DATA (w))) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_SOUND_INTERNAL, MODE (SOUND), "sound has no data"); exit_genie (p, A68_RUNTIME_ERROR); } r = (int) io_write (FD (f), ADDRESS (&(DATA (w))), subchunk2size); if (r != (int) subchunk2size) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_SOUND_INTERNAL, MODE (SOUND), "error while writing file"); exit_genie (p, A68_RUNTIME_ERROR); } } /*! \brief PROC new sound = (INT bits, INT sample rate, INT channels, INT samples) SOUND \param p position in tree **/ void genie_new_sound (NODE_T * p) { A68_INT num_channels, sample_rate, bits_per_sample, num_samples; A68_SOUND w; POP_OBJECT (p, &num_samples, A68_INT); POP_OBJECT (p, &num_channels, A68_INT); POP_OBJECT (p, &sample_rate, A68_INT); POP_OBJECT (p, &bits_per_sample, A68_INT); NUM_SAMPLES (&w) = (unsigned) (VALUE (&num_samples)); NUM_CHANNELS (&w) = (unsigned) (VALUE (&num_channels)); SAMPLE_RATE (&w) = (unsigned) (VALUE (&sample_rate)); BITS_PER_SAMPLE (&w) = (unsigned) (VALUE (&bits_per_sample)); test_bits_per_sample (p, BITS_PER_SAMPLE (&w)); DATA_SIZE (&w) = (unsigned) A68_SOUND_DATA_SIZE (&w); DATA (&w) = heap_generator (p, MODE (SOUND_DATA), (int) DATA_SIZE (&w)); STATUS (&w) = INIT_MASK; PUSH_OBJECT (p, w, A68_SOUND); } /*! \brief PROC get sound = (SOUND w, INT channel, sample) INT \param p position in tree **/ void genie_get_sound (NODE_T * p) { A68_INT channel, sample; A68_SOUND w; int addr, k, n, z, m; BYTE_T *d; POP_OBJECT (p, &sample, A68_INT); POP_OBJECT (p, &channel, A68_INT); POP_OBJECT (p, &w, A68_SOUND); if (!(VALUE (&channel) >= 1 && VALUE (&channel) <= (int) NUM_CHANNELS (&w))) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_SOUND_INTERNAL, MODE (SOUND), "channel index out of range"); exit_genie (p, A68_RUNTIME_ERROR); } if (!(VALUE (&sample) >= 1 && VALUE (&sample) <= (int) NUM_SAMPLES (&w))) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_SOUND_INTERNAL, MODE (SOUND), "sample index out of range"); exit_genie (p, A68_RUNTIME_ERROR); } if (IS_NIL (DATA (&w))) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_SOUND_INTERNAL, MODE (SOUND), "sound has no data"); exit_genie (p, A68_RUNTIME_ERROR); } n = A68_SOUND_BYTES (&w); addr = ((VALUE (&sample) - 1) * (int) (NUM_CHANNELS (&w)) + (VALUE (&channel) - 1)) * n; ABEND (addr < 0 || addr >= (int) DATA_SIZE (&w), ERROR_INTERNAL_CONSISTENCY, NO_TEXT); d = &(ADDRESS (&(DATA (&w)))[addr]); /* Convert from little-endian, irrespective from the platform we work on */ for (k = 0, z = 0, m = 0; k < n; k++) { z += ((int) (d[k]) * (int) (pow256[k])); m = k; } PUSH_PRIMITIVE (p, (d[m] & 0x80 ? (n == 4 ? z : z - (int) pow256[m + 1]) : z), A68_INT); } /*! \brief PROC set sound = (SOUND w, INT channel, sample, value) VOID \param p position in tree **/ void genie_set_sound (NODE_T * p) { A68_INT channel, sample, value; int addr, k, n, z; BYTE_T *d; A68_SOUND w; POP_OBJECT (p, &value, A68_INT); POP_OBJECT (p, &sample, A68_INT); POP_OBJECT (p, &channel, A68_INT); POP_OBJECT (p, &w, A68_SOUND); if (!(VALUE (&channel) >= 1 && VALUE (&channel) <= (int) NUM_CHANNELS (&w))) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_SOUND_INTERNAL, MODE (SOUND), "channel index out of range"); exit_genie (p, A68_RUNTIME_ERROR); } if (!(VALUE (&sample) >= 1 && VALUE (&sample) <= (int) NUM_SAMPLES (&w))) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_SOUND_INTERNAL, MODE (SOUND), "sample index out of range"); exit_genie (p, A68_RUNTIME_ERROR); } if (IS_NIL (DATA (&w))) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_SOUND_INTERNAL, MODE (SOUND), "sound has no data"); exit_genie (p, A68_RUNTIME_ERROR); } n = A68_SOUND_BYTES (&w); addr = ((VALUE (&sample) - 1) * (int) (NUM_CHANNELS (&w)) + (VALUE (&channel) - 1)) * n; ABEND (addr < 0 || addr >= (int) DATA_SIZE (&w), ERROR_INTERNAL_CONSISTENCY, NO_TEXT); d = &(ADDRESS (&(DATA (&w)))[addr]); /* Convert to little-endian */ for (k = 0, z = VALUE (&value); k < n; k++) { d[k] = (BYTE_T) (z & 0xff); z >>= 8; } } /*! \brief OP SOUND = (SOUND) INT \param p position in tree **/ void genie_sound_samples (NODE_T * p) { A68_SOUND w; POP_OBJECT (p, &w, A68_SOUND); PUSH_PRIMITIVE (p, (int) (NUM_SAMPLES (&w)), A68_INT); } /*! \brief OP RATE = (SOUND) INT \param p position in tree **/ void genie_sound_rate (NODE_T * p) { A68_SOUND w; POP_OBJECT (p, &w, A68_SOUND); PUSH_PRIMITIVE (p, (int) (SAMPLE_RATE (&w)), A68_INT); } /*! \brief OP CHANNELS = (SOUND) INT \param p position in tree **/ void genie_sound_channels (NODE_T * p) { A68_SOUND w; POP_OBJECT (p, &w, A68_SOUND); PUSH_PRIMITIVE (p, (int) (NUM_CHANNELS (&w)), A68_INT); } /*! \brief OP RESOLUTION = (SOUND) INT \param p position in tree **/ void genie_sound_resolution (NODE_T * p) { A68_SOUND w; POP_OBJECT (p, &w, A68_SOUND); PUSH_PRIMITIVE (p, (int) (BITS_PER_SAMPLE (&w)), A68_INT); } /*! Unix extensions to A68G */ #define MAX_RESTART 256 BOOL_T halt_typing; static int chars_in_tty_line; char output_line[BUFFER_SIZE], edit_line[BUFFER_SIZE], input_line[BUFFER_SIZE]; /*! \brief initialise output to STDOUT **/ void init_tty (void) { chars_in_tty_line = 0; halt_typing = A68_FALSE; change_masks (TOP_NODE (&program), BREAKPOINT_INTERRUPT_MASK, A68_FALSE); } /*! \brief terminate current line on STDOUT **/ void io_close_tty_line (void) { if (chars_in_tty_line > 0) { io_write_string (STDOUT_FILENO, NEWLINE_STRING); } } /*! \brief get a char from STDIN \return same **/ char get_stdin_char (void) { ssize_t j; char ch[4]; RESET_ERRNO; j = io_read_conv (STDIN_FILENO, &(ch[0]), 1); ABEND (j < 0, "cannot read char from stdin", NO_TEXT); return ((char) (j == 1 ? ch[0] : EOF_CHAR)); } /*! \brief read string from STDIN, until NEWLINE_STRING \param prompt prompt string \return input line buffer **/ char *read_string_from_tty (char *prompt) { #if defined HAVE_READLINE char * line = readline (prompt); if (line != NO_TEXT && (int) strlen (line) > 0) { add_history (line); } bufcpy (input_line, line, BUFFER_SIZE); chars_in_tty_line = (int) strlen (input_line); free (line); return (input_line); #else int ch, k = 0, n; if (prompt != NO_TEXT) { io_close_tty_line (); io_write_string (STDOUT_FILENO, prompt); } ch = get_stdin_char (); while (ch != NEWLINE_CHAR && k < BUFFER_SIZE - 1) { if (ch == EOF_CHAR) { input_line[0] = EOF_CHAR; input_line[1] = NULL_CHAR; chars_in_tty_line = 1; return (input_line); } else { input_line[k++] = (char) ch; ch = get_stdin_char (); } } input_line[k] = NULL_CHAR; n = (int) strlen (input_line); chars_in_tty_line = (ch == NEWLINE_CHAR ? 0 : (n > 0 ? n : 1)); return (input_line); #endif } /*! \brief write string to file \param f file number \param z string to write **/ void io_write_string (FILE_T f, const char *z) { ssize_t j; RESET_ERRNO; if (f != STDOUT_FILENO && f != STDERR_FILENO) { /* Writing to file */ j = io_write_conv (f, z, strlen (z)); ABEND (j < 0, "cannot write", NO_TEXT); } else { /* Writing to TTY */ int first, k; /* Write parts until end-of-string */ first = 0; do { k = first; /* How far can we get? */ while (z[k] != NULL_CHAR && z[k] != NEWLINE_CHAR) { k++; } if (k > first) { /* Write these characters */ int n = k - first; j = io_write_conv (f, &(z[first]), (size_t) n); ABEND (j < 0, "cannot write", NO_TEXT); chars_in_tty_line += n; } if (z[k] == NEWLINE_CHAR) { /* Pretty-print newline */ k++; first = k; j = io_write_conv (f, NEWLINE_STRING, 1); ABEND (j < 0, "cannot write", NO_TEXT); chars_in_tty_line = 0; } } while (z[k] != NULL_CHAR); } } /*! \brief read bytes from file into buffer \param fd file descriptor, must be open \param buf character buffer, size must be >= n \param n maximum number of bytes to read \return number of bytes read or -1 in case of error **/ ssize_t io_read (FILE_T fd, void *buf, size_t n) { size_t to_do = n; int restarts = 0; char *z = (char *) buf; while (to_do > 0) { #if defined HAVE_WIN32 int bytes_read; #else ssize_t bytes_read; #endif RESET_ERRNO; bytes_read = read (fd, z, to_do); if (bytes_read < 0) { if (errno == EINTR) { /* interrupt, retry */ bytes_read = 0; if (restarts++ > MAX_RESTART) { return (-1); } } else { /* read error */ return (-1); } } else if (bytes_read == 0) { break; /* EOF_CHAR */ } to_do -= (size_t) bytes_read; z += bytes_read; } return ((ssize_t) n - (ssize_t) to_do); /* return >= 0 */ } /*! \brief writes n bytes from buffer to file \param fd file descriptor, must be open \param buf character buffer, size must be >= n \param n maximum number of bytes to write \return n or -1 in case of error **/ ssize_t io_write (FILE_T fd, const void *buf, size_t n) { size_t to_do = n; int restarts = 0; char *z = (char *) buf; while (to_do > 0) { ssize_t bytes_written; RESET_ERRNO; bytes_written = write (fd, z, to_do); if (bytes_written <= 0) { if (errno == EINTR) { /* interrupt, retry */ bytes_written = 0; if (restarts++ > MAX_RESTART) { return (-1); } } else { /* write error */ return (-1); } } to_do -= (size_t) bytes_written; z += bytes_written; } return ((ssize_t) n); } /*! \brief read bytes from file into buffer \param fd file descriptor, must be open \param buf character buffer, size must be >= n \param n maximum number of bytes to read \return number of bytes read or -1 in case of error **/ ssize_t io_read_conv (FILE_T fd, void *buf, size_t n) { size_t to_do = n; int restarts = 0; char *z = (char *) buf; while (to_do > 0) { #if defined HAVE_WIN32 int bytes_read; #else ssize_t bytes_read; #endif RESET_ERRNO; bytes_read = read (fd, z, to_do); if (bytes_read < 0) { if (errno == EINTR) { /* interrupt, retry */ bytes_read = 0; if (restarts++ > MAX_RESTART) { return (-1); } } else { /* read error */ return (-1); } } else if (bytes_read == 0) { break; /* EOF_CHAR */ } to_do -= (size_t) bytes_read; z += bytes_read; } return ((ssize_t) n - (ssize_t) to_do); } /*! \brief writes n bytes from buffer to file \param fd file descriptor, must be open \param buf character buffer, size must be >= n \param n maximum number of bytes to write \return n or -1 in case of error **/ ssize_t io_write_conv (FILE_T fd, const void *buf, size_t n) { size_t to_do = n; int restarts = 0; char *z = (char *) buf; while (to_do > 0) { ssize_t bytes_written; RESET_ERRNO; bytes_written = write (fd, z, to_do); if (bytes_written <= 0) { if (errno == EINTR) { /* interrupt, retry */ bytes_written = 0; if (restarts++ > MAX_RESTART) { return (-1); } } else { /* write error */ return (-1); } } to_do -= (size_t) bytes_written; z += bytes_written; } return ((ssize_t) n); } /* This code implements some UNIX/Linux/BSD related routines. In part contributed by Sian Leitch. */ #define VECTOR_SIZE 512 #define FD_READ 0 #define FD_WRITE 1 extern A68_REF tmp_to_a68_string (NODE_T *, char *); extern A68_CHANNEL stand_in_channel, stand_out_channel, stand_draw_channel, stand_back_channel, stand_error_channel; #if defined HAVE_DIRENT_H /*! \brief PROC (STRING) [] STRING directory \param p position in tree **/ void genie_directory (NODE_T * p) { A68_REF name; char *buffer; RESET_ERRNO; POP_REF (p, &name); CHECK_INIT (p, INITIALISED (&name), MODE (STRING)); buffer = (char *) malloc ((size_t) (1 + a68_string_size (p, name))); if (buffer == NO_TEXT) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_OUT_OF_CORE); exit_genie (p, A68_RUNTIME_ERROR); PUSH_PRIMITIVE (p, A68_MAX_INT, A68_INT); } else { char *dir_name = a_to_c_string (p, buffer, name); A68_REF z, row; A68_ARRAY arr; A68_TUPLE tup; int k, n = 0; A68_REF *base; DIR *dir; struct dirent *entry; dir = opendir (dir_name); if (dir == NULL) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FILE_ACCESS); exit_genie (p, A68_RUNTIME_ERROR); } do { entry = readdir (dir); if (errno != 0) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FILE_ACCESS); exit_genie (p, A68_RUNTIME_ERROR); } if (entry != NULL) { n++; } } while (entry != NULL); rewinddir (dir); if (errno != 0) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FILE_ACCESS); exit_genie (p, A68_RUNTIME_ERROR); } z = heap_generator (p, MODE (ROW_STRING), ALIGNED_SIZE_OF (A68_ARRAY) + ALIGNED_SIZE_OF (A68_TUPLE)); row = heap_generator (p, MODE (ROW_STRING), n * MOID_SIZE (MODE (STRING))); DIM (&arr) = 1; MOID (&arr) = MODE (STRING); ELEM_SIZE (&arr) = MOID_SIZE (MODE (STRING)); SLICE_OFFSET (&arr) = 0; FIELD_OFFSET (&arr) = 0; ARRAY (&arr) = row; LWB (&tup) = 1; UPB (&tup) = n; SHIFT (&tup) = LWB (&tup); SPAN (&tup) = 1; K (&tup) = 0; PUT_DESCRIPTOR (arr, tup, &z); base = DEREF (A68_REF, &row); for (k = 0; k < n; k++) { entry = readdir (dir); if (errno != 0) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FILE_ACCESS); exit_genie (p, A68_RUNTIME_ERROR); } base[k] = c_to_a_string (p, D_NAME (entry), DEFAULT_WIDTH); } if (closedir (dir) != 0) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FILE_ACCESS); exit_genie (p, A68_RUNTIME_ERROR); } PUSH_REF (p, z); free (buffer); } } #endif /*! \brief PROC [] INT utc time \param p position in tree **/ void genie_utctime (NODE_T * p) { time_t dt; if (time (&dt) == (time_t) - 1) { (void) empty_row (p, MODE (ROW_INT)); } else { A68_REF row; ADDR_T sp = stack_pointer; struct tm *tod = gmtime (&dt); PUSH_PRIMITIVE (p, TM_YEAR (tod) + 1900, A68_INT); PUSH_PRIMITIVE (p, TM_MON (tod) + 1, A68_INT); PUSH_PRIMITIVE (p, TM_MDAY (tod), A68_INT); PUSH_PRIMITIVE (p, TM_HOUR (tod), A68_INT); PUSH_PRIMITIVE (p, TM_MIN (tod), A68_INT); PUSH_PRIMITIVE (p, TM_SEC (tod), A68_INT); PUSH_PRIMITIVE (p, TM_WDAY (tod) + 1, A68_INT); PUSH_PRIMITIVE (p, TM_ISDST (tod), A68_INT); row = genie_make_row (p, MODE (INT), 8, sp); stack_pointer = sp; PUSH_REF (p, row); } } /*! \brief PROC [] INT local time \param p position in tree **/ void genie_localtime (NODE_T * p) { time_t dt; if (time (&dt) == (time_t) - 1) { (void) empty_row (p, MODE (ROW_INT)); } else { A68_REF row; ADDR_T sp = stack_pointer; struct tm *tod = localtime (&dt); PUSH_PRIMITIVE (p, TM_YEAR (tod) + 1900, A68_INT); PUSH_PRIMITIVE (p, TM_MON (tod) + 1, A68_INT); PUSH_PRIMITIVE (p, TM_MDAY (tod), A68_INT); PUSH_PRIMITIVE (p, TM_HOUR (tod), A68_INT); PUSH_PRIMITIVE (p, TM_MIN (tod), A68_INT); PUSH_PRIMITIVE (p, TM_SEC (tod), A68_INT); PUSH_PRIMITIVE (p, TM_WDAY (tod) + 1, A68_INT); PUSH_PRIMITIVE (p, TM_ISDST (tod), A68_INT); row = genie_make_row (p, MODE (INT), 8, sp); stack_pointer = sp; PUSH_REF (p, row); } } /*! \brief PROC INT rows \param p position in tree **/ void genie_rows (NODE_T * p) { RESET_ERRNO; PUSH_PRIMITIVE (p, term_heigth, A68_INT); } /*! \brief PROC INT columns \param p position in tree **/ void genie_columns (NODE_T * p) { RESET_ERRNO; PUSH_PRIMITIVE (p, term_width, A68_INT); } /*! \brief PROC INT argc \param p position in tree **/ void genie_argc (NODE_T * p) { RESET_ERRNO; PUSH_PRIMITIVE (p, global_argc, A68_INT); } /*! \brief PROC (INT) STRING argv \param p position in tree **/ void genie_argv (NODE_T * p) { A68_INT a68g_index; RESET_ERRNO; POP_OBJECT (p, &a68g_index, A68_INT); if (VALUE (&a68g_index) >= 1 && VALUE (&a68g_index) <= global_argc) { char *q = global_argv[VALUE (&a68g_index) - 1]; int n = (int) strlen (q); /* Allow for spaces ending in # to have A68 comment syntax with '#!' */ while (n > 0 && (IS_SPACE(q[n - 1]) || q[n - 1] == '#')) { q[--n] = NULL_CHAR; } PUSH_REF (p, c_to_a_string (p, q, DEFAULT_WIDTH)); } else { PUSH_REF (p, empty_string (p)); } } /*! \brief PROC STRING pwd \param p position in tree **/ void genie_pwd (NODE_T * p) { size_t size = BUFFER_SIZE; char *buffer = NO_TEXT; BOOL_T cont = A68_TRUE; RESET_ERRNO; while (cont) { buffer = (char *) malloc (size); if (buffer == NO_TEXT) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_OUT_OF_CORE); exit_genie (p, A68_RUNTIME_ERROR); } if (getcwd (buffer, size) == buffer) { cont = A68_FALSE; } else { free (buffer); cont = (BOOL_T) (errno == 0); size *= 2; } } if (buffer != NO_TEXT && errno == 0) { PUSH_REF (p, c_to_a_string (p, buffer, DEFAULT_WIDTH)); free (buffer); } else { PUSH_REF (p, empty_string (p)); } } /*! \brief PROC (STRING) INT cd \param p position in tree **/ void genie_cd (NODE_T * p) { A68_REF dir; char *buffer; RESET_ERRNO; POP_REF (p, &dir); CHECK_INIT (p, INITIALISED (&dir), MODE (STRING)); buffer = (char *) malloc ((size_t) (1 + a68_string_size (p, dir))); if (buffer == NO_TEXT) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_OUT_OF_CORE); exit_genie (p, A68_RUNTIME_ERROR); } else { int rc = chdir (a_to_c_string (p, buffer, dir)); if (rc == 0) { PUSH_PRIMITIVE (p, chdir (a_to_c_string (p, buffer, dir)), A68_INT); } else { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FILE_ACCESS); exit_genie (p, A68_RUNTIME_ERROR); } free (buffer); } } /*! \brief PROC (STRING) BITS \param p position in tree **/ void genie_file_mode (NODE_T * p) { A68_REF name; char *buffer; RESET_ERRNO; POP_REF (p, &name); CHECK_INIT (p, INITIALISED (&name), MODE (STRING)); buffer = (char *) malloc ((size_t) (1 + a68_string_size (p, name))); if (buffer == NO_TEXT) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_OUT_OF_CORE); exit_genie (p, A68_RUNTIME_ERROR); } else { struct stat status; if (stat (a_to_c_string (p, buffer, name), &status) == 0) { PUSH_PRIMITIVE (p, (unsigned) (ST_MODE (&status)), A68_BITS); } else { PUSH_PRIMITIVE (p, 0x0, A68_BITS); } free (buffer); } } /*! \brief PROC (STRING) BOOL file is block device \param p position in tree **/ void genie_file_is_block_device (NODE_T * p) { A68_REF name; char *buffer; RESET_ERRNO; POP_REF (p, &name); CHECK_INIT (p, INITIALISED (&name), MODE (STRING)); buffer = (char *) malloc ((size_t) (1 + a68_string_size (p, name))); if (buffer == NO_TEXT) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_OUT_OF_CORE); exit_genie (p, A68_RUNTIME_ERROR); } else { struct stat status; if (stat (a_to_c_string (p, buffer, name), &status) == 0) { PUSH_PRIMITIVE (p, (BOOL_T) (S_ISBLK (ST_MODE (&status)) != 0 ? A68_TRUE : A68_FALSE), A68_BOOL); } else { PUSH_PRIMITIVE (p, A68_FALSE, A68_BOOL); } free (buffer); } } /*! \brief PROC (STRING) BOOL file is char device \param p position in tree **/ void genie_file_is_char_device (NODE_T * p) { A68_REF name; char *buffer; RESET_ERRNO; POP_REF (p, &name); CHECK_INIT (p, INITIALISED (&name), MODE (STRING)); buffer = (char *) malloc ((size_t) (1 + a68_string_size (p, name))); if (buffer == NO_TEXT) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_OUT_OF_CORE); exit_genie (p, A68_RUNTIME_ERROR); } else { struct stat status; if (stat (a_to_c_string (p, buffer, name), &status) == 0) { PUSH_PRIMITIVE (p, (BOOL_T) (S_ISCHR (ST_MODE (&status)) != 0 ? A68_TRUE : A68_FALSE), A68_BOOL); } else { PUSH_PRIMITIVE (p, A68_FALSE, A68_BOOL); } free (buffer); } } /*! \brief PROC (STRING) BOOL file is directory \param p position in tree **/ void genie_file_is_directory (NODE_T * p) { A68_REF name; char *buffer; RESET_ERRNO; POP_REF (p, &name); CHECK_INIT (p, INITIALISED (&name), MODE (STRING)); buffer = (char *) malloc ((size_t) (1 + a68_string_size (p, name))); if (buffer == NO_TEXT) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_OUT_OF_CORE); exit_genie (p, A68_RUNTIME_ERROR); } else { struct stat status; if (stat (a_to_c_string (p, buffer, name), &status) == 0) { PUSH_PRIMITIVE (p, (BOOL_T) (S_ISDIR (ST_MODE (&status)) != 0 ? A68_TRUE : A68_FALSE), A68_BOOL); } else { PUSH_PRIMITIVE (p, A68_FALSE, A68_BOOL); } free (buffer); } } /*! \brief PROC (STRING) BOOL file is regular \param p position in tree **/ void genie_file_is_regular (NODE_T * p) { A68_REF name; char *buffer; RESET_ERRNO; POP_REF (p, &name); CHECK_INIT (p, INITIALISED (&name), MODE (STRING)); buffer = (char *) malloc ((size_t) (1 + a68_string_size (p, name))); if (buffer == NO_TEXT) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_OUT_OF_CORE); exit_genie (p, A68_RUNTIME_ERROR); } else { struct stat status; if (stat (a_to_c_string (p, buffer, name), &status) == 0) { PUSH_PRIMITIVE (p, (BOOL_T) (S_ISREG (ST_MODE (&status)) != 0 ? A68_TRUE : A68_FALSE), A68_BOOL); } else { PUSH_PRIMITIVE (p, A68_FALSE, A68_BOOL); } free (buffer); } } #if defined __S_IFIFO /*! \brief PROC (STRING) BOOL file is fifo \param p position in tree **/ void genie_file_is_fifo (NODE_T * p) { A68_REF name; char *buffer; RESET_ERRNO; POP_REF (p, &name); CHECK_INIT (p, INITIALISED (&name), MODE (STRING)); buffer = (char *) malloc ((size_t) (1 + a68_string_size (p, name))); if (buffer == NO_TEXT) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_OUT_OF_CORE); exit_genie (p, A68_RUNTIME_ERROR); } else { struct stat status; if (stat (a_to_c_string (p, buffer, name), &status) == 0) { PUSH_PRIMITIVE (p, (BOOL_T) (S_ISFIFO (ST_MODE (&status)) != 0 ? A68_TRUE : A68_FALSE), A68_BOOL); } else { PUSH_PRIMITIVE (p, A68_FALSE, A68_BOOL); } free (buffer); } } #endif #if defined S_ISLNK /*! \brief PROC (STRING) BOOL file is link \param p position in tree **/ void genie_file_is_link (NODE_T * p) { A68_REF name; char *buffer; RESET_ERRNO; POP_REF (p, &name); CHECK_INIT (p, INITIALISED (&name), MODE (STRING)); buffer = (char *) malloc ((size_t) (1 + a68_string_size (p, name))); if (buffer == NO_TEXT) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_OUT_OF_CORE); exit_genie (p, A68_RUNTIME_ERROR); } else { struct stat status; if (stat (a_to_c_string (p, buffer, name), &status) == 0) { PUSH_PRIMITIVE (p, (BOOL_T) (S_ISLNK (ST_MODE (&status)) != 0 ? A68_TRUE : A68_FALSE), A68_BOOL); } else { PUSH_PRIMITIVE (p, A68_FALSE, A68_BOOL); } free (buffer); } } #endif /*! \brief convert [] STRING row to char *vec[] \param p position in tree \param vec string vector \param row [] STRING **/ static void convert_string_vector (NODE_T * p, char *vec[], A68_REF row) { BYTE_T *z = ADDRESS (&row); A68_ARRAY *arr = (A68_ARRAY *) & z[0]; A68_TUPLE *tup = (A68_TUPLE *) & z[ALIGNED_SIZE_OF (A68_ARRAY)]; int k = 0; if (get_row_size (tup, DIM (arr)) > 0) { BYTE_T *base_addr = DEREF (BYTE_T, &ARRAY (arr)); BOOL_T done = A68_FALSE; initialise_internal_index (tup, DIM (arr)); while (!done) { ADDR_T a68g_index = calculate_internal_index (tup, DIM (arr)); ADDR_T elem_addr = (a68g_index + SLICE_OFFSET (arr)) * ELEM_SIZE (arr) + FIELD_OFFSET (arr); BYTE_T *elem = &base_addr[elem_addr]; int size = a68_string_size (p, *(A68_REF *) elem); CHECK_INIT (p, INITIALISED ((A68_REF *) elem), MODE (STRING)); vec[k] = (char *) get_heap_space ((size_t) (1 + size)); ASSERT (a_to_c_string (p, vec[k], *(A68_REF *) elem) != NO_TEXT); if (k == VECTOR_SIZE - 1) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_TOO_MANY_ARGUMENTS); exit_genie (p, A68_RUNTIME_ERROR); } if (strlen (vec[k]) > 0) { k++; } done = increment_internal_index (tup, DIM (arr)); } } vec[k] = NO_TEXT; } /*! \brief free char *vec[] \param vec string vector **/ static void free_vector (char *vec[]) { int k = 0; while (vec[k] != NO_TEXT) { free (vec[k]); k++; } } /*! \brief reset error number \param p position in tree **/ void genie_reset_errno (NODE_T * p) { (void) *p; RESET_ERRNO; } /*! \brief error number \param p position in tree **/ void genie_errno (NODE_T * p) { PUSH_PRIMITIVE (p, errno, A68_INT); } /*! \brief PROC strerror = (INT) STRING \param p position in tree **/ void genie_strerror (NODE_T * p) { A68_INT i; POP_OBJECT (p, &i, A68_INT); PUSH_REF (p, c_to_a_string (p, strerror (VALUE (&i)), DEFAULT_WIDTH)); } /*! \brief set up file for usage in pipe \param p position in tree \param z pointer to file \param fd file number \param chan channel \param r_mood read mood \param w_mood write mood \param pid pid **/ static void set_up_file (NODE_T * p, A68_REF * z, int fd, A68_CHANNEL chan, BOOL_T r_mood, BOOL_T w_mood, int pid) { A68_FILE *f; *z = heap_generator (p, MODE (REF_FILE), ALIGNED_SIZE_OF (A68_FILE)); f = FILE_DEREF (z); STATUS (f) = (STATUS_MASK) ((pid < 0) ? 0 : INIT_MASK); IDENTIFICATION (f) = nil_ref; TERMINATOR (f) = nil_ref; CHANNEL (f) = chan; FD (f) = fd; STREAM (&DEVICE (f)) = NO_STREAM; OPENED (f) = A68_TRUE; OPEN_EXCLUSIVE (f) = A68_FALSE; READ_MOOD (f) = r_mood; WRITE_MOOD (f) = w_mood; CHAR_MOOD (f) = A68_TRUE; DRAW_MOOD (f) = A68_FALSE; FORMAT (f) = nil_format; TRANSPUT_BUFFER (f) = get_unblocked_transput_buffer (p); STRING (f) = nil_ref; reset_transput_buffer (TRANSPUT_BUFFER (f)); set_default_event_procedures (f); } /*! \brief create and push a pipe \param p position in tree \param fd_r read file number \param fd_w write file number \param pid pid **/ static void genie_mkpipe (NODE_T * p, int fd_r, int fd_w, int pid) { A68_REF r, w; RESET_ERRNO; /* Set up pipe */ set_up_file (p, &r, fd_r, stand_in_channel, A68_TRUE, A68_FALSE, pid); set_up_file (p, &w, fd_w, stand_out_channel, A68_FALSE, A68_TRUE, pid); /* push pipe */ PUSH_REF (p, r); PUSH_REF (p, w); PUSH_PRIMITIVE (p, pid, A68_INT); } /*! \brief push an environment string \param p position in tree **/ void genie_getenv (NODE_T * p) { A68_REF a_env; char *val, *z, *z_env; RESET_ERRNO; POP_REF (p, &a_env); CHECK_INIT (p, INITIALISED (&a_env), MODE (STRING)); z_env = (char *) get_heap_space ((size_t) (1 + a68_string_size (p, a_env))); z = a_to_c_string (p, z_env, a_env); val = getenv (z); if (val == NO_TEXT) { a_env = empty_string (p); } else { a_env = tmp_to_a68_string (p, val); } PUSH_REF (p, a_env); } /*! \brief PROC fork = INT \param p position in tree **/ void genie_fork (NODE_T * p) { #if defined HAVE_WIN32 PUSH_PRIMITIVE (p, -1, A68_INT); #else int pid; RESET_ERRNO; pid = (int) fork (); PUSH_PRIMITIVE (p, pid, A68_INT); #endif } /*! \brief PROC execve = (STRING, [] STRING, [] STRING) INT \param p position in tree **/ void genie_execve (NODE_T * p) { int ret; A68_REF a_prog, a_args, a_env; char *prog, *argv[VECTOR_SIZE], *envp[VECTOR_SIZE]; RESET_ERRNO; /* Pop parameters */ POP_REF (p, &a_env); POP_REF (p, &a_args); POP_REF (p, &a_prog); /* Convert strings and hasta el infinito */ prog = (char *) get_heap_space ((size_t) (1 + a68_string_size (p, a_prog))); ASSERT (a_to_c_string (p, prog, a_prog) != NO_TEXT); convert_string_vector (p, argv, a_args); convert_string_vector (p, envp, a_env); if (argv[0] == NO_TEXT) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_EMPTY_ARGUMENT); exit_genie (p, A68_RUNTIME_ERROR); } #if defined HAVE_WIN32 ret = execve (prog, (const char * const *) argv, (const char * const *) envp); #else ret = execve (prog, argv, envp); #endif /* execve only returns if it fails */ free_vector (argv); free_vector (envp); free (prog); PUSH_PRIMITIVE (p, ret, A68_INT); } /*! \brief PROC execve child = (STRING, [] STRING, [] STRING) INT \param p position in tree **/ void genie_execve_child (NODE_T * p) { int pid; A68_REF a_prog, a_args, a_env; RESET_ERRNO; /* Pop parameters */ POP_REF (p, &a_env); POP_REF (p, &a_args); POP_REF (p, &a_prog); /* Now create the pipes and fork */ #if defined HAVE_WIN32 pid = -1; PUSH_PRIMITIVE (p, -1, A68_INT); return; #else pid = (int) fork (); if (pid == -1) { PUSH_PRIMITIVE (p, -1, A68_INT); } else if (pid == 0) { /* Child process */ char *prog, *argv[VECTOR_SIZE], *envp[VECTOR_SIZE]; /* Convert strings */ prog = (char *) get_heap_space ((size_t) (1 + a68_string_size (p, a_prog))); ASSERT (a_to_c_string (p, prog, a_prog) != NO_TEXT); convert_string_vector (p, argv, a_args); convert_string_vector (p, envp, a_env); if (argv[0] == NO_TEXT) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_EMPTY_ARGUMENT); exit_genie (p, A68_RUNTIME_ERROR); } (void) execve (prog, argv, envp); /* execve only returns if it fails - end child process */ a68g_exit (EXIT_FAILURE); PUSH_PRIMITIVE (p, 0, A68_INT); } else { /* parent process */ PUSH_PRIMITIVE (p, pid, A68_INT); } #endif /* defined HAVE_WIN32 */ } /*! \brief PROC execve child pipe = (STRING, [] STRING, [] STRING) PIPE \param p position in tree **/ void genie_execve_child_pipe (NODE_T * p) { /* Child redirects STDIN and STDOUT. Return a PIPE that contains the descriptors for the parent. pipe ptoc ->W...R-> PARENT CHILD <-R...W<- pipe ctop */ int pid; #if ! defined HAVE_WIN32 int ptoc_fd[2], ctop_fd[2]; #endif /* ! defined HAVE_WIN32 */ A68_REF a_prog, a_args, a_env; RESET_ERRNO; /* Pop parameters */ POP_REF (p, &a_env); POP_REF (p, &a_args); POP_REF (p, &a_prog); #if defined HAVE_WIN32 pid = -1; genie_mkpipe (p, -1, -1, -1); return; #else /* Create the pipes and fork */ if ((pipe (ptoc_fd) == -1) || (pipe (ctop_fd) == -1)) { genie_mkpipe (p, -1, -1, -1); return; } pid = (int) fork (); if (pid == -1) { /* Fork failure */ genie_mkpipe (p, -1, -1, -1); return; } if (pid == 0) { /* Child process */ char *prog, *argv[VECTOR_SIZE], *envp[VECTOR_SIZE]; /* Convert strings */ prog = (char *) get_heap_space ((size_t) (1 + a68_string_size (p, a_prog))); ASSERT (a_to_c_string (p, prog, a_prog) != NO_TEXT); convert_string_vector (p, argv, a_args); convert_string_vector (p, envp, a_env); /* Set up redirection */ ASSERT (close (ctop_fd[FD_READ]) == 0); ASSERT (close (ptoc_fd[FD_WRITE]) == 0); ASSERT (close (STDIN_FILENO) == 0); ASSERT (close (STDOUT_FILENO) == 0); ASSERT (dup2 (ptoc_fd[FD_READ], STDIN_FILENO) != -1); ASSERT (dup2 (ctop_fd[FD_WRITE], STDOUT_FILENO) != -1); if (argv[0] == NO_TEXT) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_EMPTY_ARGUMENT); exit_genie (p, A68_RUNTIME_ERROR); } (void) execve (prog, argv, envp); /* execve only returns if it fails - end child process */ a68g_exit (EXIT_FAILURE); genie_mkpipe (p, -1, -1, -1); } else { /* Parent process */ ASSERT (close (ptoc_fd[FD_READ]) == 0); ASSERT (close (ctop_fd[FD_WRITE]) == 0); genie_mkpipe (p, ctop_fd[FD_READ], ptoc_fd[FD_WRITE], pid); } #endif /* defined HAVE_WIN32 */ } /*! \brief PROC execve_output = (STRING, [] STRING, [] STRING, REF_STRING) INT \param p position in tree **/ void genie_execve_output (NODE_T * p) { /* Child redirects STDIN and STDOUT. pipe ptoc ->W...R-> PARENT CHILD <-R...W<- pipe ctop */ int pid; #if ! defined HAVE_WIN32 int ptoc_fd[2], ctop_fd[2]; #endif /* ! defined HAVE_WIN32 */ A68_REF a_prog, a_args, a_env, dest; RESET_ERRNO; /* Pop parameters */ POP_REF (p, &dest); POP_REF (p, &a_env); POP_REF (p, &a_args); POP_REF (p, &a_prog); #if defined HAVE_WIN32 pid = -1; PUSH_PRIMITIVE (p, -1, A68_INT); return; #else /* Create the pipes and fork */ if ((pipe (ptoc_fd) == -1) || (pipe (ctop_fd) == -1)) { PUSH_PRIMITIVE (p, -1, A68_INT); return; } pid = (int) fork (); if (pid == -1) { /* Fork failure */ PUSH_PRIMITIVE (p, -1, A68_INT); return; } if (pid == 0) { /* Child process */ char *prog, *argv[VECTOR_SIZE], *envp[VECTOR_SIZE]; /* Convert strings */ prog = (char *) get_heap_space ((size_t) (1 + a68_string_size (p, a_prog))); ASSERT (a_to_c_string (p, prog, a_prog) != NO_TEXT); convert_string_vector (p, argv, a_args); convert_string_vector (p, envp, a_env); /* Set up redirection */ ASSERT (close (ctop_fd[FD_READ]) == 0); ASSERT (close (ptoc_fd[FD_WRITE]) == 0); ASSERT (close (STDIN_FILENO) == 0); ASSERT (close (STDOUT_FILENO) == 0); ASSERT (dup2 (ptoc_fd[FD_READ], STDIN_FILENO) != -1); ASSERT (dup2 (ctop_fd[FD_WRITE], STDOUT_FILENO) != -1); if (argv[0] == NO_TEXT) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_EMPTY_ARGUMENT); exit_genie (p, A68_RUNTIME_ERROR); } (void) execve (prog, argv, envp); /* execve only returns if it fails - end child process */ a68g_exit (EXIT_FAILURE); PUSH_PRIMITIVE (p, -1, A68_INT); } else { /* Parent process */ char ch; int pipe_read, ret, status; ASSERT (close (ptoc_fd[FD_READ]) == 0); ASSERT (close (ctop_fd[FD_WRITE]) == 0); reset_transput_buffer (INPUT_BUFFER); do { pipe_read = (int) io_read_conv (ctop_fd[FD_READ], &ch, 1); if (pipe_read > 0) { add_char_transput_buffer (p, INPUT_BUFFER, ch); } } while (pipe_read > 0); do { ret = (int) waitpid ((__pid_t) pid, &status, 0); } while (ret == -1 && errno == EINTR); if (ret != pid) { status = -1; } if (!IS_NIL (dest)) { * DEREF (A68_REF, &dest) = c_to_a_string (p, get_transput_buffer (INPUT_BUFFER), get_transput_buffer_index (INPUT_BUFFER)); } PUSH_PRIMITIVE (p, ret, A68_INT); } #endif /* defined HAVE_WIN32 */ } /*! \brief PROC create pipe = PIPE \param p position in tree **/ void genie_create_pipe (NODE_T * p) { RESET_ERRNO; genie_stand_in (p); genie_stand_out (p); PUSH_PRIMITIVE (p, -1, A68_INT); } /*! \brief PROC wait pid = (INT) VOID \param p position in tree **/ void genie_waitpid (NODE_T * p) { A68_INT k; RESET_ERRNO; POP_OBJECT (p, &k, A68_INT); #if ! defined HAVE_WIN32 ASSERT (waitpid ((__pid_t) VALUE (&k), NULL, 0) != -1); #endif } /* Next part contains some routines that interface Algol68G and the curses library. Be sure to know what you are doing when you use this, but on the other hand, "reset" will always restore your terminal. */ #if defined HAVE_CURSES #define CHECK_CURSES_RETVAL(f) {\ if (!(f)) {\ diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_CURSES);\ exit_genie (p, A68_RUNTIME_ERROR);\ }} BOOL_T a68g_curses_mode = A68_FALSE; /*! \brief clean_curses **/ void clean_curses (void) { if (a68g_curses_mode == A68_TRUE) { (void) wattrset (stdscr, A_NORMAL); (void) endwin (); a68g_curses_mode = A68_FALSE; } } /*! \brief init_curses **/ void init_curses (void) { (void) initscr (); (void) cbreak (); /* raw () would cut off ctrl-c */ (void) noecho (); (void) nonl (); (void) curs_set (0); if (has_colors ()) { (void) start_color (); } } /*! \brief watch stdin for input, do not wait very long \return character read **/ int rgetchar (void) { #if defined HAVE_WIN32 if (kbhit ()) { return (getch ()); } else { return (NULL_CHAR); } #else int retval; struct timeval tv; fd_set rfds; TV_SEC (&tv) = 0; TV_USEC (&tv) = 100; FD_ZERO (&rfds); FD_SET (0, &rfds); retval = select (1, &rfds, NULL, NULL, &tv); if (retval) { /* FD_ISSET(0, &rfds) will be true. */ return (getch ()); } else { return (NULL_CHAR); } #endif } /*! \brief PROC curses start = VOID \param p position in tree **/ void genie_curses_start (NODE_T * p) { errno = 0; init_curses (); if (errno != 0) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_CURSES); exit_genie (p, A68_RUNTIME_ERROR); } a68g_curses_mode = A68_TRUE; } /*! \brief PROC curses end = VOID \param p position in tree **/ void genie_curses_end (NODE_T * p) { (void) p; clean_curses (); } /*! \brief PROC curses clear = VOID \param p position in tree **/ void genie_curses_clear (NODE_T * p) { if (a68g_curses_mode == A68_FALSE) { genie_curses_start (p); } CHECK_CURSES_RETVAL (clear () != ERR); } /*! \brief PROC curses refresh = VOID \param p position in tree **/ void genie_curses_refresh (NODE_T * p) { if (a68g_curses_mode == A68_FALSE) { genie_curses_start (p); } CHECK_CURSES_RETVAL (refresh () != ERR); } /*! \brief PROC curses lines = INT \param p position in tree **/ void genie_curses_lines (NODE_T * p) { if (a68g_curses_mode == A68_FALSE) { genie_curses_start (p); } PUSH_PRIMITIVE (p, LINES, A68_INT); } /*! \brief PROC curses columns = INT \param p position in tree **/ void genie_curses_columns (NODE_T * p) { if (a68g_curses_mode == A68_FALSE) { genie_curses_start (p); } PUSH_PRIMITIVE (p, COLS, A68_INT); } /*! \brief PROC curses getchar = CHAR \param p position in tree **/ void genie_curses_getchar (NODE_T * p) { if (a68g_curses_mode == A68_FALSE) { genie_curses_start (p); } PUSH_PRIMITIVE (p, (char) rgetchar (), A68_CHAR); } /*! \brief PROC curses colour = VOID \param p position in tree **/ #define GENIE_COLOUR(f, n, fg, bg)\ void f (NODE_T *p) {\ (void) p;\ if ((n) < COLOR_PAIRS) {\ (void) init_pair (n, (fg), (bg));\ wattrset (stdscr, COLOR_PAIR ((n)) | A_BOLD);\ }\ }\ void f##_inverse (NODE_T *p) {\ (void) p;\ if ((n + 8) < COLOR_PAIRS) {\ (void) init_pair ((n) + 8, (bg), (fg));\ wattrset (stdscr, COLOR_PAIR (((n) + 8)));\ }\ } GENIE_COLOUR (genie_curses_blue, 1, COLOR_BLUE, COLOR_BLACK) GENIE_COLOUR (genie_curses_cyan, 2, COLOR_CYAN, COLOR_BLACK) GENIE_COLOUR (genie_curses_green, 3, COLOR_GREEN, COLOR_BLACK) GENIE_COLOUR (genie_curses_magenta, 4, COLOR_MAGENTA, COLOR_BLACK) GENIE_COLOUR (genie_curses_red, 5, COLOR_RED, COLOR_BLACK) GENIE_COLOUR (genie_curses_white, 6, COLOR_WHITE, COLOR_BLACK) GENIE_COLOUR (genie_curses_yellow, 7, COLOR_YELLOW, COLOR_BLACK) /*! \brief PROC curses delchar = (CHAR) BOOL \param p position in tree **/ void genie_curses_del_char (NODE_T * p) { A68_CHAR ch; int v; POP_OBJECT (p, &ch, A68_CHAR); v = (int) VALUE (&ch); PUSH_PRIMITIVE (p, (BOOL_T) (v == 8 || v == 127 || v == KEY_BACKSPACE), A68_BOOL); } /*! \brief PROC curses putchar = (CHAR) VOID \param p position in tree **/ void genie_curses_putchar (NODE_T * p) { A68_CHAR ch; if (a68g_curses_mode == A68_FALSE) { genie_curses_start (p); } POP_OBJECT (p, &ch, A68_CHAR); (void) (addch ((chtype) (VALUE (&ch)))); /* if (addch ((chtype) (VALUE (&ch))) == ERR) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_CURSES_OFF_SCREEN); exit_genie (p, A68_RUNTIME_ERROR); } */ } /*! \brief PROC curses move = (INT, INT) VOID \param p position in tree **/ void genie_curses_move (NODE_T * p) { A68_INT i, j; if (a68g_curses_mode == A68_FALSE) { genie_curses_start (p); } POP_OBJECT (p, &j, A68_INT); POP_OBJECT (p, &i, A68_INT); if (VALUE (&i) < 0 || VALUE (&i) >= LINES) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_CURSES_OFF_SCREEN); exit_genie (p, A68_RUNTIME_ERROR); } if (VALUE (&j) < 0 || VALUE (&j) >= COLS) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_CURSES_OFF_SCREEN); exit_genie (p, A68_RUNTIME_ERROR); } CHECK_CURSES_RETVAL(move (VALUE (&i), VALUE (&j)) != ERR); } #endif /* HAVE_CURSES */ #if defined HAVE_REGEX_H /*! \brief return code for regex interface \param rc return code from regex routine \return 0: match, 1: no match, 2: no core, 3: other error **/ void push_grep_rc (NODE_T * p, int rc) { switch (rc) { case 0: { PUSH_PRIMITIVE (p, 0, A68_INT); return; } case REG_NOMATCH: { PUSH_PRIMITIVE (p, 1, A68_INT); return; } case REG_ESPACE: { PUSH_PRIMITIVE (p, 3, A68_INT); return; } default: { PUSH_PRIMITIVE (p, 2, A68_INT); return; } } } /*! \brief PROC grep in string = (STRING, STRING, REF INT, REF INT) INT \param p position in tree \return 0: match, 1: no match, 2: no core, 3: other error **/ void genie_grep_in_string (NODE_T * p) { A68_REF ref_pat, ref_beg, ref_end, ref_str, row; A68_ARRAY *arr; A68_TUPLE *tup; int rc, nmatch, k, max_k, widest; regex_t compiled; regmatch_t *matches; POP_REF (p, &ref_end); POP_REF (p, &ref_beg); POP_REF (p, &ref_str); POP_REF (p, &ref_pat); row = *(A68_REF *) & ref_str; CHECK_INIT (p, INITIALISED (&row), MODE (ROWS)); GET_DESCRIPTOR (arr, tup, &row); reset_transput_buffer (PATTERN_BUFFER); reset_transput_buffer (STRING_BUFFER); add_a_string_transput_buffer (p, PATTERN_BUFFER, (BYTE_T *) & ref_pat); add_a_string_transput_buffer (p, STRING_BUFFER, (BYTE_T *) & ref_str); rc = regcomp (&compiled, get_transput_buffer (PATTERN_BUFFER), REG_NEWLINE | REG_EXTENDED); if (rc != 0) { push_grep_rc (p, rc); regfree (&compiled); return; } nmatch = (int) (RE_NSUB (&compiled)); if (nmatch == 0) { nmatch = 1; } matches = malloc ((size_t) (nmatch * ALIGNED_SIZE_OF (regmatch_t))); if (nmatch > 0 && matches == NULL) { rc = 2; PUSH_PRIMITIVE (p, rc, A68_INT); regfree (&compiled); return; } rc = regexec (&compiled, get_transput_buffer (STRING_BUFFER), (size_t) nmatch, matches, 0); if (rc != 0) { push_grep_rc (p, rc); regfree (&compiled); return; } /* Find widest match. Do not assume it is the first one */ widest = 0; max_k = 0; for (k = 0; k < nmatch; k++) { int dif = (int) (RM_EO (&(matches[k]))) - (int) (RM_SO (&(matches[k]))); if (dif > widest) { widest = dif; max_k = k; } } if (!IS_NIL (ref_beg)) { A68_INT *i = DEREF (A68_INT, &ref_beg); STATUS (i) = INIT_MASK; VALUE (i) = (int) (RM_SO (&(matches[max_k]))) + (int) (LOWER_BOUND (tup)); } if (!IS_NIL (ref_end)) { A68_INT *i = DEREF (A68_INT, &ref_end); STATUS (i) = INIT_MASK; VALUE (i) = (int) (RM_EO (&(matches[max_k]))) + (int) (LOWER_BOUND (tup)) - 1; } free (matches); push_grep_rc (p, 0); } /*! \brief PROC grep in substring = (STRING, STRING, REF INT, REF INT) INT \param p position in tree \return 0: match, 1: no match, 2: no core, 3: other error **/ void genie_grep_in_substring (NODE_T * p) { A68_REF ref_pat, ref_beg, ref_end, ref_str, row; A68_ARRAY *arr; A68_TUPLE *tup; int rc, nmatch, k, max_k, widest; regex_t compiled; regmatch_t *matches; POP_REF (p, &ref_end); POP_REF (p, &ref_beg); POP_REF (p, &ref_str); POP_REF (p, &ref_pat); row = *(A68_REF *) & ref_str; CHECK_INIT (p, INITIALISED (&row), MODE (ROWS)); GET_DESCRIPTOR (arr, tup, &row); reset_transput_buffer (PATTERN_BUFFER); reset_transput_buffer (STRING_BUFFER); add_a_string_transput_buffer (p, PATTERN_BUFFER, (BYTE_T *) & ref_pat); add_a_string_transput_buffer (p, STRING_BUFFER, (BYTE_T *) & ref_str); rc = regcomp (&compiled, get_transput_buffer (PATTERN_BUFFER), REG_NEWLINE | REG_EXTENDED); if (rc != 0) { push_grep_rc (p, rc); regfree (&compiled); return; } nmatch = (int) (RE_NSUB (&compiled)); if (nmatch == 0) { nmatch = 1; } matches = malloc ((size_t) (nmatch * ALIGNED_SIZE_OF (regmatch_t))); if (nmatch > 0 && matches == NULL) { rc = 2; PUSH_PRIMITIVE (p, rc, A68_INT); regfree (&compiled); return; } rc = regexec (&compiled, get_transput_buffer (STRING_BUFFER), (size_t) nmatch, matches, REG_NOTBOL); if (rc != 0) { push_grep_rc (p, rc); regfree (&compiled); return; } /* Find widest match. Do not assume it is the first one */ widest = 0; max_k = 0; for (k = 0; k < nmatch; k++) { int dif = (int) (RM_EO (&(matches[k]))) - (int) (RM_SO (&(matches[k]))); if (dif > widest) { widest = dif; max_k = k; } } if (!IS_NIL (ref_beg)) { A68_INT *i = DEREF (A68_INT, &ref_beg); STATUS (i) = INIT_MASK; VALUE (i) = (int) (RM_SO (&(matches[max_k]))) + (int) (LOWER_BOUND (tup)); } if (!IS_NIL (ref_end)) { A68_INT *i = DEREF (A68_INT, &ref_end); STATUS (i) = INIT_MASK; VALUE (i) = (int) (RM_EO (&(matches[max_k]))) + (int) (LOWER_BOUND (tup)) - 1; } free (matches); push_grep_rc (p, 0); } /*! \brief PROC sub in string = (STRING, STRING, REF STRING) INT \param p position in tree \return 0: match, 1: no match, 2: no core, 3: other error **/ void genie_sub_in_string (NODE_T * p) { A68_REF ref_pat, ref_rep, ref_str; int rc, nmatch, k, max_k, widest, begin, end; char *txt; regex_t compiled; regmatch_t *matches; POP_REF (p, &ref_str); POP_REF (p, &ref_rep); POP_REF (p, &ref_pat); if (IS_NIL (ref_str)) { PUSH_PRIMITIVE (p, 3, A68_INT); return; } reset_transput_buffer (STRING_BUFFER); reset_transput_buffer (REPLACE_BUFFER); reset_transput_buffer (PATTERN_BUFFER); add_a_string_transput_buffer (p, PATTERN_BUFFER, (BYTE_T *) & ref_pat); add_a_string_transput_buffer (p, STRING_BUFFER, (BYTE_T *) DEREF (A68_REF, &ref_str)); rc = regcomp (&compiled, get_transput_buffer (PATTERN_BUFFER), REG_NEWLINE | REG_EXTENDED); if (rc != 0) { push_grep_rc (p, rc); regfree (&compiled); return; } nmatch = (int) (RE_NSUB (&compiled)); if (nmatch == 0) { nmatch = 1; } matches = malloc ((size_t) (nmatch * ALIGNED_SIZE_OF (regmatch_t))); if (nmatch > 0 && matches == NULL) { PUSH_PRIMITIVE (p, rc, A68_INT); regfree (&compiled); return; } rc = regexec (&compiled, get_transput_buffer (STRING_BUFFER), (size_t) nmatch, matches, 0); if (rc != 0) { push_grep_rc (p, rc); regfree (&compiled); return; } /* Find widest match. Do not assume it is the first one */ widest = 0; max_k = 0; for (k = 0; k < nmatch; k++) { int dif = (int) RM_EO (&(matches[k])) - (int) RM_SO (&(matches[k])); if (dif > widest) { widest = dif; max_k = k; } } begin = (int) RM_SO (&(matches[max_k])) + 1; end = (int) RM_EO (&(matches[max_k])); /* Substitute text */ txt = get_transput_buffer (STRING_BUFFER); for (k = 0; k < begin - 1; k++) { add_char_transput_buffer (p, REPLACE_BUFFER, txt[k]); } add_a_string_transput_buffer (p, REPLACE_BUFFER, (BYTE_T *) & ref_rep); for (k = end; k < get_transput_buffer_size (STRING_BUFFER); k++) { add_char_transput_buffer (p, REPLACE_BUFFER, txt[k]); } * DEREF (A68_REF, &ref_str) = c_to_a_string (p, get_transput_buffer (REPLACE_BUFFER), DEFAULT_WIDTH); free (matches); push_grep_rc (p, 0); } #endif /* HAVE_REGEX_H */ algol68g-2.4.1/source/code.c0000644000175000001440000054504611770152775012466 00000000000000/*! \file code.c \brief emit C code for Algol 68 constructs. */ /* This file is part of Algol68G - an Algol 68 interpreter. Copyright (C) 2001-2012 J. Marcel van der Veer . 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 generates optimised C routines for many units in an Algol 68 source program. A68G 1.x contained some general optimised routines. These are decommissioned in A68G 2.x that dynamically generates routines depending on the source code. The generated routines are compiled on the fly into a dynamic library that is linked by the running interpreter. To invoke this code generator specify option --optimise. Currently the optimiser only considers units that operate on basic modes that are contained in a single C struct, for instance primitive modes INT, REAL, BOOL, CHAR and BITS and simple structures of these basic modes, such as COMPLEX and also (single) references, rows and procedures REF MODE, [] MODE, PROC PARAMSETY MODE The code generator employs a few simple optimisations like constant folding and common subexpression elimination when DEREFERENCING or SLICING is performed; for instance x[i + 1] := x[i + 1] + 1 translates into tmp = x[i + 1]; tmp := tmp + 1 There are no optimisations that are easily recognised by the back end compiler, for instance symbolic simplification. */ /* You will find here and there lines if (DEBUG_LEVEL >= ...) which I use to debug the compiler - MvdV. 1: denotations only 2: also basic unit compilation 3: also better fetching of data from the stack 4: also compile enclosed clauses Below definition switches everything on. */ #define DEBUG_LEVEL 9 #if defined HAVE_CONFIG_H #include "a68g-config.h" #endif #include "a68g.h" #define BASIC(p, n) (basic_unit (locate ((p), (n)))) #define CON "_const" #define ELM "_elem" #define TMP "_tmp" #define ARG "_arg" #define ARR "_array" #define DEC "_declarer" #define DRF "_deref" #define DSP "_display" #define FUN "_function" #define PUP "_pop" #define REF "_ref" #define SEL "_field" #define TUP "_tuple" #define A68_MAKE_NOTHING 0 #define A68_MAKE_OTHERS 1 #define A68_MAKE_FUNCTION 2 #define OFFSET_OFF(s) (OFFSET (NODE_PACK (SUB (s)))) #define LONG_MODE(m) ((m) == MODE (LONG_INT) || (m) == MODE (LONG_REAL)) #define WIDEN_TO(p, a, b) (MOID (p) == MODE (b) && MOID (SUB (p)) == MODE (a)) #define GC_MODE(m) (m != NO_MOID && (IS (m, REF_SYMBOL) || IS (DEFLEX (m), ROW_SYMBOL))) #define NEEDS_DNS(m) (m != NO_MOID && (IS (m, REF_SYMBOL) || IS (m, PROC_SYMBOL) || IS (m, UNION_SYMBOL) || IS (m, FORMAT_SYMBOL))) #define CODE_EXECUTE(p) {\ indentf (out, snprintf (line, SNPRINTF_SIZE, "EXECUTE_UNIT_TRACE (_N_ (%d));", NUMBER (p)));\ } #define NAME_SIZE 128 static BOOL_T long_mode_allowed = A68_TRUE; static int indentation = 0; static char line[BUFFER_SIZE]; static BOOL_T basic_unit (NODE_T *); static char *compile_unit (NODE_T *, FILE_T, BOOL_T); static void inline_unit (NODE_T *, FILE_T, int); static void compile_units (NODE_T *, FILE_T); static void indent (FILE_T, char *); static void indentf (FILE_T, int); /* The phases we go through */ enum {L_NONE = 0, L_DECLARE = 1, L_INITIALISE, L_EXECUTE, L_EXECUTE_2, L_YIELD, L_PUSH}; /*********************************************************/ /* TRANSLATION tabulates translations for genie actions. */ /* This tells what to call for an A68 action. */ /*********************************************************/ typedef int LEVEL_T; typedef struct {GPROC * procedure; char * code;} TRANSLATION; static TRANSLATION monadics[] = { {genie_minus_int, "-"}, {genie_minus_real, "-"}, {genie_abs_int, "labs"}, {genie_abs_real, "fabs"}, {genie_sign_int, "SIGN"}, {genie_sign_real, "SIGN"}, {genie_entier_real, "a68g_entier"}, {genie_round_real, "a68g_round"}, {genie_not_bool, "!"}, {genie_abs_bool, "(int) "}, {genie_abs_bits, "(int) "}, {genie_bin_int, "(unsigned) "}, {genie_not_bits, "~"}, {genie_abs_char, "TO_UCHAR"}, {genie_repr_char, ""}, {genie_re_complex, "a68g_re_complex"}, {genie_im_complex, "a68g_im_complex"}, {genie_minus_complex, "a68g_minus_complex"}, {genie_abs_complex, "a68g_abs_complex"}, {genie_arg_complex, "a68g_arg_complex"}, {genie_conj_complex, "a68g_conj_complex"}, {genie_round_long_mp, "(void) round_mp"}, {genie_entier_long_mp, "(void) entier_mp"}, {genie_minus_long_mp, "(void) minus_mp"}, {genie_abs_long_mp, "(void) abs_mp"}, {genie_idle, ""}, {NO_GPROC, NO_TEXT} }; static TRANSLATION dyadics[] = { {genie_add_int, "+"}, {genie_sub_int, "-"}, {genie_mul_int, "*"}, {genie_over_int, "/"}, {genie_mod_int, "a68g_mod_int"}, {genie_div_int, "DIV_INT"}, {genie_eq_int, "=="}, {genie_ne_int, "!="}, {genie_lt_int, "<"}, {genie_gt_int, ">"}, {genie_le_int, "<="}, {genie_ge_int, ">="}, {genie_plusab_int, "a68g_plusab_int"}, {genie_minusab_int, "a68g_minusab_int"}, {genie_timesab_int, "a68g_timesab_int"}, {genie_overab_int, "a68g_overab_int"}, {genie_add_real, "+"}, {genie_sub_real, "-"}, {genie_mul_real, "*"}, {genie_div_real, "/"}, {genie_pow_real, "a68g_pow_real"}, {genie_pow_real_int, "a68g_pow_real_int"}, {genie_eq_real, "=="}, {genie_ne_real, "!="}, {genie_lt_real, "<"}, {genie_gt_real, ">"}, {genie_le_real, "<="}, {genie_ge_real, ">="}, {genie_plusab_real, "a68g_plusab_real"}, {genie_minusab_real, "a68g_minusab_real"}, {genie_timesab_real, "a68g_timesab_real"}, {genie_divab_real, "a68g_divab_real"}, {genie_eq_char, "=="}, {genie_ne_char, "!="}, {genie_lt_char, "<"}, {genie_gt_char, ">"}, {genie_le_char, "<="}, {genie_ge_char, ">="}, {genie_eq_bool, "=="}, {genie_ne_bool, "!="}, {genie_and_bool, "&&"}, {genie_or_bool, "||"}, {genie_and_bits, "&"}, {genie_or_bits, "|"}, {genie_eq_bits, "=="}, {genie_ne_bits, "!="}, {genie_shl_bits, "<<"}, {genie_shr_bits, ">>"}, {genie_icomplex, "a68g_i_complex"}, {genie_iint_complex, "a68g_i_complex"}, {genie_abs_complex, "a68g_abs_complex"}, {genie_arg_complex, "a68g_arg_complex"}, {genie_add_complex, "a68g_add_complex"}, {genie_sub_complex, "a68g_sub_complex"}, {genie_mul_complex, "a68g_mul_complex"}, {genie_div_complex, "a68g_div_complex"}, {genie_eq_complex, "a68g_eq_complex"}, {genie_ne_complex, "a68g_ne_complex"}, {genie_add_long_int, "(void) add_mp"}, {genie_add_long_mp, "(void) add_mp"}, {genie_sub_long_int, "(void) sub_mp"}, {genie_sub_long_mp, "(void) sub_mp"}, {genie_mul_long_int, "(void) mul_mp"}, {genie_mul_long_mp, "(void) mul_mp"}, {genie_over_long_mp, "(void) over_mp"}, {genie_div_long_mp, "(void) div_mp"}, {genie_eq_long_mp, "eq_mp"}, {genie_ne_long_mp, "ne_mp"}, {genie_lt_long_mp, "lt_mp"}, {genie_le_long_mp, "le_mp"}, {genie_gt_long_mp, "gt_mp"}, {genie_ge_long_mp, "ge_mp"}, {NO_GPROC, NO_TEXT} }; static TRANSLATION functions[] = { {genie_sqrt_real, "sqrt"}, {genie_curt_real, "curt"}, {genie_exp_real, "a68g_exp"}, {genie_ln_real, "log"}, {genie_log_real, "log10"}, {genie_sin_real, "sin"}, {genie_cos_real, "cos"}, {genie_tan_real, "tan"}, {genie_arcsin_real, "asin"}, {genie_arccos_real, "acos"}, {genie_arctan_real, "atan"}, {genie_sinh_real, "sinh"}, {genie_cosh_real, "cosh"}, {genie_tanh_real, "tanh"}, {genie_arcsinh_real, "a68g_asinh"}, {genie_arccosh_real, "a68g_acosh"}, {genie_arctanh_real, "a68g_atanh"}, {genie_inverf_real, "inverf"}, {genie_inverfc_real, "inverfc"}, {genie_sqrt_complex, "a68g_sqrt_complex"}, {genie_exp_complex, "a68g_exp_complex"}, {genie_ln_complex, "a68g_ln_complex"}, {genie_sin_complex, "a68g_sin_complex"}, {genie_cos_complex, "a68g_cos_complex"}, {genie_tan_complex, "a68g_tan_complex"}, {genie_arcsin_complex, "a68g_arcsin_complex"}, {genie_arccos_complex, "a68g_arccos_complex"}, {genie_arctan_complex, "a68g_arctan_complex"}, {genie_sqrt_long_mp, "(void) sqrt_mp"}, {genie_exp_long_mp, "(void) exp_mp"}, {genie_ln_long_mp, "(void) ln_mp"}, {genie_log_long_mp, "(void) log_mp"}, {genie_sin_long_mp, "(void) sin_mp"}, {genie_cos_long_mp, "(void) cos_mp"}, {genie_tan_long_mp, "(void) tan_mp"}, {genie_asin_long_mp, "(void) asin_mp"}, {genie_acos_long_mp, "(void) acos_mp"}, {genie_atan_long_mp, "(void) atan_mp"}, {genie_sinh_long_mp, "(void) sinh_mp"}, {genie_cosh_long_mp, "(void) cosh_mp"}, {genie_tanh_long_mp, "(void) tanh_mp"}, {genie_arcsinh_long_mp, "(void) asinh_mp"}, {genie_arccosh_long_mp, "(void) acosh_mp"}, {genie_arctanh_long_mp, "(void) atanh_mp"}, {NO_GPROC, NO_TEXT} }; static TRANSLATION constants[] = { {genie_int_lengths, "3"}, {genie_int_shorths, "1"}, {genie_real_lengths, "3"}, {genie_real_shorths, "1"}, {genie_complex_lengths, "3"}, {genie_complex_shorths, "1"}, {genie_bits_lengths, "3"}, {genie_bits_shorths, "1"}, {genie_bytes_lengths, "2"}, {genie_bytes_shorths, "1"}, {genie_int_width, "INT_WIDTH"}, {genie_long_int_width, "LONG_INT_WIDTH"}, {genie_longlong_int_width, "LONGLONG_INT_WIDTH"}, {genie_real_width, "REAL_WIDTH"}, {genie_long_real_width, "LONG_REAL_WIDTH"}, {genie_longlong_real_width, "LONGLONG_REAL_WIDTH"}, {genie_exp_width, "EXP_WIDTH"}, {genie_long_exp_width, "LONG_EXP_WIDTH"}, {genie_longlong_exp_width, "LONGLONG_EXP_WIDTH"}, {genie_bits_width, "BITS_WIDTH"}, {genie_bytes_width, "BYTES_WIDTH"}, {genie_long_bytes_width, "LONG_BYTES_WIDTH"}, {genie_max_abs_char, "UCHAR_MAX"}, {genie_max_int, "A68_MAX_INT"}, {genie_max_real, "DBL_MAX"}, {genie_min_real, "DBL_MIN"}, {genie_null_char, "NULL_CHAR"}, {genie_small_real, "DBL_EPSILON"}, {genie_pi, "A68_PI"}, {genie_pi_long_mp, NO_TEXT}, {genie_long_max_int, NO_TEXT}, {genie_long_min_real, NO_TEXT}, {genie_long_small_real, NO_TEXT}, {genie_long_max_real, NO_TEXT}, {genie_cgs_acre, "GSL_CONST_CGSM_ACRE"}, {genie_cgs_angstrom, "GSL_CONST_CGSM_ANGSTROM"}, {genie_cgs_astronomical_unit, "GSL_CONST_CGSM_ASTRONOMICAL_UNIT"}, {genie_cgs_bar, "GSL_CONST_CGSM_BAR"}, {genie_cgs_barn, "GSL_CONST_CGSM_BARN"}, {genie_cgs_bohr_magneton, "GSL_CONST_CGSM_BOHR_MAGNETON"}, {genie_cgs_bohr_radius, "GSL_CONST_CGSM_BOHR_RADIUS"}, {genie_cgs_boltzmann, "GSL_CONST_CGSM_BOLTZMANN"}, {genie_cgs_btu, "GSL_CONST_CGSM_BTU"}, {genie_cgs_calorie, "GSL_CONST_CGSM_CALORIE"}, {genie_cgs_canadian_gallon, "GSL_CONST_CGSM_CANADIAN_GALLON"}, {genie_cgs_carat, "GSL_CONST_CGSM_CARAT"}, {genie_cgs_cup, "GSL_CONST_CGSM_CUP"}, {genie_cgs_curie, "GSL_CONST_CGSM_CURIE"}, {genie_cgs_day, "GSL_CONST_CGSM_DAY"}, {genie_cgs_dyne, "GSL_CONST_CGSM_DYNE"}, {genie_cgs_electron_charge, "GSL_CONST_CGSM_ELECTRON_CHARGE"}, {genie_cgs_electron_magnetic_moment, "GSL_CONST_CGSM_ELECTRON_MAGNETIC_MOMENT"}, {genie_cgs_electron_volt, "GSL_CONST_CGSM_ELECTRON_VOLT"}, {genie_cgs_erg, "GSL_CONST_CGSM_ERG"}, {genie_cgs_faraday, "GSL_CONST_CGSM_FARADAY"}, {genie_cgs_fathom, "GSL_CONST_CGSM_FATHOM"}, {genie_cgs_fluid_ounce, "GSL_CONST_CGSM_FLUID_OUNCE"}, {genie_cgs_foot, "GSL_CONST_CGSM_FOOT"}, {genie_cgs_footcandle, "GSL_CONST_CGSM_FOOTCANDLE"}, {genie_cgs_footlambert, "GSL_CONST_CGSM_FOOTLAMBERT"}, {genie_cgs_gauss, "GSL_CONST_CGSM_GAUSS"}, {genie_cgs_gram_force, "GSL_CONST_CGSM_GRAM_FORCE"}, {genie_cgs_grav_accel, "GSL_CONST_CGSM_GRAV_ACCEL"}, {genie_cgs_gravitational_constant, "GSL_CONST_CGSM_GRAVITATIONAL_CONSTANT"}, {genie_cgs_hectare, "GSL_CONST_CGSM_HECTARE"}, {genie_cgs_horsepower, "GSL_CONST_CGSM_HORSEPOWER"}, {genie_cgs_hour, "GSL_CONST_CGSM_HOUR"}, {genie_cgs_inch, "GSL_CONST_CGSM_INCH"}, {genie_cgs_inch_of_mercury, "GSL_CONST_CGSM_INCH_OF_MERCURY"}, {genie_cgs_inch_of_water, "GSL_CONST_CGSM_INCH_OF_WATER"}, {genie_cgs_joule, "GSL_CONST_CGSM_JOULE"}, {genie_cgs_kilometers_per_hour, "GSL_CONST_CGSM_KILOMETERS_PER_HOUR"}, {genie_cgs_kilopound_force, "GSL_CONST_CGSM_KILOPOUND_FORCE"}, {genie_cgs_knot, "GSL_CONST_CGSM_KNOT"}, {genie_cgs_lambert, "GSL_CONST_CGSM_LAMBERT"}, {genie_cgs_light_year, "GSL_CONST_CGSM_LIGHT_YEAR"}, {genie_cgs_liter, "GSL_CONST_CGSM_LITER"}, {genie_cgs_lumen, "GSL_CONST_CGSM_LUMEN"}, {genie_cgs_lux, "GSL_CONST_CGSM_LUX"}, {genie_cgs_mass_electron, "GSL_CONST_CGSM_MASS_ELECTRON"}, {genie_cgs_mass_muon, "GSL_CONST_CGSM_MASS_MUON"}, {genie_cgs_mass_neutron, "GSL_CONST_CGSM_MASS_NEUTRON"}, {genie_cgs_mass_proton, "GSL_CONST_CGSM_MASS_PROTON"}, {genie_cgs_meter_of_mercury, "GSL_CONST_CGSM_METER_OF_MERCURY"}, {genie_cgs_metric_ton, "GSL_CONST_CGSM_METRIC_TON"}, {genie_cgs_micron, "GSL_CONST_CGSM_MICRON"}, {genie_cgs_mil, "GSL_CONST_CGSM_MIL"}, {genie_cgs_mile, "GSL_CONST_CGSM_MILE"}, {genie_cgs_miles_per_hour, "GSL_CONST_CGSM_MILES_PER_HOUR"}, {genie_cgs_minute, "GSL_CONST_CGSM_MINUTE"}, {genie_cgs_molar_gas, "GSL_CONST_CGSM_MOLAR_GAS"}, {genie_cgs_nautical_mile, "GSL_CONST_CGSM_NAUTICAL_MILE"}, {genie_cgs_newton, "GSL_CONST_CGSM_NEWTON"}, {genie_cgs_nuclear_magneton, "GSL_CONST_CGSM_NUCLEAR_MAGNETON"}, {genie_cgs_ounce_mass, "GSL_CONST_CGSM_OUNCE_MASS"}, {genie_cgs_parsec, "GSL_CONST_CGSM_PARSEC"}, {genie_cgs_phot, "GSL_CONST_CGSM_PHOT"}, {genie_cgs_pint, "GSL_CONST_CGSM_PINT"}, {genie_cgs_planck_constant_h, "6.6260693e-27"}, {genie_cgs_planck_constant_hbar, "1.0545717e-27"}, {genie_cgs_point, "GSL_CONST_CGSM_POINT"}, {genie_cgs_poise, "GSL_CONST_CGSM_POISE"}, {genie_cgs_pound_force, "GSL_CONST_CGSM_POUND_FORCE"}, {genie_cgs_pound_mass, "GSL_CONST_CGSM_POUND_MASS"}, {genie_cgs_poundal, "GSL_CONST_CGSM_POUNDAL"}, {genie_cgs_proton_magnetic_moment, "GSL_CONST_CGSM_PROTON_MAGNETIC_MOMENT"}, {genie_cgs_psi, "GSL_CONST_CGSM_PSI"}, {genie_cgs_quart, "GSL_CONST_CGSM_QUART"}, {genie_cgs_rad, "GSL_CONST_CGSM_RAD"}, {genie_cgs_roentgen, "GSL_CONST_CGSM_ROENTGEN"}, {genie_cgs_rydberg, "GSL_CONST_CGSM_RYDBERG"}, {genie_cgs_solar_mass, "GSL_CONST_CGSM_SOLAR_MASS"}, {genie_cgs_speed_of_light, "GSL_CONST_CGSM_SPEED_OF_LIGHT"}, {genie_cgs_standard_gas_volume, "GSL_CONST_CGSM_STANDARD_GAS_VOLUME"}, {genie_cgs_std_atmosphere, "GSL_CONST_CGSM_STD_ATMOSPHERE"}, {genie_cgs_stilb, "GSL_CONST_CGSM_STILB"}, {genie_cgs_stokes, "GSL_CONST_CGSM_STOKES"}, {genie_cgs_tablespoon, "GSL_CONST_CGSM_TABLESPOON"}, {genie_cgs_teaspoon, "GSL_CONST_CGSM_TEASPOON"}, {genie_cgs_texpoint, "GSL_CONST_CGSM_TEXPOINT"}, {genie_cgs_therm, "GSL_CONST_CGSM_THERM"}, {genie_cgs_ton, "GSL_CONST_CGSM_TON"}, {genie_cgs_torr, "GSL_CONST_CGSM_TORR"}, {genie_cgs_troy_ounce, "GSL_CONST_CGSM_TROY_OUNCE"}, {genie_cgs_uk_gallon, "GSL_CONST_CGSM_UK_GALLON"}, {genie_cgs_uk_ton, "GSL_CONST_CGSM_UK_TON"}, {genie_cgs_unified_atomic_mass, "GSL_CONST_CGSM_UNIFIED_ATOMIC_MASS"}, {genie_cgs_us_gallon, "GSL_CONST_CGSM_US_GALLON"}, {genie_cgs_week, "GSL_CONST_CGSM_WEEK"}, {genie_cgs_yard, "GSL_CONST_CGSM_YARD"}, {genie_mks_acre, "GSL_CONST_MKS_ACRE"}, {genie_mks_angstrom, "GSL_CONST_MKS_ANGSTROM"}, {genie_mks_astronomical_unit, "GSL_CONST_MKS_ASTRONOMICAL_UNIT"}, {genie_mks_bar, "GSL_CONST_MKS_BAR"}, {genie_mks_barn, "GSL_CONST_MKS_BARN"}, {genie_mks_bohr_magneton, "GSL_CONST_MKS_BOHR_MAGNETON"}, {genie_mks_bohr_radius, "GSL_CONST_MKS_BOHR_RADIUS"}, {genie_mks_boltzmann, "GSL_CONST_MKS_BOLTZMANN"}, {genie_mks_btu, "GSL_CONST_MKS_BTU"}, {genie_mks_calorie, "GSL_CONST_MKS_CALORIE"}, {genie_mks_canadian_gallon, "GSL_CONST_MKS_CANADIAN_GALLON"}, {genie_mks_carat, "GSL_CONST_MKS_CARAT"}, {genie_mks_cup, "GSL_CONST_MKS_CUP"}, {genie_mks_curie, "GSL_CONST_MKS_CURIE"}, {genie_mks_day, "GSL_CONST_MKS_DAY"}, {genie_mks_dyne, "GSL_CONST_MKS_DYNE"}, {genie_mks_electron_charge, "GSL_CONST_MKS_ELECTRON_CHARGE"}, {genie_mks_electron_magnetic_moment, "GSL_CONST_MKS_ELECTRON_MAGNETIC_MOMENT"}, {genie_mks_electron_volt, "GSL_CONST_MKS_ELECTRON_VOLT"}, {genie_mks_erg, "GSL_CONST_MKS_ERG"}, {genie_mks_faraday, "GSL_CONST_MKS_FARADAY"}, {genie_mks_fathom, "GSL_CONST_MKS_FATHOM"}, {genie_mks_fluid_ounce, "GSL_CONST_MKS_FLUID_OUNCE"}, {genie_mks_foot, "GSL_CONST_MKS_FOOT"}, {genie_mks_footcandle, "GSL_CONST_MKS_FOOTCANDLE"}, {genie_mks_footlambert, "GSL_CONST_MKS_FOOTLAMBERT"}, {genie_mks_gauss, "GSL_CONST_MKS_GAUSS"}, {genie_mks_gram_force, "GSL_CONST_MKS_GRAM_FORCE"}, {genie_mks_grav_accel, "GSL_CONST_MKS_GRAV_ACCEL"}, {genie_mks_gravitational_constant, "GSL_CONST_MKS_GRAVITATIONAL_CONSTANT"}, {genie_mks_hectare, "GSL_CONST_MKS_HECTARE"}, {genie_mks_horsepower, "GSL_CONST_MKS_HORSEPOWER"}, {genie_mks_hour, "GSL_CONST_MKS_HOUR"}, {genie_mks_inch, "GSL_CONST_MKS_INCH"}, {genie_mks_inch_of_mercury, "GSL_CONST_MKS_INCH_OF_MERCURY"}, {genie_mks_inch_of_water, "GSL_CONST_MKS_INCH_OF_WATER"}, {genie_mks_joule, "GSL_CONST_MKS_JOULE"}, {genie_mks_kilometers_per_hour, "GSL_CONST_MKS_KILOMETERS_PER_HOUR"}, {genie_mks_kilopound_force, "GSL_CONST_MKS_KILOPOUND_FORCE"}, {genie_mks_knot, "GSL_CONST_MKS_KNOT"}, {genie_mks_lambert, "GSL_CONST_MKS_LAMBERT"}, {genie_mks_light_year, "GSL_CONST_MKS_LIGHT_YEAR"}, {genie_mks_liter, "GSL_CONST_MKS_LITER"}, {genie_mks_lumen, "GSL_CONST_MKS_LUMEN"}, {genie_mks_lux, "GSL_CONST_MKS_LUX"}, {genie_mks_mass_electron, "GSL_CONST_MKS_MASS_ELECTRON"}, {genie_mks_mass_muon, "GSL_CONST_MKS_MASS_MUON"}, {genie_mks_mass_neutron, "GSL_CONST_MKS_MASS_NEUTRON"}, {genie_mks_mass_proton, "GSL_CONST_MKS_MASS_PROTON"}, {genie_mks_meter_of_mercury, "GSL_CONST_MKS_METER_OF_MERCURY"}, {genie_mks_metric_ton, "GSL_CONST_MKS_METRIC_TON"}, {genie_mks_micron, "GSL_CONST_MKS_MICRON"}, {genie_mks_mil, "GSL_CONST_MKS_MIL"}, {genie_mks_mile, "GSL_CONST_MKS_MILE"}, {genie_mks_miles_per_hour, "GSL_CONST_MKS_MILES_PER_HOUR"}, {genie_mks_minute, "GSL_CONST_MKS_MINUTE"}, {genie_mks_molar_gas, "GSL_CONST_MKS_MOLAR_GAS"}, {genie_mks_nautical_mile, "GSL_CONST_MKS_NAUTICAL_MILE"}, {genie_mks_newton, "GSL_CONST_MKS_NEWTON"}, {genie_mks_nuclear_magneton, "GSL_CONST_MKS_NUCLEAR_MAGNETON"}, {genie_mks_ounce_mass, "GSL_CONST_MKS_OUNCE_MASS"}, {genie_mks_parsec, "GSL_CONST_MKS_PARSEC"}, {genie_mks_phot, "GSL_CONST_MKS_PHOT"}, {genie_mks_pint, "GSL_CONST_MKS_PINT"}, {genie_mks_planck_constant_h, "6.6260693e-34"}, {genie_mks_planck_constant_hbar, "1.0545717e-34"}, {genie_mks_point, "GSL_CONST_MKS_POINT"}, {genie_mks_poise, "GSL_CONST_MKS_POISE"}, {genie_mks_pound_force, "GSL_CONST_MKS_POUND_FORCE"}, {genie_mks_pound_mass, "GSL_CONST_MKS_POUND_MASS"}, {genie_mks_poundal, "GSL_CONST_MKS_POUNDAL"}, {genie_mks_proton_magnetic_moment, "GSL_CONST_MKS_PROTON_MAGNETIC_MOMENT"}, {genie_mks_psi, "GSL_CONST_MKS_PSI"}, {genie_mks_quart, "GSL_CONST_MKS_QUART"}, {genie_mks_rad, "GSL_CONST_MKS_RAD"}, {genie_mks_roentgen, "GSL_CONST_MKS_ROENTGEN"}, {genie_mks_rydberg, "GSL_CONST_MKS_RYDBERG"}, {genie_mks_solar_mass, "GSL_CONST_MKS_SOLAR_MASS"}, {genie_mks_speed_of_light, "GSL_CONST_MKS_SPEED_OF_LIGHT"}, {genie_mks_standard_gas_volume, "GSL_CONST_MKS_STANDARD_GAS_VOLUME"}, {genie_mks_std_atmosphere, "GSL_CONST_MKS_STD_ATMOSPHERE"}, {genie_mks_stilb, "GSL_CONST_MKS_STILB"}, {genie_mks_stokes, "GSL_CONST_MKS_STOKES"}, {genie_mks_tablespoon, "GSL_CONST_MKS_TABLESPOON"}, {genie_mks_teaspoon, "GSL_CONST_MKS_TEASPOON"}, {genie_mks_texpoint, "GSL_CONST_MKS_TEXPOINT"}, {genie_mks_therm, "GSL_CONST_MKS_THERM"}, {genie_mks_ton, "GSL_CONST_MKS_TON"}, {genie_mks_torr, "GSL_CONST_MKS_TORR"}, {genie_mks_troy_ounce, "GSL_CONST_MKS_TROY_OUNCE"}, {genie_mks_uk_gallon, "GSL_CONST_MKS_UK_GALLON"}, {genie_mks_uk_ton, "GSL_CONST_MKS_UK_TON"}, {genie_mks_unified_atomic_mass, "GSL_CONST_MKS_UNIFIED_ATOMIC_MASS"}, {genie_mks_us_gallon, "GSL_CONST_MKS_US_GALLON"}, {genie_mks_vacuum_permeability, "GSL_CONST_MKS_VACUUM_PERMEABILITY"}, {genie_mks_vacuum_permittivity, "GSL_CONST_MKS_VACUUM_PERMITTIVITY"}, {genie_mks_week, "GSL_CONST_MKS_WEEK"}, {genie_mks_yard, "GSL_CONST_MKS_YARD"}, {genie_num_atto, "GSL_CONST_NUM_ATTO"}, {genie_num_avogadro, "GSL_CONST_NUM_AVOGADRO"}, {genie_num_exa, "GSL_CONST_NUM_EXA"}, {genie_num_femto, "GSL_CONST_NUM_FEMTO"}, {genie_num_fine_structure, "GSL_CONST_NUM_FINE_STRUCTURE"}, {genie_num_giga, "GSL_CONST_NUM_GIGA"}, {genie_num_kilo, "GSL_CONST_NUM_KILO"}, {genie_num_mega, "GSL_CONST_NUM_MEGA"}, {genie_num_micro, "GSL_CONST_NUM_MICRO"}, {genie_num_milli, "GSL_CONST_NUM_MILLI"}, {genie_num_nano, "GSL_CONST_NUM_NANO"}, {genie_num_peta, "GSL_CONST_NUM_PETA"}, {genie_num_pico, "GSL_CONST_NUM_PICO"}, {genie_num_tera, "GSL_CONST_NUM_TERA"}, {genie_num_yocto, "GSL_CONST_NUM_YOCTO"}, {genie_num_yotta, "GSL_CONST_NUM_YOTTA"}, {genie_num_zepto, "GSL_CONST_NUM_ZEPTO"}, {genie_num_zetta, "GSL_CONST_NUM_ZETTA"}, {NO_GPROC, NO_TEXT} }; /**************************/ /* Pretty printing stuff. */ /**************************/ /*! \brief write indented text \param out output file descriptor \param str text **/ static void indent (FILE_T out, char *str) { int j = indentation; if (out == 0) { return; } while (j -- > 0) { WRITE (out, " "); } WRITE (out, str); } /*! \brief write unindented text \param out output file descriptor \param str text **/ static void undent (FILE_T out, char *str) { if (out == 0) { return; } WRITE (out, str); } /*! \brief write indent text \param out output file descriptor \param ret bytes written by snprintf **/ static void indentf (FILE_T out, int ret) { if (out == 0) { return; } if (ret >= 0) { indent (out, line); } else { ABEND(A68_TRUE, "Return value failure", error_specification ()); } } /*! \brief write unindent text \param out output file descriptor \param ret bytes written by snprintf **/ static void undentf (FILE_T out, int ret) { if (out == 0) { return; } if (ret >= 0) { WRITE (out, line); } else { ABEND(A68_TRUE, "Return value failure", error_specification ()); } } /*************************************/ /* Administration of C declarations */ /* Pretty printing of C declarations */ /*************************************/ /*! \brief add declaration to a tree \param p top token \param t token text \return new entry **/ typedef struct DEC_T DEC_T; struct DEC_T { char *text; int level; DEC_T *sub, *less, *more; }; static DEC_T *root_idf = NO_DEC; /*! \brief add declaration to a tree \param p top declaration \param idf identifier name \return new entry **/ DEC_T *add_identifier (DEC_T ** p, int level, char *idf) { char *z = new_temp_string (idf); while (*p != NO_DEC) { int k = strcmp (z, TEXT (*p)); if (k < 0) { p = &LESS (*p); } else if (k > 0) { p = &MORE (*p); } else { ABEND(A68_TRUE, "duplicate declaration", z); return (*p); } } *p = (DEC_T *) get_temp_heap_space ((size_t) ALIGNED_SIZE_OF (DEC_T)); TEXT (*p) = z; LEVEL (*p) = level; SUB (*p) = LESS (*p) = MORE (*p) = NO_DEC; return (*p); } /*! \brief add declaration to a tree \param p top declaration \param mode mode for identifier \param idf identifier name \return new entry **/ DEC_T *add_declaration (DEC_T ** p, char *mode, int level, char *idf) { char *z = new_temp_string (mode); while (*p != NO_DEC) { int k = strcmp (z, TEXT (*p)); if (k < 0) { p = &LESS (*p); } else if (k > 0) { p = &MORE (*p); } else { (void) add_identifier(&SUB(*p), level, idf); return (*p); } } *p = (DEC_T *) get_temp_heap_space ((size_t) ALIGNED_SIZE_OF (DEC_T)); TEXT (*p) = z; LEVEL (*p) = -1; SUB (*p) = LESS (*p) = MORE (*p) = NO_DEC; (void) add_identifier(&SUB(*p), level, idf); return (*p); } static BOOL_T put_idf_comma = A68_TRUE; /*! \brief print identifiers (following mode) \param out file to print to \param p top token **/ void print_identifiers (FILE_T out, DEC_T *p) { if (p != NO_DEC) { print_identifiers (out, LESS (p)); if (put_idf_comma) { WRITE (out, ", "); } else { put_idf_comma = A68_TRUE; } if (LEVEL (p) > 0) { int k = LEVEL (p); while (k--) { WRITE (out, "*"); } WRITE (out, " "); } WRITE (out, TEXT (p)); print_identifiers (out, MORE (p)); } } /*! \brief print declarations \param out file to print to \param p top token **/ void print_declarations (FILE_T out, DEC_T *p) { if (p != NO_DEC) { print_declarations (out, LESS (p)); indent (out, TEXT (p)); WRITE (out, " "); put_idf_comma = A68_FALSE; print_identifiers (out, SUB (p)); WRITELN (out, ";\n") print_declarations (out, MORE (p)); } } /***************************************************************************/ /* Administration for common (sub) expression elimination. */ /* BOOK keeps track of already seen (temporary) variables and denotations. */ /***************************************************************************/ typedef struct { int action, phase; char * idf; void * info; int number; } BOOK_T; enum {BOOK_NONE = 0, BOOK_DECL, BOOK_INIT, BOOK_DEREF, BOOK_ARRAY, BOOK_COMPILE}; #define MAX_BOOK 1024 BOOK_T temp_book[MAX_BOOK]; int temp_book_pointer; /*! \brief book identifier to keep track of it for CSE \param number number given to it \param action some identification as L_DECLARE or DEREFERENCING \param phase phase in which booking is made **/ static void sign_in (int action, int phase, char * idf, void * info, int number) { if (temp_book_pointer < MAX_BOOK) { ACTION (&temp_book[temp_book_pointer]) = action; PHASE (&temp_book[temp_book_pointer]) = phase; IDF (&temp_book[temp_book_pointer]) = idf; INFO (&temp_book[temp_book_pointer]) = info; NUMBER (&temp_book[temp_book_pointer]) = number; temp_book_pointer ++; } } /*! \brief whether identifier is signed_in \param action some identification as L_DECLARE or DEREFERENCING \param phase phase in which booking is made \return number given to it **/ static BOOK_T * signed_in (int action, int phase, char * idf) { int k; for (k = 0; k < temp_book_pointer; k ++) { if (IDF (&temp_book[k]) == idf && ACTION (&temp_book[k]) == action && PHASE (&temp_book[k]) >= phase) { return (& (temp_book[k])); } } return (NO_BOOK); } /*! \brief make name \param buf output buffer \param name appropriate name \param n distinghuising number \return output buffer **/ static char * make_name (char * buf, char * name, char * tag, int n) { if (strlen (tag) > 0) { ASSERT (snprintf (buf, NAME_SIZE, "%s_%s_%d", name, tag, n) >= 0); } else { ASSERT (snprintf (buf, NAME_SIZE, "%s_%d", name, n) >= 0); } ABEND (strlen (buf) >= NAME_SIZE, "make name error", NO_TEXT); return (buf); } /*! \brief whether two sub-trees are the same Algol 68 construct \param l left-hand tree \param r right-hand tree \return same **/ static BOOL_T same_tree (NODE_T * l, NODE_T *r) { if (l == NO_NODE) { return ((BOOL_T) (r == NO_NODE)); } else if (r == NO_NODE) { return ((BOOL_T) (l == NO_NODE)); } else if (ATTRIBUTE (l) == ATTRIBUTE (r) && NSYMBOL (l) == NSYMBOL (r)) { return ((BOOL_T) (same_tree (SUB (l), SUB (r)) && same_tree (NEXT (l), NEXT (r)))); } else { return (A68_FALSE); } } /********************/ /* Basic mode check */ /********************/ /*! \brief whether primitive mode, with simple C equivalent \param m mode to check \return same **/ static BOOL_T primitive_mode (MOID_T * m) { if (m == MODE (INT)) { return (A68_TRUE); } else if (m == MODE (REAL)) { return (A68_TRUE); } else if (m == MODE (BOOL)) { return (A68_TRUE); } else if (m == MODE (CHAR)) { return (A68_TRUE); } else if (m == MODE (BITS)) { return (A68_TRUE); } else { return (A68_FALSE); } } /*! \brief whether mode for which denotations are compiled \param m mode to check \return same **/ static BOOL_T denotation_mode (MOID_T * m) { if (primitive_mode (m)) { return (A68_TRUE); } else if (LONG_MODE (m) && long_mode_allowed) { return (A68_TRUE); } else { return (A68_FALSE); } } /*! \brief whether mode is handled by the constant folder \param m mode to check \return same **/ BOOL_T folder_mode (MOID_T * m) { if (primitive_mode (m)) { return (A68_TRUE); } else if (m == MODE (COMPLEX)) { return (A68_TRUE); } else if (LONG_MODE (m)) { return (A68_TRUE); } else { return (A68_FALSE); } } /*! \brief whether basic mode, for which units are compiled \param m mode to check \return same **/ static BOOL_T basic_mode (MOID_T * m) { if (denotation_mode (m)) { return (A68_TRUE); } else if (IS (m, REF_SYMBOL)) { if (IS (SUB (m), REF_SYMBOL) || IS (SUB (m), PROC_SYMBOL)) { return (A68_FALSE); } else { return (basic_mode (SUB (m))); } } else if (IS (m, ROW_SYMBOL)) { if (primitive_mode (SUB (m))) { return (A68_TRUE); } else if (IS (SUB (m), STRUCT_SYMBOL)) { return (basic_mode (SUB (m))); } else { return (A68_FALSE); } } else if (IS (m, STRUCT_SYMBOL)) { PACK_T *p = PACK (m); for (; p != NO_PACK; FORWARD (p)) { if (!primitive_mode (MOID (p))) { return (A68_FALSE); } } return (A68_TRUE); } else { return (A68_FALSE); } } /*! \brief whether basic mode, which is not a row \param m mode to check \return same **/ static BOOL_T basic_mode_non_row (MOID_T * m) { if (denotation_mode (m)) { return (A68_TRUE); } else if (IS (m, REF_SYMBOL)) { if (IS (SUB (m), REF_SYMBOL) || IS (SUB (m), PROC_SYMBOL)) { return (A68_FALSE); } else { return (basic_mode_non_row (SUB (m))); } } else if (IS (m, STRUCT_SYMBOL)) { PACK_T *p = PACK (m); for (; p != NO_PACK; FORWARD (p)) { if (!primitive_mode (MOID (p))) { return (A68_FALSE); } } return (A68_TRUE); } else { return (A68_FALSE); } } /*! \brief whether stems from certain attribute \param p position in tree \param att attribute to comply to \return same **/ static NODE_T * locate (NODE_T * p, int att) { if (IS (p, VOIDING)) { return (locate (SUB (p), att)); } else if (IS (p, UNIT)) { return (locate (SUB (p), att)); } else if (IS (p, TERTIARY)) { return (locate (SUB (p), att)); } else if (IS (p, SECONDARY)) { return (locate (SUB (p), att)); } else if (IS (p, PRIMARY)) { return (locate (SUB (p), att)); } else if (IS (p, att)) { return (p); } else { return (NO_NODE); } } /**********************************************************/ /* Basic unit check */ /* Whether a unit is sufficiently "basic" to be compiled. */ /**********************************************************/ /*! \brief whether basic collateral clause \param p position in tree \return same **/ static BOOL_T basic_collateral (NODE_T * p) { if (p == NO_NODE) { return (A68_TRUE); } else if (IS (p, UNIT)) { return ((BOOL_T) (basic_mode (MOID (p)) && basic_unit (SUB (p)) && basic_collateral (NEXT (p)))); } else { return ((BOOL_T) (basic_collateral (SUB (p)) && basic_collateral (NEXT (p)))); } } /*! \brief whether basic serial clause \param p position in tree \return same **/ static void count_basic_units (NODE_T * p, int * total, int * good) { for (; p != NO_NODE; FORWARD (p)) { if (IS (p, UNIT)) { (* total) ++; if (basic_unit (p)) { (* good) ++; } } else if (IS (p, DECLARATION_LIST)) { (* total) ++; } else { count_basic_units (SUB (p), total, good); } } } /*! \brief whether basic serial clause \param p position in tree \param want > 0 is how many units we allow, <= 0 is don't care \return same **/ static BOOL_T basic_serial (NODE_T * p, int want) { int total = 0, good = 0; count_basic_units (p, &total, &good); if (want > 0) { return (total == want && total == good); } else { return (total == good); } } /*! \brief whether basic indexer \param p position in tree \return same **/ static BOOL_T basic_indexer (NODE_T * p) { if (p == NO_NODE) { return (A68_TRUE); } else if (IS (p, TRIMMER)) { return (A68_FALSE); } else if (IS (p, UNIT)) { return (basic_unit (p)); } else { return ((BOOL_T) (basic_indexer (SUB (p)) && basic_indexer (NEXT (p)))); } } /*! \brief whether basic slice \param p starting node \return same **/ static BOOL_T basic_slice (NODE_T * p) { if (IS (p, SLICE)) { NODE_T * prim = SUB (p); NODE_T * idf = locate (prim, IDENTIFIER); if (idf != NO_NODE) { NODE_T * indx = NEXT (prim); return (basic_indexer (indx)); } } return (A68_FALSE); } /*! \brief whether basic argument \param p starting node \return same **/ static BOOL_T basic_argument (NODE_T * p) { if (p == NO_NODE) { return (A68_TRUE); } else if (IS (p, UNIT)) { return ((BOOL_T) (basic_mode (MOID (p)) && basic_unit (p) && basic_argument (NEXT (p)))); } else { return ((BOOL_T) (basic_argument (SUB (p)) && basic_argument (NEXT (p)))); } } /*! \brief whether basic call \param p starting node \return same **/ static BOOL_T basic_call (NODE_T * p) { if (IS (p, CALL)) { NODE_T * prim = SUB (p); NODE_T * idf = locate (prim, IDENTIFIER); if (idf == NO_NODE) { return (A68_FALSE); } else if (SUB_MOID (idf) == MOID (p)) { /* Prevent partial parametrisation */ int k; for (k = 0; PROCEDURE (&functions[k]) != NO_GPROC; k ++) { if (PROCEDURE (TAX (idf)) == PROCEDURE (&functions[k])) { NODE_T * args = NEXT (prim); return (basic_argument (args)); } } } } return (A68_FALSE); } /*! \brief whether basic monadic formula \param p starting node \return same **/ static BOOL_T basic_monadic_formula (NODE_T * p) { if (IS (p, MONADIC_FORMULA)) { NODE_T * op = SUB (p); int k; for (k = 0; PROCEDURE (&monadics[k]) != NO_GPROC; k ++) { if (PROCEDURE (TAX (op)) == PROCEDURE (&monadics[k])) { NODE_T * rhs = NEXT (op); return (basic_unit (rhs)); } } } return (A68_FALSE); } /*! \brief whether basic dyadic formula \param p starting node \return same **/ static BOOL_T basic_formula (NODE_T * p) { if (IS (p, FORMULA)) { NODE_T * lhs = SUB (p); NODE_T * op = NEXT (lhs); if (op == NO_NODE) { return (basic_monadic_formula (lhs)); } else { int k; for (k = 0; PROCEDURE (&dyadics[k]) != NO_GPROC; k ++) { if (PROCEDURE (TAX (op)) == PROCEDURE (&dyadics[k])) { NODE_T * rhs = NEXT (op); return ((BOOL_T) (basic_unit (lhs) && basic_unit (rhs))); } } } } return (A68_FALSE); } /*! \brief whether basic conditional clause \param p starting node \return same **/ static BOOL_T basic_conditional (NODE_T * p) { if (! (IS (p, IF_PART) || IS (p, OPEN_PART))) { return (A68_FALSE); } if (! basic_serial (NEXT_SUB (p), 1)) { return (A68_FALSE); } FORWARD (p); if (! (IS (p, THEN_PART) || IS (p, CHOICE))) { return (A68_FALSE); } if (! basic_serial (NEXT_SUB (p), 1)) { return (A68_FALSE); } FORWARD (p); if (IS (p, ELSE_PART) || IS (p, CHOICE)) { return (basic_serial (NEXT_SUB (p), 1)); } else if (IS (p, FI_SYMBOL)) { return (A68_TRUE); } else { return (A68_FALSE); } } /*! \brief whether basic unit \param p starting node \return same **/ static BOOL_T basic_unit (NODE_T * p) { if (p == NO_NODE) { return (A68_FALSE); } else if (IS (p, UNIT)) { return (basic_unit (SUB (p))); } else if (IS (p, TERTIARY)) { return (basic_unit (SUB (p))); } else if (IS (p, SECONDARY)) { return (basic_unit (SUB (p))); } else if (IS (p, PRIMARY)) { return (basic_unit (SUB (p))); } else if (IS (p, ENCLOSED_CLAUSE)) { return (basic_unit (SUB (p))); } else if (IS (p, CLOSED_CLAUSE)) { return (basic_serial (NEXT_SUB (p), 1)); } else if (IS (p, COLLATERAL_CLAUSE)) { return (basic_mode (MOID (p)) && basic_collateral (NEXT_SUB (p))); } else if (IS (p, CONDITIONAL_CLAUSE)) { return (basic_mode (MOID (p)) && basic_conditional (SUB (p))); } else if (IS (p, VOIDING) && IS (SUB (p), ASSIGNATION) && locate (SUB_SUB (p), IDENTIFIER) != NO_NODE) { NODE_T * dst = SUB_SUB (p); NODE_T * src = NEXT_NEXT (dst); return ((BOOL_T) basic_unit (src) && basic_mode_non_row (MOID (src))); } else if (IS (p, VOIDING) && IS (SUB (p), ASSIGNATION) && locate (SUB_SUB (p), SLICE) != NO_NODE) { NODE_T * dst = SUB_SUB (p); NODE_T * src = NEXT_NEXT (dst); NODE_T * slice = locate (dst, SLICE); return ((BOOL_T) (IS (MOID (slice), REF_SYMBOL) && basic_slice (slice) && basic_unit (src) && basic_mode_non_row (MOID (src)))); } else if (IS (p, VOIDING) && IS (SUB (p), ASSIGNATION) && locate (SUB_SUB (p), SELECTION) != NO_NODE) { NODE_T * dst = SUB_SUB (p); NODE_T * src = NEXT_NEXT (dst); return ((BOOL_T) (locate (NEXT_SUB (locate (dst, SELECTION)), IDENTIFIER) != NO_NODE && basic_unit (src) && basic_mode_non_row (MOID (dst)))); } else if (IS (p, VOIDING)) { return (basic_unit (SUB (p))); } else if (IS (p, DEREFERENCING) && locate (SUB (p), IDENTIFIER)) { return ((BOOL_T) (basic_mode (MOID (p)) && BASIC (SUB (p), IDENTIFIER))); } else if (IS (p, DEREFERENCING) && locate (SUB (p), SLICE)) { NODE_T * slice = locate (SUB (p), SLICE); return ((BOOL_T) (basic_mode (MOID (p)) && IS (MOID (SUB (slice)), REF_SYMBOL) && basic_slice (slice))); } else if (IS (p, DEREFERENCING) && locate (SUB (p), SELECTION)) { return ((BOOL_T) (primitive_mode (MOID (p)) && BASIC (SUB (p), SELECTION))); } else if (IS (p, WIDENING)) { if (WIDEN_TO (p, INT, REAL)) { return (basic_unit (SUB (p))); } else if (WIDEN_TO (p, INT, LONG_INT)) { return (basic_unit (SUB (p))); } else if (WIDEN_TO (p, REAL, COMPLEX)) { return (basic_unit (SUB (p))); } else if (WIDEN_TO (p, REAL, LONG_REAL)) { return (basic_unit (SUB (p))); } else if (WIDEN_TO (p, LONG_INT, LONG_REAL)) { return (basic_unit (SUB (p))); } else { return (A68_FALSE); } } else if (IS (p, IDENTIFIER)) { if (A68G_STANDENV_PROC (TAX (p))) { int k; for (k = 0; PROCEDURE (&constants[k]) != NO_GPROC; k ++) { if (PROCEDURE (TAX (p)) == PROCEDURE (&constants[k])) { return (A68_TRUE); } } return (A68_FALSE); } else { return (basic_mode (MOID (p))); } } else if (IS (p, DENOTATION)) { return (denotation_mode (MOID (p))); } else if (IS (p, MONADIC_FORMULA)) { return ((BOOL_T) (basic_mode (MOID (p)) && basic_monadic_formula (p))); } else if (IS (p, FORMULA)) { return ((BOOL_T) (basic_mode (MOID (p)) && basic_formula (p))); } else if (IS (p, CALL)) { return ((BOOL_T) (basic_mode (MOID (p)) && basic_call (p))); } else if (IS (p, CAST)) { return ((BOOL_T) (folder_mode (MOID (SUB (p))) && basic_unit (NEXT_SUB (p)))); } else if (IS (p, SLICE)) { return ((BOOL_T) (basic_mode (MOID (p)) && basic_slice (p))); } else if (IS (p, SELECTION)) { NODE_T * sec = locate (NEXT_SUB (p), IDENTIFIER); if (sec == NO_NODE) { return (A68_FALSE); } else { return (basic_mode_non_row (MOID (sec))); } } else if (IS (p, IDENTITY_RELATION)) { #define GOOD(p) (locate (p, IDENTIFIER) != NO_NODE && IS (MOID (locate ((p), IDENTIFIER)), REF_SYMBOL)) NODE_T * lhs = SUB (p); NODE_T * rhs = NEXT_NEXT (lhs); if (GOOD (lhs) && GOOD (rhs)) { return (A68_TRUE); } else if (GOOD (lhs) && locate (rhs, NIHIL) != NO_NODE) { return (A68_TRUE); } else { return (A68_FALSE); } #undef GOOD } else { return (A68_FALSE); } } /*******************************************************************/ /* Constant folder */ /* Uses interpreter routines to calculate compile-time expressions */ /*******************************************************************/ /***********************/ /* Constant unit check */ /***********************/ /*! \brief whether constant collateral clause \param p position in tree \return same **/ static BOOL_T constant_collateral (NODE_T * p) { if (p == NO_NODE) { return (A68_TRUE); } else if (IS (p, UNIT)) { return ((BOOL_T) (folder_mode (MOID (p)) && constant_unit (SUB (p)) && constant_collateral (NEXT (p)))); } else { return ((BOOL_T) (constant_collateral (SUB (p)) && constant_collateral (NEXT (p)))); } } /*! \brief whether constant serial clause \param p position in tree \return same **/ static void count_constant_units (NODE_T * p, int * total, int * good) { if (p != NO_NODE) { if (IS (p, UNIT)) { (* total) ++; if (constant_unit (p)) { (* good) ++; } count_constant_units (NEXT (p), total, good); } else { count_constant_units (SUB (p), total, good); count_constant_units (NEXT (p), total, good); } } } /*! \brief whether constant serial clause \param p position in tree \param want > 0 is how many units we allow, <= 0 is don't care \return same **/ static BOOL_T constant_serial (NODE_T * p, int want) { int total = 0, good = 0; count_constant_units (p, &total, &good); if (want > 0) { return (total == want && total == good); } else { return (total == good); } } /*! \brief whether constant argument \param p starting node \return same **/ static BOOL_T constant_argument (NODE_T * p) { if (p == NO_NODE) { return (A68_TRUE); } else if (IS (p, UNIT)) { return ((BOOL_T) (folder_mode (MOID (p)) && constant_unit (p) && constant_argument (NEXT (p)))); } else { return ((BOOL_T) (constant_argument (SUB (p)) && constant_argument (NEXT (p)))); } } /*! \brief whether constant call \param p starting node \return same **/ static BOOL_T constant_call (NODE_T * p) { if (IS (p, CALL)) { NODE_T * prim = SUB (p); NODE_T * idf = locate (prim, IDENTIFIER); if (idf != NO_NODE) { int k; for (k = 0; PROCEDURE (&functions[k]) != NO_GPROC; k ++) { if (PROCEDURE (TAX (idf)) == PROCEDURE (&functions[k])) { NODE_T * args = NEXT (prim); return (constant_argument (args)); } } } } return (A68_FALSE); } /*! \brief whether constant monadic formula \param p starting node \return same **/ static BOOL_T constant_monadic_formula (NODE_T * p) { if (IS (p, MONADIC_FORMULA)) { NODE_T * op = SUB (p); int k; for (k = 0; PROCEDURE (&monadics[k]) != NO_GPROC; k ++) { if (PROCEDURE (TAX (op)) == PROCEDURE (&monadics[k])) { NODE_T * rhs = NEXT (op); return (constant_unit (rhs)); } } } return (A68_FALSE); } /*! \brief whether constant dyadic formula \param p starting node \return same **/ static BOOL_T constant_formula (NODE_T * p) { if (IS (p, FORMULA)) { NODE_T * lhs = SUB (p); NODE_T * op = NEXT (lhs); if (op == NO_NODE) { return (constant_monadic_formula (lhs)); } else { int k; for (k = 0; PROCEDURE (&dyadics[k]) != NO_GPROC; k ++) { if (PROCEDURE (TAX (op)) == PROCEDURE (&dyadics[k])) { NODE_T * rhs = NEXT (op); return ((BOOL_T) (constant_unit (lhs) && constant_unit (rhs))); } } } } return (A68_FALSE); } /*! \brief whether constant unit \param p starting node \return same **/ BOOL_T constant_unit (NODE_T * p) { if (p == NO_NODE) { return (A68_FALSE); } else if (IS (p, UNIT)) { return (constant_unit (SUB (p))); } else if (IS (p, TERTIARY)) { return (constant_unit (SUB (p))); } else if (IS (p, SECONDARY)) { return (constant_unit (SUB (p))); } else if (IS (p, PRIMARY)) { return (constant_unit (SUB (p))); } else if (IS (p, ENCLOSED_CLAUSE)) { return (constant_unit (SUB (p))); } else if (IS (p, CLOSED_CLAUSE)) { return (constant_serial (NEXT_SUB (p), 1)); } else if (IS (p, COLLATERAL_CLAUSE)) { return (folder_mode (MOID (p)) && constant_collateral (NEXT_SUB (p))); } else if (IS (p, WIDENING)) { if (WIDEN_TO (p, INT, REAL)) { return (constant_unit (SUB (p))); } else if (WIDEN_TO (p, INT, LONG_INT)) { return (constant_unit (SUB (p))); } else if (WIDEN_TO (p, REAL, COMPLEX)) { return (constant_unit (SUB (p))); } else if (WIDEN_TO (p, REAL, LONG_REAL)) { return (constant_unit (SUB (p))); } else if (WIDEN_TO (p, LONG_INT, LONG_REAL)) { return (constant_unit (SUB (p))); } else { return (A68_FALSE); } } else if (IS (p, IDENTIFIER)) { if (A68G_STANDENV_PROC (TAX (p))) { int k; for (k = 0; PROCEDURE (&constants[k]) != NO_GPROC; k ++) { if (PROCEDURE (TAX (p)) == PROCEDURE (&constants[k])) { return (A68_TRUE); } } return (A68_FALSE); } else { /* Possible constant folding */ NODE_T * def = NODE (TAX (p)); BOOL_T ret = A68_FALSE; if (STATUS (p) & COOKIE_MASK) { diagnostic_node (A68_WARNING, p, WARNING_UNINITIALISED); } else { STATUS (p) |= COOKIE_MASK; if (folder_mode (MOID (p)) && def != NO_NODE && NEXT (def) != NO_NODE && IS (NEXT (def), EQUALS_SYMBOL)) { ret = constant_unit (NEXT_NEXT (def)); } } STATUS (p) &= !(COOKIE_MASK); return (ret); } } else if (IS (p, DENOTATION)) { return (denotation_mode (MOID (p))); } else if (IS (p, MONADIC_FORMULA)) { return ((BOOL_T) (folder_mode (MOID (p)) && constant_monadic_formula (p))); } else if (IS (p, FORMULA)) { return ((BOOL_T) (folder_mode (MOID (p)) && constant_formula (p))); } else if (IS (p, CALL)) { return ((BOOL_T) (folder_mode (MOID (p)) && constant_call (p))); } else if (IS (p, CAST)) { return ((BOOL_T) (folder_mode (MOID (SUB (p))) && constant_unit (NEXT_SUB (p)))); } else { return (A68_FALSE); } } /*****************************************************************/ /* Evaluate compile-time expressions using interpreter routines. */ /*****************************************************************/ /*! \brief push denotation \param p position in tree **/ static void push_denotation (NODE_T * p) { #define PUSH_DENOTATION(mode, decl) {\ decl z;\ NODE_T *s = (IS (SUB (p), SHORTETY) ? NEXT_SUB (p) : SUB (p));\ if (genie_string_to_value_internal (p, MODE (mode), NSYMBOL (s), (BYTE_T *) & z) == A68_FALSE) {\ diagnostic_node (A68_SYNTAX_ERROR, p, ERROR_IN_DENOTATION, MODE (mode));\ }\ PUSH_PRIMITIVE (p, VALUE (&z), decl);} /**/ #define PUSH_LONG_DENOTATION(mode, decl) {\ decl z;\ NODE_T *s = (IS (SUB (p), LONGETY) ? NEXT_SUB (p) : SUB (p));\ if (genie_string_to_value_internal (p, MODE (mode), NSYMBOL (s), (BYTE_T *) z) == A68_FALSE) {\ diagnostic_node (A68_SYNTAX_ERROR, p, ERROR_IN_DENOTATION, MODE (mode));\ }\ PUSH (p, &z, MOID_SIZE (MODE (mode)));} /**/ if (MOID (p) == MODE (INT)) { PUSH_DENOTATION (INT, A68_INT); } else if (MOID (p) == MODE (REAL)) { PUSH_DENOTATION (REAL, A68_REAL); } else if (MOID (p) == MODE (BOOL)) { PUSH_DENOTATION (BOOL, A68_BOOL); } else if (MOID (p) == MODE (CHAR)) { if ((NSYMBOL (p))[0] == NULL_CHAR) { PUSH_PRIMITIVE (p, NULL_CHAR, A68_CHAR); } else { PUSH_PRIMITIVE (p, (NSYMBOL (p))[0], A68_CHAR); } } else if (MOID (p) == MODE (BITS)) { PUSH_DENOTATION (BITS, A68_BITS); } else if (MOID (p) == MODE (LONG_INT)) { PUSH_LONG_DENOTATION (LONG_INT, A68_LONG); } else if (MOID (p) == MODE (LONG_REAL)) { PUSH_LONG_DENOTATION (LONG_REAL, A68_LONG); } #undef PUSH_DENOTATION #undef PUSH_LONG_DENOTATION } /*! \brief push widening \param p starting node **/ static void push_widening (NODE_T * p) { push_unit (SUB (p)); if (WIDEN_TO (p, INT, REAL)) { A68_INT k; POP_OBJECT (p, &k, A68_INT); PUSH_PRIMITIVE (p, (double) VALUE (&k), A68_REAL); } else if (WIDEN_TO (p, REAL, COMPLEX)) { PUSH_PRIMITIVE (p, 0.0, A68_REAL); } else if (WIDEN_TO (p, INT, LONG_INT)) { genie_lengthen_int_to_long_mp (p); } else if (WIDEN_TO (p, REAL, LONG_REAL)) { genie_lengthen_real_to_long_mp (p); } else if (WIDEN_TO (p, LONG_INT, LONG_REAL)) { /* 1:1 mapping */; } } /*! \brief code collateral units \param p starting node **/ static void push_collateral_units (NODE_T * p) { if (p == NO_NODE) { return; } else if (IS (p, UNIT)) { push_unit (p); } else { push_collateral_units (SUB (p)); push_collateral_units (NEXT (p)); } } /*! \brief code argument \param p starting node **/ static void push_argument (NODE_T * p) { for (; p != NO_NODE; FORWARD (p)) { if (IS (p, UNIT)) { push_unit (p); } else { push_argument (SUB (p)); } } } /*! \brief push unit \param p starting node **/ void push_unit (NODE_T * p) { if (p == NO_NODE) { return; } if (IS (p, UNIT)) { push_unit (SUB (p)); } else if (IS (p, TERTIARY)) { push_unit (SUB (p)); } else if (IS (p, SECONDARY)) { push_unit (SUB (p)); } else if (IS (p, PRIMARY)) { push_unit (SUB (p)); } else if (IS (p, ENCLOSED_CLAUSE)) { push_unit (SUB (p)); } else if (IS (p, CLOSED_CLAUSE)) { push_unit (SUB (NEXT_SUB (p))); } else if (IS (p, COLLATERAL_CLAUSE)) { push_collateral_units (NEXT_SUB (p)); } else if (IS (p, WIDENING)) { push_widening (p); } else if (IS (p, IDENTIFIER)) { if (A68G_STANDENV_PROC (TAX (p))) { (void) (*(PROCEDURE (TAX (p)))) (p); } else { /* Possible constant folding */ NODE_T * def = NODE (TAX (p)); push_unit (NEXT_NEXT (def)); } } else if (IS (p, DENOTATION)) { push_denotation (p); } else if (IS (p, MONADIC_FORMULA)) { NODE_T * op = SUB (p); NODE_T * rhs = NEXT (op); push_unit (rhs); (*(PROCEDURE (TAX (op)))) (op); } else if (IS (p, FORMULA)) { NODE_T * lhs = SUB (p); NODE_T * op = NEXT (lhs); if (op == NO_NODE) { push_unit (lhs); } else { NODE_T * rhs = NEXT (op); push_unit (lhs); push_unit (rhs); (*(PROCEDURE (TAX (op)))) (op); } } else if (IS (p, CALL)) { NODE_T * prim = SUB (p); NODE_T * args = NEXT (prim); NODE_T * idf = locate (prim, IDENTIFIER); push_argument (args); (void) (*(PROCEDURE (TAX (idf)))) (p); } else if (IS (p, CAST)) { push_unit (NEXT_SUB (p)); } } /*! \brief code constant folding \param p node to start **/ static void constant_folder (NODE_T * p, FILE_T out, int phase) { if (phase == L_DECLARE) { if (MOID (p) == MODE (COMPLEX)) { char acc[NAME_SIZE]; A68_REAL re, im; (void) make_name (acc, CON, "", NUMBER (p)); stack_pointer = 0; push_unit (p); POP_OBJECT (p, &im, A68_REAL); POP_OBJECT (p, &re, A68_REAL); indentf (out, snprintf (line, SNPRINTF_SIZE, "A68_COMPLEX %s = {", acc)); undentf (out, snprintf (line, SNPRINTF_SIZE, "{INIT_MASK, %.*g}", REAL_WIDTH, VALUE (&re))); undentf (out, snprintf (line, SNPRINTF_SIZE, ", {INIT_MASK, %.*g}", REAL_WIDTH, VALUE (&im))); undent (out, "};\n"); ABEND (stack_pointer > 0, "stack not empty", NO_TEXT); } else if (LONG_MODE (MOID (p))) { char acc[NAME_SIZE]; A68_LONG z; int k; (void) make_name (acc, CON, "", NUMBER (p)); stack_pointer = 0; push_unit (p); POP (p, &z, MOID_SIZE (MOID (p))); indentf (out, snprintf (line, SNPRINTF_SIZE, "A68_LONG %s = {INIT_MASK, %.0f", acc, z[1])); for (k = 1; k <= LONG_MP_DIGITS; k ++) { undentf (out, snprintf (line, SNPRINTF_SIZE, ", %.0f", z[k + 1])); } undent (out, "};\n"); ABEND (stack_pointer > 0, "stack not empty", NO_TEXT); } } else if (phase == L_EXECUTE) { if (MOID (p) == MODE (COMPLEX)) { /* Done at declaration stage */ } else if (LONG_MODE (MOID (p))) { /* Done at declaration stage */ } } else if (phase == L_YIELD) { if (MOID (p) == MODE (INT)) { A68_INT k; stack_pointer = 0; push_unit (p); POP_OBJECT (p, &k, A68_INT); ASSERT (snprintf (line, SNPRINTF_SIZE, "%d", VALUE (&k)) >= 0); undent (out, line); ABEND (stack_pointer > 0, "stack not empty", NO_TEXT); } else if (MOID (p) == MODE (REAL)) { A68_REAL x; double conv; stack_pointer = 0; push_unit (p); POP_OBJECT (p, &x, A68_REAL); /* Mind overflowing or underflowing values */ if (VALUE (&x) == DBL_MAX) { undent (out, "DBL_MAX"); } else if (VALUE (&x) == -DBL_MAX) { undent (out, "(-DBL_MAX)"); } else { ASSERT (snprintf (line, SNPRINTF_SIZE, "%.*g", REAL_WIDTH, VALUE (&x)) >= 0); errno = 0; conv = strtod (line, NO_VAR); if (errno == ERANGE && conv == 0.0) { undent (out, "0.0"); } else if (errno == ERANGE && conv == HUGE_VAL) { diagnostic_node (A68_WARNING, p, WARNING_OVERFLOW, MODE (REAL)); undent (out, "DBL_MAX"); } else if (errno == ERANGE && conv == -HUGE_VAL) { diagnostic_node (A68_WARNING, p, WARNING_OVERFLOW, MODE (REAL)); undent (out, "(-DBL_MAX)"); } else if (errno == ERANGE && conv >= 0) { diagnostic_node (A68_WARNING, p, WARNING_UNDERFLOW, MODE (REAL)); undent (out, "DBL_MIN"); } else if (errno == ERANGE && conv < 0) { diagnostic_node (A68_WARNING, p, WARNING_UNDERFLOW, MODE (REAL)); undent (out, "(-DBL_MIN)"); } else { if (strchr (line, '.') == NO_TEXT && strchr (line, 'e') == NO_TEXT && strchr (line, 'E') == NO_TEXT) { strncat (line, ".0", BUFFER_SIZE); } undent (out, line); } } ABEND (stack_pointer > 0, "stack not empty", NO_TEXT); } else if (MOID (p) == MODE (BOOL)) { A68_BOOL b; stack_pointer = 0; push_unit (p); POP_OBJECT (p, &b, A68_BOOL); ASSERT (snprintf (line, SNPRINTF_SIZE, "%s", (VALUE (&b) ? "A68_TRUE" : "A68_FALSE")) >= 0); undent (out, line); ABEND (stack_pointer > 0, "stack not empty", NO_TEXT); } else if (MOID (p) == MODE (CHAR)) { A68_CHAR c; stack_pointer = 0; push_unit (p); POP_OBJECT (p, &c, A68_CHAR); if (VALUE (&c) == '\'') { undentf (out, snprintf (line, SNPRINTF_SIZE, "'\\\''")); } else if (VALUE (&c) == '\\') { undentf (out, snprintf (line, SNPRINTF_SIZE, "'\\\\'")); } else if (VALUE (&c) == NULL_CHAR) { undentf (out, snprintf (line, SNPRINTF_SIZE, "NULL_CHAR")); } else if (IS_PRINT (VALUE (&c))) { undentf (out, snprintf (line, SNPRINTF_SIZE, "'%c'", VALUE (&c))); } else { undentf (out, snprintf (line, SNPRINTF_SIZE, "(int) 0x%04x", (unsigned) VALUE (&c))); } ABEND (stack_pointer > 0, "stack not empty", NO_TEXT); } else if (MOID (p) == MODE (BITS)) { A68_BITS b; stack_pointer = 0; push_unit (p); POP_OBJECT (p, &b, A68_BITS); ASSERT (snprintf (line, SNPRINTF_SIZE, "0x%x", VALUE (&b)) >= 0); undent (out, line); ABEND (stack_pointer > 0, "stack not empty", NO_TEXT); } else if (MOID (p) == MODE (COMPLEX)) { char acc[NAME_SIZE]; (void) make_name (acc, CON, "", NUMBER (p)); undentf (out, snprintf (line, SNPRINTF_SIZE, "(A68_REAL *) %s", acc)); } else if (LONG_MODE (MOID (p))) { char acc[NAME_SIZE]; (void) make_name (acc, CON, "", NUMBER (p)); undentf (out, snprintf (line, SNPRINTF_SIZE, "(MP_T *) %s", acc)); } } } /********************************************/ /* Auxilliary routines for emitting C code. */ /********************************************/ static BOOL_T need_initialise_frame (NODE_T * p) { TAG_T *tag; int count; for (tag = ANONYMOUS (TABLE (p)); tag != NO_TAG; FORWARD (tag)) { if (PRIO (tag) == ROUTINE_TEXT) { return (A68_TRUE); } else if (PRIO (tag) == FORMAT_TEXT) { return (A68_TRUE); } } count = 0; genie_find_proc_op (p, &count); if (count > 0) { return (A68_TRUE); } else { return (A68_FALSE); } } /*! \brief comment source line \param p position in tree \param out output file descriptor **/ static void comment_tree (NODE_T * p, FILE_T out, int *want_space, int *max_print) { /* Take care not to generate nested comments */ #define UNDENT(out, p) {\ char * q;\ for (q = p; q[0] != NULL_CHAR; q ++) {\ if (q[0] == '*' && q[1] == '/') {\ undent (out, "\\*\\/");\ q ++;\ } else if (q[0] == '/' && q[1] == '*') {\ undent (out, "\\/\\*");\ q ++;\ } else {\ char w[2];\ w[0] = q[0];\ w[1] = NULL_CHAR;\ undent (out, w);\ }\ }} /**/ for (; p != NO_NODE && (*max_print) >= 0; FORWARD (p)) { if (IS (p, ROW_CHAR_DENOTATION)) { if (*want_space != 0) { UNDENT (out, " "); } UNDENT (out, "\""); UNDENT (out, NSYMBOL (p)); UNDENT (out, "\""); *want_space = 2; } else if (SUB (p) != NO_NODE) { comment_tree (SUB (p), out, want_space, max_print); } else if (NSYMBOL (p)[0] == '(' || NSYMBOL (p)[0] == '[' || NSYMBOL (p)[0] == '{') { if (*want_space == 2) { UNDENT (out, " "); } UNDENT (out, NSYMBOL (p)); *want_space = 0; } else if (NSYMBOL (p)[0] == ')' || NSYMBOL (p)[0] == ']' || NSYMBOL (p)[0] == '}') { UNDENT (out, NSYMBOL (p)); *want_space = 1; } else if (NSYMBOL (p)[0] == ';' || NSYMBOL (p)[0] == ',') { UNDENT (out, NSYMBOL (p)); *want_space = 2; } else if (strlen (NSYMBOL (p)) == 1 && (NSYMBOL (p)[0] == '.' || NSYMBOL (p)[0] == ':')) { UNDENT (out, NSYMBOL (p)); *want_space = 2; } else { if (*want_space != 0) { UNDENT (out, " "); } if ((*max_print) > 0) { UNDENT (out, NSYMBOL (p)); } else if ((*max_print) == 0) { if (*want_space == 0) { UNDENT (out, " "); } UNDENT (out, "..."); } (*max_print)--; if (IS_UPPER (NSYMBOL (p)[0])) { *want_space = 2; } else if (! IS_ALNUM (NSYMBOL (p)[0])) { *want_space = 2; } else { *want_space = 1; } } } #undef UNDENT } /*! \brief comment source line \param p position in tree \param out output file descriptor **/ static void comment_source (NODE_T * p, FILE_T out) { int want_space = 0, max_print = 16; undentf (out, snprintf (line, SNPRINTF_SIZE, "/* %s: %d: ", FILENAME (LINE (INFO (p))), LINE_NUMBER (p))); comment_tree (p, out, &want_space, &max_print); undent (out, " */\n"); } /*! \brief inline comment source line \param p position in tree \param out output file descriptor **/ static void inline_comment_source (NODE_T * p, FILE_T out) { int want_space = 0, max_print = 8; undent (out, " /* "); comment_tree (p, out, &want_space, &max_print); undent (out, " */"); } /*! \brief write prelude \param out output file descriptor **/ static void write_prelude (FILE_T out) { indentf (out, snprintf (line, SNPRINTF_SIZE, "/* \"%s\" %s */\n\n", FILE_OBJECT_NAME (&program), PACKAGE_STRING)); if (OPTION_LOCAL (&program)) { indentf (out, snprintf (line, SNPRINTF_SIZE, "#include \"a68g-config.h\"\n")); indentf (out, snprintf (line, SNPRINTF_SIZE, "#include \"a68g.h\"\n\n")); } else { indentf (out, snprintf (line, SNPRINTF_SIZE, "#include <%s/a68g-config.h>\n", PACKAGE)); indentf (out, snprintf (line, SNPRINTF_SIZE, "#include <%s/a68g.h>\n\n", PACKAGE)); } indent (out, "#define _CODE_(n) PROP_T n (NODE_T * p) {\\\n"); indent (out, " PROP_T self;\n\n"); indent (out, "#define _EDOC_(n, q) UNIT (&self) = n;\\\n"); indent (out, " SOURCE (&self) = q;\\\n"); indent (out, " (void) p;\\\n"); indent (out, " return (self);}\n\n"); indent (out, "#define DIV_INT(i, j) ((double) (i) / (double) (j))\n"); indent (out, "#define _N_(n) (node_register[n])\n"); indent (out, "#define _S_(z) (STATUS (z))\n"); indent (out, "#define _V_(z) (VALUE (z))\n\n"); } /*! \brief write initialisation of frame \**/ static void init_static_frame (FILE_T out, NODE_T * p) { if (AP_INCREMENT (TABLE (p)) > 0) { indentf (out, snprintf (line, SNPRINTF_SIZE, "FRAME_CLEAR (%d);\n", AP_INCREMENT (TABLE (p)))); } if (LEX_LEVEL (p) == global_level) { indent (out, "global_pointer = frame_pointer;\n"); } if (need_initialise_frame (p)) { indentf (out, snprintf (line, SNPRINTF_SIZE, "initialise_frame (_N_ (%d));\n", NUMBER (p))); } } /********************************/ /* COMPILATION OF PARTIAL UNITS */ /********************************/ /*! \brief code getting objects from the stack \param p position in tree \param out output file descriptor \param dst where to store \param cast mode to cast to **/ static void get_stack (NODE_T * p, FILE_T out, char * dst, char * cast) { if (DEBUG_LEVEL >= 4) { if (LEVEL (GINFO (p)) == global_level) { indentf (out, snprintf (line, SNPRINTF_SIZE, "GET_GLOBAL (%s, %s, %d);\n", dst, cast, OFFSET (TAX (p)))); } else { indentf (out, snprintf (line, SNPRINTF_SIZE, "GET_FRAME (%s, %s, %d, %d);\n", dst, cast, LEVEL (GINFO (p)), OFFSET (TAX (p)))); } } else { indentf (out, snprintf (line, SNPRINTF_SIZE, "GET_FRAME (%s, %s, %d, %d);\n", dst, cast, LEVEL (GINFO (p)), OFFSET (TAX (p)))); } } /*! \brief code function prelude \param out output file descriptor \param p position in tree \param fn function name **/ static void write_fun_prelude (NODE_T * p, FILE_T out, char * fn) { (void) p; indentf (out, snprintf (line, SNPRINTF_SIZE, "_CODE_ (%s)\n", fn)); indentation ++; temp_book_pointer = 0; } /*! \brief code function postlude \param out output file descriptor \param p position in tree \param fn function name **/ static void write_fun_postlude (NODE_T * p, FILE_T out, char * fn) { (void) p; indentation --; indentf (out, snprintf (line, SNPRINTF_SIZE, "_EDOC_ (%s, _N_ (%d))\n\n", fn, NUMBER (p))); temp_book_pointer = 0; } /*! \brief code internal a68g mode \param m mode to check \return same **/ static char *internal_mode (MOID_T * m) { if (m == MODE (INT)) { return ("MODE (INT)"); } else if (m == MODE (REAL)) { return ("MODE (REAL)"); } else if (m == MODE (BOOL)) { return ("MODE (BOOL)"); } else if (m == MODE (CHAR)) { return ("MODE (CHAR)"); } else if (m == MODE (BITS)) { return ("MODE (BITS)"); } else { return ("MODE (ERROR)"); } } /*! \brief code an A68 mode \param m mode to code \return internal identifier for mode **/ static char * inline_mode (MOID_T * m) { if (m == MODE (INT)) { return ("A68_INT"); } else if (m == MODE (REAL)) { return ("A68_REAL"); } else if (LONG_MODE (m)) { return ("A68_LONG"); } else if (m == MODE (BOOL)) { return ("A68_BOOL"); } else if (m == MODE (CHAR)) { return ("A68_CHAR"); } else if (m == MODE (BITS)) { return ("A68_BITS"); } else if (m == MODE (COMPLEX)) { return ("A68_COMPLEX"); } else if (IS (m, REF_SYMBOL)) { return ("A68_REF"); } else if (IS (m, ROW_SYMBOL)) { return ("A68_ROW"); } else if (IS (m, PROC_SYMBOL)) { return ("A68_PROCEDURE"); } else if (IS (m, STRUCT_SYMBOL)) { return ("A68_STRUCT"); } else { return ("A68_ERROR"); } } /*! \brief code denotation \param p starting node \param out object file \param phase phase of code generation **/ static void inline_denotation (NODE_T * p, FILE_T out, int phase) { if (phase == L_DECLARE && LONG_MODE (MOID (p))) { char acc[NAME_SIZE]; A68_LONG z; NODE_T *s = IS (SUB (p), LONGETY) ? NEXT_SUB (p) : SUB (p); int k; (void) make_name (acc, CON, "", NUMBER (p)); if (genie_string_to_value_internal (p, MOID (p), NSYMBOL (s), (BYTE_T *) & z) == A68_FALSE) { diagnostic_node (A68_SYNTAX_ERROR, p, ERROR_IN_DENOTATION, MODE (INT)); } indentf (out, snprintf (line, SNPRINTF_SIZE, "A68_LONG %s = {INIT_MASK, %.0f", acc, z[1])); for (k = 1; k <= LONG_MP_DIGITS; k ++) { undentf (out, snprintf (line, SNPRINTF_SIZE, ", %.0f", z[k + 1])); } undent (out, "};\n"); } if (phase == L_YIELD) { if (MOID (p) == MODE (INT)) { A68_INT z; NODE_T *s = IS (SUB (p), SHORTETY) ? NEXT_SUB (p) : SUB (p); char *den = NSYMBOL (s); if (genie_string_to_value_internal (p, MODE (INT), den, (BYTE_T *) & z) == A68_FALSE) { diagnostic_node (A68_SYNTAX_ERROR, p, ERROR_IN_DENOTATION, MODE (INT)); } undentf (out, snprintf (line, SNPRINTF_SIZE, "%d", VALUE (&z))); } else if (MOID (p) == MODE (REAL)) { A68_REAL z; NODE_T *s = IS (SUB (p), SHORTETY) ? NEXT_SUB (p) : SUB (p); char *den = NSYMBOL (s); if (genie_string_to_value_internal (p, MODE (REAL), den, (BYTE_T *) & z) == A68_FALSE) { diagnostic_node (A68_SYNTAX_ERROR, p, ERROR_IN_DENOTATION, MODE (REAL)); } if (strchr (den, '.') == NO_TEXT && strchr (den, 'e') == NO_TEXT && strchr (den, 'E') == NO_TEXT) { undentf (out, snprintf (line, SNPRINTF_SIZE, "(double) %s", den)); } else { undentf (out, snprintf (line, SNPRINTF_SIZE, "%s", den)); } } else if (LONG_MODE (MOID (p))) { char acc[NAME_SIZE]; (void) make_name (acc, CON, "", NUMBER (p)); undent (out, acc); } else if (MOID (p) == MODE (BOOL)) { undent (out, "(BOOL_T) A68_"); undent (out, NSYMBOL (p)); } else if (MOID (p) == MODE (CHAR)) { if (NSYMBOL (p)[0] == '\'') { undentf (out, snprintf (line, SNPRINTF_SIZE, "'\\''")); } else if (NSYMBOL (p)[0] == NULL_CHAR) { undentf (out, snprintf (line, SNPRINTF_SIZE, "NULL_CHAR")); } else if (NSYMBOL (p)[0] == '\\') { undentf (out, snprintf (line, SNPRINTF_SIZE, "'\\\\'")); } else { undentf (out, snprintf (line, SNPRINTF_SIZE, "'%c'", (NSYMBOL (p))[0])); } } else if (MOID (p) == MODE (BITS)) { A68_BITS z; NODE_T *s = IS (SUB (p), SHORTETY) ? NEXT_SUB (p) : SUB (p); if (genie_string_to_value_internal (p, MODE (BITS), NSYMBOL (s), (BYTE_T *) & z) == A68_FALSE) { diagnostic_node (A68_SYNTAX_ERROR, p, ERROR_IN_DENOTATION, MODE (BITS)); } ASSERT (snprintf (line, SNPRINTF_SIZE, "(unsigned) 0x%x", VALUE (&z)) >= 0); undent (out, line); } } } /*! \brief code widening \param p starting node \param out object file \param phase phase of code generation **/ static void inline_widening (NODE_T * p, FILE_T out, int phase) { if (WIDEN_TO (p, INT, REAL)) { if (phase == L_DECLARE) { inline_unit (SUB (p), out, L_DECLARE); } else if (phase == L_EXECUTE) { inline_unit (SUB (p), out, L_EXECUTE); } else if (phase == L_YIELD) { undent (out, "(double) ("); inline_unit (SUB (p), out, L_YIELD); undent (out, ")"); } } else if (WIDEN_TO (p, REAL, COMPLEX)) { char acc[NAME_SIZE]; (void) make_name (acc, TMP, "", NUMBER (p)); if (phase == L_DECLARE) { (void) add_declaration (&root_idf, inline_mode (MODE (COMPLEX)), 0, acc); inline_unit (SUB (p), out, L_DECLARE); } else if (phase == L_EXECUTE) { inline_unit (SUB (p), out, L_EXECUTE); indentf (out, snprintf (line, SNPRINTF_SIZE, "STATUS_RE (%s) = INIT_MASK;\n", acc)); indentf (out, snprintf (line, SNPRINTF_SIZE, "STATUS_IM (%s) = INIT_MASK;\n", acc)); indentf (out, snprintf (line, SNPRINTF_SIZE, "RE (%s) = (double) (", acc)); inline_unit (SUB (p), out, L_YIELD); undent (out, ");\n"); indentf (out, snprintf (line, SNPRINTF_SIZE, "IM (%s) = 0.0;\n", acc)); } else if (phase == L_YIELD) { undentf (out, snprintf (line, SNPRINTF_SIZE, "(A68_REAL *) %s", acc)); } } else if (WIDEN_TO (p, INT, LONG_INT)) { char acc[NAME_SIZE]; (void) make_name (acc, TMP, "", NUMBER (p)); if (phase == L_DECLARE) { (void) add_declaration (&root_idf, inline_mode (MODE (LONG_INT)), 0, acc); inline_unit (SUB (p), out, L_DECLARE); } else if (phase == L_EXECUTE) { inline_unit (SUB (p), out, L_EXECUTE); indentf (out, snprintf (line, SNPRINTF_SIZE, "(void) int_to_mp (_N_ (%d), %s, ", NUMBER (p), acc)); inline_unit (SUB (p), out, L_YIELD); undentf (out, snprintf (line, SNPRINTF_SIZE, ", %d);\n", LONG_MP_DIGITS)); } else if (phase == L_YIELD) { undentf (out, snprintf (line, SNPRINTF_SIZE, "(MP_T *) %s", acc)); } } else if (WIDEN_TO (p, REAL, LONG_REAL)) { char acc[NAME_SIZE]; (void) make_name (acc, TMP, "", NUMBER (p)); if (phase == L_DECLARE) { (void) add_declaration (&root_idf, inline_mode (MODE (LONG_REAL)), 0, acc); inline_unit (SUB (p), out, L_DECLARE); } else if (phase == L_EXECUTE) { inline_unit (SUB (p), out, L_EXECUTE); indentf (out, snprintf (line, SNPRINTF_SIZE, "(void) real_to_mp (_N_ (%d), %s, ", NUMBER (p), acc)); inline_unit (SUB (p), out, L_YIELD); undentf (out, snprintf (line, SNPRINTF_SIZE, ", %d);\n", LONG_MP_DIGITS)); } else if (phase == L_YIELD) { undentf (out, snprintf (line, SNPRINTF_SIZE, "(MP_T *) %s", acc)); } } else if (WIDEN_TO (p, LONG_INT, LONG_REAL)) { inline_unit (SUB (p), out, phase); } } /*! \brief code dereferencing of identifier \param p starting node \param out object file \param phase phase of code generation **/ static void inline_dereference_identifier (NODE_T * p, FILE_T out, int phase) { NODE_T * q = locate (SUB (p), IDENTIFIER); ABEND (q == NO_NODE, "not dereferencing an identifier", NO_TEXT); if (phase == L_DECLARE) { if (signed_in (BOOK_DEREF, L_DECLARE, NSYMBOL (q)) != NO_BOOK) { return; } else { char idf[NAME_SIZE]; (void) make_name (idf, NSYMBOL (q), "", NUMBER (p)); (void) add_declaration (&root_idf, inline_mode (MOID (p)), 1, idf); sign_in (BOOK_DEREF, L_DECLARE, NSYMBOL (p), NULL, NUMBER (p)); inline_unit (SUB (p), out, L_DECLARE); } } else if (phase == L_EXECUTE) { if (signed_in (BOOK_DEREF, L_EXECUTE, NSYMBOL (q)) != NO_BOOK) { return; } else { char idf[NAME_SIZE]; (void) make_name (idf, NSYMBOL (q), "", NUMBER (p)); inline_unit (SUB (p), out, L_EXECUTE); if (BODY (TAX (q)) != NO_TAG) { indentf (out, snprintf (line, SNPRINTF_SIZE, "%s = (%s *) LOCAL_ADDRESS (", idf, inline_mode (MOID (p)))); sign_in (BOOK_DEREF, L_EXECUTE, NSYMBOL (p), NULL, NUMBER (p)); inline_unit (SUB (p), out, L_YIELD); undent (out, ");\n"); } else { indentf (out, snprintf (line, SNPRINTF_SIZE, "%s = DEREF (%s, ", idf, inline_mode (MOID (p)))); sign_in (BOOK_DEREF, L_EXECUTE, NSYMBOL (p), NULL, NUMBER (p)); inline_unit (SUB (p), out, L_YIELD); undent (out, ");\n"); } } } else if (phase == L_YIELD) { char idf[NAME_SIZE]; if (signed_in (BOOK_DEREF, L_EXECUTE, NSYMBOL (q)) != NO_BOOK) { (void) make_name (idf, NSYMBOL (q), "", NUMBER (signed_in (BOOK_DEREF, L_DECLARE, NSYMBOL (q)))); } else { (void) make_name (idf, NSYMBOL (q), "", NUMBER (p)); } if (primitive_mode (MOID (p))) { undentf (out, snprintf (line, SNPRINTF_SIZE, "_V_ (%s)", idf)); } else if (MOID (p) == MODE (COMPLEX)) { undentf (out, snprintf (line, SNPRINTF_SIZE, "(A68_REAL *) (%s)", idf)); } else if (LONG_MODE (MOID (p))) { undentf (out, snprintf (line, SNPRINTF_SIZE, "(MP_T *) (%s)", idf)); } else if (basic_mode (MOID (p))) { undent (out, idf); } } } /*! \brief code identifier \param p starting node \param out object file \param phase phase of code generation **/ static void inline_identifier (NODE_T * p, FILE_T out, int phase) { /* Possible constant folding */ NODE_T * def = NODE (TAX (p)); if (primitive_mode (MOID (p)) && def != NO_NODE && NEXT (def) != NO_NODE && IS (NEXT (def), EQUALS_SYMBOL)) { NODE_T * src = locate (NEXT_NEXT (def), DENOTATION); if (src != NO_NODE) { inline_denotation (src, out, phase); return; } } /* No folding - consider identifier */ if (phase == L_DECLARE) { if (signed_in (BOOK_DECL, L_DECLARE, NSYMBOL (p)) != NO_BOOK) { return; } else if (A68G_STANDENV_PROC (TAX (p))) { return; } else { char idf[NAME_SIZE]; (void) make_name (idf, NSYMBOL (p), "", NUMBER (p)); (void) add_declaration (&root_idf, inline_mode (MOID (p)), 1, idf); sign_in (BOOK_DECL, L_DECLARE, NSYMBOL (p), NULL, NUMBER (p)); } } else if (phase == L_EXECUTE) { if (signed_in (BOOK_DECL, L_EXECUTE, NSYMBOL (p)) != NO_BOOK) { return; } else if (A68G_STANDENV_PROC (TAX (p))) { return; } else { char idf[NAME_SIZE]; (void) make_name (idf, NSYMBOL (p), "", NUMBER (p)); get_stack (p, out, idf, inline_mode (MOID (p))); sign_in (BOOK_DECL, L_EXECUTE, NSYMBOL (p), NULL, NUMBER (p)); } } else if (phase == L_YIELD) { if (A68G_STANDENV_PROC (TAX (p))) { int k; for (k = 0; PROCEDURE (&constants[k]) != NO_GPROC; k ++) { if (PROCEDURE (TAX (p)) == PROCEDURE (&constants[k])) { undent (out, CODE (&constants[k])); return; } } } else { char idf[NAME_SIZE]; BOOK_T * entry = signed_in (BOOK_DECL, L_EXECUTE, NSYMBOL (p)); if (entry != NO_BOOK) { (void) make_name (idf, NSYMBOL (p), "", NUMBER (entry)); } else { (void) make_name (idf, NSYMBOL (p), "", NUMBER (p)); } if (primitive_mode (MOID (p))) { undentf (out, snprintf (line, SNPRINTF_SIZE, "_V_ (%s)", idf)); } else if (MOID (p) == MODE (COMPLEX)) { undentf (out, snprintf (line, SNPRINTF_SIZE, "(A68_REAL *) (%s)", idf)); } else if (LONG_MODE (MOID (p))) { undentf (out, snprintf (line, SNPRINTF_SIZE, "(MP_T *) (%s)", idf)); } else if (basic_mode (MOID (p))) { undent (out, idf); } } } } /*! \brief code indexer \param p starting node \param out object file \param phase phase of code generation **/ static void inline_indexer (NODE_T * p, FILE_T out, int phase, int * k, char * tup) { if (p == NO_NODE) { return; } else if (IS (p, UNIT)) { if (phase != L_YIELD) { inline_unit (p, out, phase); } else { if ((*k) == 0) { undentf (out, snprintf (line, SNPRINTF_SIZE, "(SPAN (&%s[%d]) * (", tup, (*k))); } else { undentf (out, snprintf (line, SNPRINTF_SIZE, " + (SPAN (&%s[%d]) * (", tup, (*k))); } inline_unit (p, out, L_YIELD); undentf (out, snprintf (line, SNPRINTF_SIZE, ") - SHIFT (&%s[%d]))", tup, (*k))); } (*k) ++; } else { inline_indexer (SUB (p), out, phase, k, tup); inline_indexer (NEXT (p), out, phase, k, tup); } } /*! \brief code dereferencing of slice \param p starting node \param out object file \param phase phase of code generation **/ static void inline_dereference_slice (NODE_T * p, FILE_T out, int phase) { NODE_T * prim = SUB (p); NODE_T * indx = NEXT (prim); MOID_T * row_mode = DEFLEX (MOID (prim)); MOID_T * mode = SUB_SUB (row_mode); char * symbol = NSYMBOL (SUB (prim)); char drf[NAME_SIZE], idf[NAME_SIZE], arr[NAME_SIZE], tup[NAME_SIZE], elm[NAME_SIZE]; int k; if (phase == L_DECLARE) { BOOK_T * entry = signed_in (BOOK_DECL, L_DECLARE, symbol); if (entry == NO_BOOK) { (void) make_name (idf, symbol, "", NUMBER (prim)); (void) make_name (arr, ARR, "", NUMBER (prim)); (void) make_name (tup, TUP, "", NUMBER (prim)); (void) make_name (elm, ELM, "", NUMBER (prim)); (void) make_name (drf, DRF, "", NUMBER (prim)); (void) add_declaration (&root_idf, "A68_REF", 1, idf); (void) add_declaration (&root_idf, "A68_REF", 0, elm); (void) add_declaration (&root_idf, "A68_ARRAY", 1, arr); (void) add_declaration (&root_idf, "A68_TUPLE", 1, tup); (void) add_declaration (&root_idf, inline_mode (mode), 1, drf); sign_in (BOOK_DECL, L_DECLARE, symbol, (void *) indx, NUMBER (prim)); } else if (same_tree (indx, (NODE_T *) (INFO (entry))) == A68_FALSE) { (void) make_name (elm, ELM, "", NUMBER (prim)); (void) make_name (drf, DRF, "", NUMBER (prim)); (void) add_declaration (&root_idf, "A68_REF", 0, elm); (void) add_declaration (&root_idf, inline_mode (mode), 1, drf); } k = 0; inline_indexer (indx, out, L_DECLARE, &k, NO_TEXT); } else if (phase == L_EXECUTE) { BOOK_T * entry = signed_in (BOOK_DECL, L_EXECUTE, symbol); NODE_T * pidf = locate (prim, IDENTIFIER); if (entry == NO_BOOK) { (void) make_name (idf, symbol, "", NUMBER (prim)); (void) make_name (arr, ARR, "", NUMBER (prim)); (void) make_name (tup, TUP, "", NUMBER (prim)); (void) make_name (elm, ELM, "", NUMBER (prim)); (void) make_name (drf, DRF, "", NUMBER (prim)); get_stack (pidf, out, idf, "A68_REF"); if (IS (row_mode, REF_SYMBOL) && IS (SUB (row_mode), ROW_SYMBOL)) { indentf (out, snprintf (line, SNPRINTF_SIZE, "GET_DESCRIPTOR (%s, %s, DEREF (A68_ROW, %s));\n", arr, tup, idf)); } else { ABEND (A68_TRUE, "strange mode in dereference slice (execute)", NO_TEXT); } sign_in (BOOK_DECL, L_EXECUTE, NSYMBOL (p), (void *) indx, NUMBER (prim)); } else if (same_tree (indx, (NODE_T *) (INFO (entry))) == A68_FALSE) { (void) make_name (arr, ARR, "", NUMBER (entry)); (void) make_name (tup, TUP, "", NUMBER (entry)); (void) make_name (elm, ELM, "", NUMBER (prim)); (void) make_name (drf, DRF, "", NUMBER (prim)); } else { return; } indentf (out, snprintf (line, SNPRINTF_SIZE, "%s = ARRAY (%s);\n", elm, arr)); k = 0; inline_indexer (indx, out, L_EXECUTE, &k, NO_TEXT); indentf (out, snprintf (line, SNPRINTF_SIZE, "OFFSET (& %s) += ROW_ELEMENT (%s, ", elm, arr)); k = 0; inline_indexer (indx, out, L_YIELD, &k, tup); undentf (out, snprintf (line, SNPRINTF_SIZE, ");\n")); indentf (out, snprintf (line, SNPRINTF_SIZE, "%s = DEREF (%s, & %s);\n", drf, inline_mode (mode), elm)); } else if (phase == L_YIELD) { BOOK_T * entry = signed_in (BOOK_DECL, L_EXECUTE, symbol); if (entry != NO_BOOK && same_tree (indx, (NODE_T *) (INFO (entry))) == A68_TRUE) { (void) make_name (drf, DRF, "", NUMBER (entry)); } else { (void) make_name (drf, DRF, "", NUMBER (prim)); } if (primitive_mode (mode)) { undentf (out, snprintf (line, SNPRINTF_SIZE, "_V_ (%s)", drf)); } else if (mode == MODE (COMPLEX)) { undentf (out, snprintf (line, SNPRINTF_SIZE, "(A68_REAL *) (%s)", drf)); } else if (LONG_MODE (mode)) { undentf (out, snprintf (line, SNPRINTF_SIZE, "(MP_T *) (%s)", drf)); } else if (basic_mode (mode)) { undent (out, drf); } else { ABEND (A68_TRUE, "strange mode in dereference slice (yield)", NO_TEXT); } } } /*! \brief code slice REF [] MODE -> REF MODE \param p starting node \param out object file \param phase phase of code generation **/ static void inline_slice_ref_to_ref (NODE_T * p, FILE_T out, int phase) { NODE_T * prim = SUB (p); NODE_T * indx = NEXT (prim); MOID_T * mode = SUB_MOID (p); MOID_T * row_mode = DEFLEX (MOID (prim)); char * symbol = NSYMBOL (SUB (prim)); char idf[NAME_SIZE], arr[NAME_SIZE], tup[NAME_SIZE], elm[NAME_SIZE], drf[NAME_SIZE]; int k; if (phase == L_DECLARE) { BOOK_T * entry = signed_in (BOOK_DECL, L_DECLARE, symbol); if (entry == NO_BOOK) { (void) make_name (idf, symbol, "", NUMBER (prim)); (void) make_name (arr, ARR, "", NUMBER (prim)); (void) make_name (tup, TUP, "", NUMBER (prim)); (void) make_name (elm, ELM, "", NUMBER (prim)); (void) make_name (drf, DRF, "", NUMBER (prim)); /*indentf (out, snprintf (line, SNPRINTF_SIZE, "A68_REF * %s, %s; %s * %s; A68_ARRAY * %s; A68_TUPLE * %s;\n", idf, elm, inline_mode (mode), drf, arr, tup));*/ (void) add_declaration (&root_idf, "A68_REF", 1, idf); (void) add_declaration (&root_idf, "A68_REF", 0, elm); (void) add_declaration (&root_idf, "A68_ARRAY", 1, arr); (void) add_declaration (&root_idf, "A68_TUPLE", 1, tup); (void) add_declaration (&root_idf, inline_mode (mode), 1, drf); sign_in (BOOK_DECL, L_DECLARE, symbol, (void *) indx, NUMBER (prim)); } else if (same_tree (indx, (NODE_T *) (INFO (entry))) == A68_FALSE) { (void) make_name (elm, ELM, "", NUMBER (prim)); (void) make_name (drf, DRF, "", NUMBER (prim)); /*indentf (out, snprintf (line, SNPRINTF_SIZE, "A68_REF %s; %s * %s;\n", elm, inline_mode (mode), drf));*/ (void) add_declaration (&root_idf, "A68_REF", 0, elm); (void) add_declaration (&root_idf, inline_mode (mode), 1, drf); } k = 0; inline_indexer (indx, out, L_DECLARE, &k, NO_TEXT); } else if (phase == L_EXECUTE) { BOOK_T * entry = signed_in (BOOK_DECL, L_EXECUTE, symbol); if (entry == NO_BOOK) { NODE_T * pidf = locate (prim, IDENTIFIER); (void) make_name (idf, symbol, "", NUMBER (prim)); (void) make_name (arr, ARR, "", NUMBER (prim)); (void) make_name (tup, TUP, "", NUMBER (prim)); (void) make_name (elm, ELM, "", NUMBER (prim)); (void) make_name (drf, DRF, "", NUMBER (prim)); get_stack (pidf, out, idf, "A68_REF"); if (IS (row_mode, REF_SYMBOL) && IS (SUB (row_mode), ROW_SYMBOL)) { indentf (out, snprintf (line, SNPRINTF_SIZE, "GET_DESCRIPTOR (%s, %s, DEREF (A68_ROW, %s));\n", arr, tup, idf)); } else { ABEND (A68_TRUE, "strange mode in slice (execute)", NO_TEXT); } sign_in (BOOK_DECL, L_EXECUTE, NSYMBOL (p), (void *) indx, NUMBER (prim)); } else if (same_tree (indx, (NODE_T *) (INFO (entry))) == A68_FALSE) { (void) make_name (arr, ARR, "", NUMBER (entry)); (void) make_name (tup, TUP, "", NUMBER (entry)); (void) make_name (elm, ELM, "", NUMBER (prim)); (void) make_name (drf, DRF, "", NUMBER (prim)); } else { return; } indentf (out, snprintf (line, SNPRINTF_SIZE, "%s = ARRAY (%s);\n", elm, arr)); k = 0; inline_indexer (indx, out, L_EXECUTE, &k, NO_TEXT); indentf (out, snprintf (line, SNPRINTF_SIZE, "OFFSET (& %s) += ROW_ELEMENT (%s, ", elm, arr)); k = 0; inline_indexer (indx, out, L_YIELD, &k, tup); undentf (out, snprintf (line, SNPRINTF_SIZE, ");\n")); indentf (out, snprintf (line, SNPRINTF_SIZE, "%s = DEREF (%s, & %s);\n", drf, inline_mode (mode), elm)); } else if (phase == L_YIELD) { BOOK_T * entry = signed_in (BOOK_DECL, L_EXECUTE, symbol); if (entry != NO_BOOK && same_tree (indx, (NODE_T *) (INFO (entry))) == A68_TRUE) { (void) make_name (elm, ELM, "", NUMBER (entry)); } else { (void) make_name (elm, ELM, "", NUMBER (prim)); } undentf (out, snprintf (line, SNPRINTF_SIZE, "(&%s)", elm)); } } /*! \brief code slice [] MODE -> MODE \param p starting node \param out object file \param phase phase of code generation **/ static void inline_slice (NODE_T * p, FILE_T out, int phase) { NODE_T * prim = SUB (p); NODE_T * indx = NEXT (prim); MOID_T * mode = MOID (p); MOID_T * row_mode = DEFLEX (MOID (prim)); char * symbol = NSYMBOL (SUB (prim)); char drf[NAME_SIZE], idf[NAME_SIZE], arr[NAME_SIZE], tup[NAME_SIZE], elm[NAME_SIZE]; int k; if (phase == L_DECLARE) { BOOK_T * entry = signed_in (BOOK_DECL, L_DECLARE, symbol); if (entry == NO_BOOK) { (void) make_name (idf, symbol, "", NUMBER (prim)); (void) make_name (arr, ARR, "", NUMBER (prim)); (void) make_name (tup, TUP, "", NUMBER (prim)); (void) make_name (elm, ELM, "", NUMBER (prim)); (void) make_name (drf, DRF, "", NUMBER (prim)); indentf (out, snprintf (line, SNPRINTF_SIZE, "A68_REF * %s, %s; %s * %s; A68_ARRAY * %s; A68_TUPLE * %s;\n", idf, elm, inline_mode (mode), drf, arr, tup)); sign_in (BOOK_DECL, L_DECLARE, symbol, (void *) indx, NUMBER (prim)); } else if (same_tree (indx, (NODE_T *) (INFO (entry))) == A68_FALSE) { (void) make_name (elm, ELM, "", NUMBER (prim)); (void) make_name (drf, DRF, "", NUMBER (prim)); indentf (out, snprintf (line, SNPRINTF_SIZE, "A68_REF %s; %s * %s;\n", elm, inline_mode (mode), drf)); } k = 0; inline_indexer (indx, out, L_DECLARE, &k, NO_TEXT); } else if (phase == L_EXECUTE) { BOOK_T * entry = signed_in (BOOK_DECL, L_EXECUTE, symbol); if (entry == NO_BOOK) { NODE_T * pidf = locate (prim, IDENTIFIER); (void) make_name (idf, symbol, "", NUMBER (prim)); (void) make_name (arr, ARR, "", NUMBER (prim)); (void) make_name (tup, TUP, "", NUMBER (prim)); (void) make_name (elm, ELM, "", NUMBER (prim)); (void) make_name (drf, DRF, "", NUMBER (prim)); get_stack (pidf, out, idf, "A68_REF"); if (IS (row_mode, REF_SYMBOL)) { indentf (out, snprintf (line, SNPRINTF_SIZE, "GET_DESCRIPTOR (%s, %s, DEREF (A68_ROW, %s));\n", arr, tup, idf)); } else { indentf (out, snprintf (line, SNPRINTF_SIZE, "GET_DESCRIPTOR (%s, %s, (A68_ROW *) %s);\n", arr, tup, idf)); } sign_in (BOOK_DECL, L_EXECUTE, NSYMBOL (p), (void *) indx, NUMBER (prim)); } else if (same_tree (indx, (NODE_T *) (INFO (entry))) == A68_FALSE) { (void) make_name (arr, ARR, "", NUMBER (entry)); (void) make_name (tup, TUP, "", NUMBER (entry)); (void) make_name (elm, ELM, "", NUMBER (prim)); (void) make_name (drf, DRF, "", NUMBER (prim)); } else { return; } indentf (out, snprintf (line, SNPRINTF_SIZE, "%s = ARRAY (%s);\n", elm, arr)); k = 0; inline_indexer (indx, out, L_EXECUTE, &k, NO_TEXT); indentf (out, snprintf (line, SNPRINTF_SIZE, "OFFSET (& %s) += ROW_ELEMENT (%s, ", elm, arr)); k = 0; inline_indexer (indx, out, L_YIELD, &k, tup); undentf (out, snprintf (line, SNPRINTF_SIZE, ");\n")); indentf (out, snprintf (line, SNPRINTF_SIZE, "%s = DEREF (%s, & %s);\n", drf, inline_mode (mode), elm)); } else if (phase == L_YIELD) { BOOK_T * entry = signed_in (BOOK_DECL, L_EXECUTE, symbol); if (entry != NO_BOOK && same_tree (indx, (NODE_T *) (INFO (entry))) == A68_TRUE) { (void) make_name (drf, DRF, "", NUMBER (entry)); } else { (void) make_name (drf, DRF, "", NUMBER (prim)); } if (primitive_mode (mode)) { undentf (out, snprintf (line, SNPRINTF_SIZE, "_V_ (%s)", drf)); } else if (mode == MODE (COMPLEX)) { undentf (out, snprintf (line, SNPRINTF_SIZE, "(A68_REAL *) (%s)", drf)); } else if (LONG_MODE (mode)) { undentf (out, snprintf (line, SNPRINTF_SIZE, "(MP_T *) (%s)", drf)); } else if (basic_mode (mode)) { undentf (out, snprintf (line, SNPRINTF_SIZE, "%s", drf)); } else { ABEND (A68_TRUE, "strange mode in slice (yield)", NO_TEXT); } } } /*! \brief code monadic formula \param p starting node \param out object file \param phase phase of code generation **/ static void inline_monadic_formula (NODE_T * p, FILE_T out, int phase) { NODE_T *op = SUB (p); NODE_T * rhs = NEXT (op); if (IS (p, MONADIC_FORMULA) && MOID (p) == MODE (COMPLEX)) { char acc[NAME_SIZE]; (void) make_name (acc, TMP, "", NUMBER (p)); if (phase == L_DECLARE) { (void) add_declaration (&root_idf, inline_mode (MODE (COMPLEX)), 0, acc); inline_unit (rhs, out, L_DECLARE); } else if (phase == L_EXECUTE) { int k; inline_unit (rhs, out, L_EXECUTE); for (k = 0; PROCEDURE (&monadics[k]) != NO_GPROC; k ++) { if (PROCEDURE (TAX (op)) == PROCEDURE (&monadics[k])) { indentf (out, snprintf (line, SNPRINTF_SIZE, "%s (%s, ", CODE (&monadics[k]), acc)); inline_unit (rhs, out, L_YIELD); undentf (out, snprintf (line, SNPRINTF_SIZE, ");\n")); } } } else if (phase == L_YIELD) { undentf (out, snprintf (line, SNPRINTF_SIZE, "%s", acc)); } } else if (IS (p, MONADIC_FORMULA) && LONG_MODE (MOID (rhs))) { char acc[NAME_SIZE]; (void) make_name (acc, TMP, "", NUMBER (p)); if (phase == L_DECLARE) { (void) add_declaration (&root_idf, inline_mode (MOID (p)), 0, acc); inline_unit (rhs, out, L_DECLARE); } else if (phase == L_EXECUTE) { int k; inline_unit (rhs, out, L_EXECUTE); for (k = 0; PROCEDURE (&monadics[k]) != NO_GPROC; k ++) { if (PROCEDURE (TAX (op)) == PROCEDURE (&monadics[k])) { if (LONG_MODE (MOID (p))) { indentf (out, snprintf (line, SNPRINTF_SIZE, "%s (_N_ (%d), %s, ", CODE (&monadics[k]), NUMBER (op), acc)); } else { indentf (out, snprintf (line, SNPRINTF_SIZE, "%s (_N_ (%d), & %s, ", CODE (&monadics[k]), NUMBER (op), acc)); } inline_unit (rhs, out, L_YIELD); undentf (out, snprintf (line, SNPRINTF_SIZE, ", %d);\n", LONG_MP_DIGITS)); } } } else if (phase == L_YIELD) { undentf (out, snprintf (line, SNPRINTF_SIZE, "%s", acc)); } } else if (IS (p, MONADIC_FORMULA) && basic_mode (MOID (p))) { if (phase != L_YIELD) { inline_unit (rhs, out, phase); } else { int k; for (k = 0; PROCEDURE (&monadics[k]) != NO_GPROC; k ++) { if (PROCEDURE (TAX (op)) == PROCEDURE (&monadics[k])) { if (IS_ALNUM ((CODE (&monadics[k]))[0])) { undent (out, CODE (&monadics[k])); undent (out, "("); inline_unit (rhs, out, L_YIELD); undent (out, ")"); } else { undent (out, CODE (&monadics[k])); undent (out, "("); inline_unit (rhs, out, L_YIELD); undent (out, ")"); } } } } } } /*! \brief code dyadic formula \param p starting node \param out object file \param phase phase of code generation **/ static void inline_formula (NODE_T * p, FILE_T out, int phase) { NODE_T * lhs = SUB (p), *rhs; NODE_T * op = NEXT (lhs); if (IS (p, FORMULA) && op == NO_NODE) { inline_monadic_formula (lhs, out, phase); return; } rhs = NEXT (op); if (IS (p, FORMULA) && MOID (p) == MODE (COMPLEX)) { if (op == NO_NODE) { inline_monadic_formula (lhs, out, phase); } else if (phase == L_DECLARE) { char acc[NAME_SIZE]; (void) make_name (acc, TMP, "", NUMBER (p)); (void) add_declaration (&root_idf, inline_mode (MOID (p)), 0, acc); inline_unit (lhs, out, L_DECLARE); inline_unit (rhs, out, L_DECLARE); } else if (phase == L_EXECUTE) { char acc[NAME_SIZE]; int k; (void) make_name (acc, TMP, "", NUMBER (p)); inline_unit (lhs, out, L_EXECUTE); inline_unit (rhs, out, L_EXECUTE); for (k = 0; PROCEDURE (&dyadics[k]) != NO_GPROC; k ++) { if (PROCEDURE (TAX (op)) == PROCEDURE (&dyadics[k])) { if (MOID (p) == MODE (COMPLEX)) { indentf (out, snprintf (line, SNPRINTF_SIZE, "%s (%s, ", CODE (&dyadics[k]), acc)); } else { indentf (out, snprintf (line, SNPRINTF_SIZE, "%s (& %s, ", CODE (&dyadics[k]), acc)); } inline_unit (lhs, out, L_YIELD); undentf (out, snprintf (line, SNPRINTF_SIZE, ", ")); inline_unit (rhs, out, L_YIELD); undentf (out, snprintf (line, SNPRINTF_SIZE, ");\n")); } } } else if (phase == L_YIELD) { char acc[NAME_SIZE]; (void) make_name (acc, TMP, "", NUMBER (p)); if (MOID (p) == MODE (COMPLEX)) { undentf (out, snprintf (line, SNPRINTF_SIZE, "%s", acc)); } else { undentf (out, snprintf (line, SNPRINTF_SIZE, "_V_ (& %s)", acc)); } } } else if (IS (p, FORMULA) && LONG_MODE (MOID (lhs)) && LONG_MODE (MOID (rhs))) { char acc[NAME_SIZE]; (void) make_name (acc, TMP, "", NUMBER (p)); if (phase == L_DECLARE) { (void) add_declaration (&root_idf, inline_mode (MOID (p)), 0, acc); inline_unit (lhs, out, L_DECLARE); inline_unit (rhs, out, L_DECLARE); } else if (phase == L_EXECUTE) { int k; inline_unit (lhs, out, L_EXECUTE); inline_unit (rhs, out, L_EXECUTE); for (k = 0; PROCEDURE (&dyadics[k]) != NO_GPROC; k ++) { if (PROCEDURE (TAX (op)) == PROCEDURE (&dyadics[k])) { if (LONG_MODE (MOID (p))) { indentf (out, snprintf (line, SNPRINTF_SIZE, "%s (_N_ (%d), %s, ", CODE (&dyadics[k]), NUMBER (op), acc)); } else { indentf (out, snprintf (line, SNPRINTF_SIZE, "%s (_N_ (%d), & %s, ", CODE (&dyadics[k]), NUMBER (op), acc)); } inline_unit (lhs, out, L_YIELD); undentf (out, snprintf (line, SNPRINTF_SIZE, ", ")); inline_unit (rhs, out, L_YIELD); undentf (out, snprintf (line, SNPRINTF_SIZE, ", %d);\n", LONG_MP_DIGITS)); } } } else if (phase == L_YIELD) { if (LONG_MODE (MOID (p))) { undentf (out, snprintf (line, SNPRINTF_SIZE, "%s", acc)); } else { undentf (out, snprintf (line, SNPRINTF_SIZE, "_V_ (& %s)", acc)); } } } else if (IS (p, FORMULA) && basic_mode (MOID (p))) { if (phase != L_YIELD) { inline_unit (lhs, out, phase); inline_unit (rhs, out, phase); } else { int k; for (k = 0; PROCEDURE (&dyadics[k]) != NO_GPROC; k ++) { if (PROCEDURE (TAX (op)) == PROCEDURE (&dyadics[k])) { if (IS_ALNUM ((CODE (&dyadics[k]))[0])) { undent (out, CODE (&dyadics[k])); undent (out, "("); inline_unit (lhs, out, L_YIELD); undent (out, ", "); inline_unit (rhs, out, L_YIELD); undent (out, ")"); } else { undent (out, "("); inline_unit (lhs, out, L_YIELD); undent (out, " "); undent (out, CODE (&dyadics[k])); undent (out, " "); inline_unit (rhs, out, L_YIELD); undent (out, ")"); } } } } } } /*! \brief code argument \param p starting node \return same **/ static void inline_single_argument (NODE_T * p, FILE_T out, int phase) { for (; p != NO_NODE; FORWARD (p)) { if (IS (p, ARGUMENT_LIST) || IS (p, ARGUMENT)) { inline_single_argument (SUB (p), out, phase); } else if (IS (p, GENERIC_ARGUMENT_LIST) || IS (p, GENERIC_ARGUMENT)) { inline_single_argument (SUB (p), out, phase); } else if (IS (p, UNIT)) { inline_unit (p, out, phase); } } } /*! \brief code call \param p starting node \return same **/ static void inline_call (NODE_T * p, FILE_T out, int phase) { NODE_T * prim = SUB (p); NODE_T * args = NEXT (prim); NODE_T * idf = locate (prim, IDENTIFIER); if (MOID (p) == MODE (COMPLEX)) { char acc[NAME_SIZE]; (void) make_name (acc, TMP, "", NUMBER (p)); if (phase == L_DECLARE) { (void) add_declaration (&root_idf, inline_mode (MODE (COMPLEX)), 0, acc); inline_single_argument (args, out, L_DECLARE); } else if (phase == L_EXECUTE) { int k; inline_single_argument (args, out, L_EXECUTE); for (k = 0; PROCEDURE (&functions[k]) != NO_GPROC; k ++) { if (PROCEDURE (TAX (idf)) == PROCEDURE (&functions[k])) { indentf (out, snprintf (line, SNPRINTF_SIZE, "%s (%s, ", CODE (&functions[k]), acc)); inline_single_argument (args, out, L_YIELD); undentf (out, snprintf (line, SNPRINTF_SIZE, ");\n")); } } } else if (phase == L_YIELD) { undentf (out, snprintf (line, SNPRINTF_SIZE, "%s", acc)); } } else if (LONG_MODE (MOID (p))) { char acc[NAME_SIZE]; (void) make_name (acc, TMP, "", NUMBER (p)); if (phase == L_DECLARE) { (void) add_declaration (&root_idf, inline_mode (MOID (p)), 0, acc); inline_single_argument (args, out, L_DECLARE); } else if (phase == L_EXECUTE) { int k; inline_single_argument (args, out, L_EXECUTE); for (k = 0; PROCEDURE (&functions[k]) != NO_GPROC; k ++) { if (PROCEDURE (TAX (idf)) == PROCEDURE (&functions[k])) { indentf (out, snprintf (line, SNPRINTF_SIZE, "%s (_N_ (%d), %s, ", CODE (&functions[k]), NUMBER (idf), acc)); inline_single_argument (args, out, L_YIELD); undentf (out, snprintf (line, SNPRINTF_SIZE, ", %d);\n", LONG_MP_DIGITS)); } } } else if (phase == L_YIELD) { undentf (out, snprintf (line, SNPRINTF_SIZE, "%s", acc)); } } else if (basic_mode (MOID (p))) { if (phase != L_YIELD) { inline_single_argument (args, out, phase); } else { int k; for (k = 0; PROCEDURE (&functions[k]) != NO_GPROC; k ++) { if (PROCEDURE (TAX (idf)) == PROCEDURE (&functions[k])) { undent (out, CODE (&functions[k])); undent (out, " ("); inline_single_argument (args, out, L_YIELD); undent (out, ")"); } } } } } /*! \brief code collateral units \param out output file descriptor \param p starting node **/ static void inline_collateral_units (NODE_T * p, FILE_T out, int phase) { if (p == NO_NODE) { return; } else if (IS (p, UNIT)) { if (phase == L_DECLARE) { inline_unit (SUB (p), out, L_DECLARE); } else if (phase == L_EXECUTE) { inline_unit (SUB (p), out, L_EXECUTE); } else if (phase == L_YIELD) { indentf (out, snprintf (line, SNPRINTF_SIZE, "PUSH_PRIMITIVE (p, ")); inline_unit (SUB (p), out, L_YIELD); undentf (out, snprintf (line, SNPRINTF_SIZE, ", %s);\n", inline_mode (MOID (p)))); } } else { inline_collateral_units (SUB (p), out, phase); inline_collateral_units (NEXT (p), out, phase); } } /*! \brief code collateral units \param out output file descriptor \param p starting node **/ static void inline_collateral (NODE_T * p, FILE_T out, int phase) { char dsp[NAME_SIZE]; (void) make_name (dsp, DSP, "", NUMBER (p)); if (p == NO_NODE) { return; } else if (phase == L_DECLARE) { if (MOID (p) == MODE (COMPLEX)) { (void) add_declaration (&root_idf, inline_mode (MODE (REAL)), 1, dsp); } else { (void) add_declaration (&root_idf, inline_mode (MOID (p)), 1, dsp); } inline_collateral_units (NEXT_SUB (p), out, L_DECLARE); } else if (phase == L_EXECUTE) { if (MOID (p) == MODE (COMPLEX)) { indentf (out, snprintf (line, SNPRINTF_SIZE, "%s = (%s *) STACK_TOP;\n", dsp, inline_mode (MODE (REAL)))); } else { indentf (out, snprintf (line, SNPRINTF_SIZE, "%s = (%s *) STACK_TOP;\n", dsp, inline_mode (MOID (p)))); } inline_collateral_units (NEXT_SUB (p), out, L_EXECUTE); inline_collateral_units (NEXT_SUB (p), out, L_YIELD); } else if (phase == L_YIELD) { undentf (out, snprintf (line, SNPRINTF_SIZE, "%s", dsp)); } } /*! \brief code basic closed clause \param p starting node \param out object file \param phase phase of code generation **/ static void inline_closed (NODE_T * p, FILE_T out, int phase) { if (p == NO_NODE) { return; } else if (phase != L_YIELD) { inline_unit (SUB (NEXT_SUB (p)), out, phase); } else { undent (out, "("); inline_unit (SUB (NEXT_SUB (p)), out, L_YIELD); undent (out, ")"); } } /*! \brief code basic closed clause \param p starting node \param out object file \param phase phase of code generation **/ static void inline_conditional (NODE_T * p, FILE_T out, int phase) { NODE_T * if_part = NO_NODE, * then_part = NO_NODE, * else_part = NO_NODE; p = SUB (p); if (IS (p, IF_PART) || IS (p, OPEN_PART)) { if_part = p; } else { ABEND (A68_TRUE, "if-part expected", NO_TEXT); } FORWARD (p); if (IS (p, THEN_PART) || IS (p, CHOICE)) { then_part = p; } else { ABEND (A68_TRUE, "then-part expected", NO_TEXT); } FORWARD (p); if (IS (p, ELSE_PART) || IS (p, CHOICE)) { else_part = p; } else { else_part = NO_NODE; } if (phase == L_DECLARE) { inline_unit (SUB (NEXT_SUB (if_part)), out, L_DECLARE); inline_unit (SUB (NEXT_SUB (then_part)), out, L_DECLARE); inline_unit (SUB (NEXT_SUB (else_part)), out, L_DECLARE); } else if (phase == L_EXECUTE) { inline_unit (SUB (NEXT_SUB (if_part)), out, L_EXECUTE); inline_unit (SUB (NEXT_SUB (then_part)), out, L_EXECUTE); inline_unit (SUB (NEXT_SUB (else_part)), out, L_EXECUTE); } else if (phase == L_YIELD) { undent (out, "("); inline_unit (SUB (NEXT_SUB (if_part)), out, L_YIELD); undent (out, " ? "); inline_unit (SUB (NEXT_SUB (then_part)), out, L_YIELD); undent (out, " : "); if (else_part != NO_NODE) { inline_unit (SUB (NEXT_SUB (else_part)), out, L_YIELD); } else { /* This is not an ideal solution although RR permits it; an omitted else-part means SKIP: yield some value of the mode required. */ inline_unit (SUB (NEXT_SUB (then_part)), out, L_YIELD); } undent (out, ")"); } } /*! \brief code dereferencing of selection \param p starting node \param out object file \param phase phase of code generation **/ static void inline_dereference_selection (NODE_T * p, FILE_T out, int phase) { NODE_T * field = SUB (p); NODE_T * sec = NEXT (field); NODE_T * idf = locate (sec, IDENTIFIER); char ref[NAME_SIZE], sel[NAME_SIZE]; char * field_idf = NSYMBOL (SUB (field)); if (phase == L_DECLARE) { BOOK_T * entry = signed_in (BOOK_DECL, L_DECLARE, NSYMBOL (idf)); if (entry == NO_BOOK) { (void) make_name (ref, NSYMBOL (idf), "", NUMBER (field)); (void) add_declaration (&root_idf, "A68_REF", 1, ref); sign_in (BOOK_DECL, L_DECLARE, NSYMBOL (idf), NULL, NUMBER (field)); } if (entry == NO_BOOK || field_idf != (char *) (INFO (entry))) { (void) make_name (sel, SEL, "", NUMBER (field)); (void) add_declaration (&root_idf, inline_mode (SUB_MOID (field)), 1, sel); sign_in (BOOK_DECL, L_DECLARE, NSYMBOL (idf), (void *) field_idf, NUMBER (field)); } inline_unit (sec, out, L_DECLARE); } else if (phase == L_EXECUTE) { BOOK_T * entry = signed_in (BOOK_DECL, L_EXECUTE, NSYMBOL (idf)); if (entry == NO_BOOK) { (void) make_name (ref, NSYMBOL (idf), "", NUMBER (field)); get_stack (idf, out, ref, "A68_REF"); sign_in (BOOK_DECL, L_EXECUTE, NSYMBOL (idf), NULL, NUMBER (field)); } if (entry == NO_BOOK) { (void) make_name (ref, NSYMBOL (idf), "", NUMBER (field)); (void) make_name (sel, SEL, "", NUMBER (field)); indentf (out, snprintf (line, SNPRINTF_SIZE, "%s = (%s *) & (ADDRESS (%s)[%d]);\n", sel, inline_mode (SUB_MOID (field)), ref, OFFSET_OFF (field))); sign_in (BOOK_DECL, L_EXECUTE, NSYMBOL (idf), (void *) field_idf, NUMBER (field)); } else if (field_idf != (char *) (INFO (entry))) { (void) make_name (ref, NSYMBOL (idf), "", NUMBER (entry)); (void) make_name (sel, SEL, "", NUMBER (field)); indentf (out, snprintf (line, SNPRINTF_SIZE, "%s = (%s *) & (ADDRESS (%s)[%d]);\n", sel, inline_mode (SUB_MOID (field)), ref, OFFSET_OFF (field))); sign_in (BOOK_DECL, L_EXECUTE, NSYMBOL (idf), (void *) field_idf, NUMBER (field)); } inline_unit (sec, out, L_EXECUTE); } else if (phase == L_YIELD) { BOOK_T * entry = signed_in (BOOK_DECL, L_EXECUTE, NSYMBOL (idf)); if (entry != NO_BOOK && (char *) (INFO (entry)) == field_idf) { (void) make_name (sel, SEL, "", NUMBER (entry)); } else { (void) make_name (sel, SEL, "", NUMBER (field)); } if (primitive_mode (SUB_MOID (p))) { undentf (out, snprintf (line, SNPRINTF_SIZE, "_V_ (%s)", sel)); } else if (SUB_MOID (p) == MODE (COMPLEX)) { undentf (out, snprintf (line, SNPRINTF_SIZE, "(A68_REAL *) (%s)", sel)); } else if (LONG_MODE (SUB_MOID (p))) { undentf (out, snprintf (line, SNPRINTF_SIZE, "(MP_T *) (%s)", sel)); } else if (basic_mode (SUB_MOID (p))) { undent (out, sel); } else { ABEND (A68_TRUE, "strange mode in dereference selection (yield)", NO_TEXT); } } } /*! \brief code selection \param p starting node \param out object file \param phase phase of code generation **/ static void inline_selection (NODE_T * p, FILE_T out, int phase) { NODE_T * field = SUB (p); NODE_T * sec = NEXT (field); NODE_T * idf = locate (sec, IDENTIFIER); char ref[NAME_SIZE], sel[NAME_SIZE]; char * field_idf = NSYMBOL (SUB (field)); if (phase == L_DECLARE) { BOOK_T * entry = signed_in (BOOK_DECL, L_DECLARE, NSYMBOL (idf)); if (entry == NO_BOOK) { (void) make_name (ref, NSYMBOL (idf), "", NUMBER (field)); (void) add_declaration (&root_idf, "A68_STRUCT", 0, ref); sign_in (BOOK_DECL, L_DECLARE, NSYMBOL (idf), NULL, NUMBER (field)); } if (entry == NO_BOOK || field_idf != (char *) (INFO (entry))) { (void) make_name (sel, SEL, "", NUMBER (field)); (void) add_declaration (&root_idf, inline_mode (MOID (field)), 1, sel); sign_in (BOOK_DECL, L_DECLARE, NSYMBOL (idf), (void *) field_idf, NUMBER (field)); } inline_unit (sec, out, L_DECLARE); } else if (phase == L_EXECUTE) { BOOK_T * entry = signed_in (BOOK_DECL, L_EXECUTE, NSYMBOL (idf)); if (entry == NO_BOOK) { (void) make_name (ref, NSYMBOL (idf), "", NUMBER (field)); get_stack (idf, out, ref, "BYTE_T"); (void) make_name (sel, SEL, "", NUMBER (field)); indentf (out, snprintf (line, SNPRINTF_SIZE, "%s = (%s *) & (%s[%d]);\n", sel, inline_mode (MOID (field)), ref, OFFSET_OFF (field))); sign_in (BOOK_DECL, L_EXECUTE, NSYMBOL (idf), (void *) field_idf, NUMBER (field)); } else if (field_idf != (char *) (INFO (entry))) { (void) make_name (ref, NSYMBOL (idf), "", NUMBER (entry)); (void) make_name (sel, SEL, "", NUMBER (field)); indentf (out, snprintf (line, SNPRINTF_SIZE, "%s = (%s *) & (%s[%d]);\n", sel, inline_mode (MOID (field)), ref, OFFSET_OFF (field))); sign_in (BOOK_DECL, L_EXECUTE, NSYMBOL (idf), (void *) field_idf, NUMBER (field)); } inline_unit (sec, out, L_EXECUTE); } else if (phase == L_YIELD) { BOOK_T * entry = signed_in (BOOK_DECL, L_EXECUTE, NSYMBOL (idf)); if (entry != NO_BOOK && (char *) (INFO (entry)) == field_idf) { (void) make_name (sel, SEL, "", NUMBER (entry)); } else { (void) make_name (sel, SEL, "", NUMBER (field)); } if (primitive_mode (MOID (p))) { undentf (out, snprintf (line, SNPRINTF_SIZE, "_V_ (%s)", sel)); } else { ABEND (A68_TRUE, "strange mode in selection (yield)", NO_TEXT); } } } /*! \brief code selection \param p starting node \param out object file \param phase phase of code generation **/ static void inline_selection_ref_to_ref (NODE_T * p, FILE_T out, int phase) { NODE_T * field = SUB (p); NODE_T * sec = NEXT (field); NODE_T * idf = locate (sec, IDENTIFIER); char ref[NAME_SIZE], sel[NAME_SIZE]; char * field_idf = NSYMBOL (SUB (field)); if (phase == L_DECLARE) { BOOK_T * entry = signed_in (BOOK_DECL, L_DECLARE, NSYMBOL (idf)); if (entry == NO_BOOK) { (void) make_name (ref, NSYMBOL (idf), "", NUMBER (field)); (void) add_declaration (&root_idf, "A68_REF", 1, ref); sign_in (BOOK_DECL, L_DECLARE, NSYMBOL (idf), NULL, NUMBER (field)); } if (entry == NO_BOOK || field_idf != (char *) (INFO (entry))) { (void) make_name (sel, SEL, "", NUMBER (field)); (void) add_declaration (&root_idf, "A68_REF", 0, sel); sign_in (BOOK_DECL, L_DECLARE, NSYMBOL (idf), (void *) field_idf, NUMBER (field)); } inline_unit (sec, out, L_DECLARE); } else if (phase == L_EXECUTE) { BOOK_T * entry = signed_in (BOOK_DECL, L_EXECUTE_2, NSYMBOL (idf)); if (entry == NO_BOOK) { (void) make_name (ref, NSYMBOL (idf), "", NUMBER (field)); get_stack (idf, out, ref, "A68_REF"); (void) make_name (sel, SEL, "", NUMBER (field)); sign_in (BOOK_DECL, L_EXECUTE_2, NSYMBOL (idf), (void *) field_idf, NUMBER (field)); } else if (field_idf != (char *) (INFO (entry))) { (void) make_name (ref, NSYMBOL (idf), "", NUMBER (entry)); (void) make_name (sel, SEL, "", NUMBER (field)); sign_in (BOOK_DECL, L_EXECUTE_2, NSYMBOL (idf), (void *) field_idf, NUMBER (field)); } indentf (out, snprintf (line, SNPRINTF_SIZE, "%s = *%s;\n", sel, ref)); indentf (out, snprintf (line, SNPRINTF_SIZE, "OFFSET (&%s) += %d;\n", sel, OFFSET_OFF (field))); inline_unit (sec, out, L_EXECUTE); } else if (phase == L_YIELD) { BOOK_T * entry = signed_in (BOOK_DECL, L_EXECUTE, NSYMBOL (idf)); if (entry != NO_BOOK && (char *) (INFO (entry)) == field_idf) { (void) make_name (sel, SEL, "", NUMBER (entry)); } else { (void) make_name (sel, SEL, "", NUMBER (field)); } if (primitive_mode (SUB_MOID (p))) { undentf (out, snprintf (line, SNPRINTF_SIZE, "(&%s)", sel)); } else { ABEND (A68_TRUE, "strange mode in selection (yield)", NO_TEXT); } } } /*! \brief code identifier \param p starting node \param out object file \param phase phase of code generation **/ static void inline_ref_identifier (NODE_T * p, FILE_T out, int phase) { /* No folding - consider identifier */ if (phase == L_DECLARE) { if (signed_in (BOOK_DECL, L_DECLARE, NSYMBOL (p)) != NO_BOOK) { return; } else { char idf[NAME_SIZE]; (void) make_name (idf, NSYMBOL (p), "", NUMBER (p)); (void) add_declaration (&root_idf, "A68_REF", 1, idf); sign_in (BOOK_DECL, L_DECLARE, NSYMBOL (p), NULL, NUMBER (p)); } } else if (phase == L_EXECUTE) { if (signed_in (BOOK_DECL, L_EXECUTE, NSYMBOL (p)) != NO_BOOK) { return; } else { char idf[NAME_SIZE]; (void) make_name (idf, NSYMBOL (p), "", NUMBER (p)); get_stack (p, out, idf, "A68_REF"); sign_in (BOOK_DECL, L_EXECUTE, NSYMBOL (p), NULL, NUMBER (p)); } } else if (phase == L_YIELD) { char idf[NAME_SIZE]; BOOK_T * entry = signed_in (BOOK_DECL, L_EXECUTE, NSYMBOL (p)); if (entry != NO_BOOK) { (void) make_name (idf, NSYMBOL (p), "", NUMBER (entry)); } else { (void) make_name (idf, NSYMBOL (p), "", NUMBER (p)); } undent (out, idf); } } /*! \brief code identity-relation \param p starting node \param out output file descriptor **/ static void inline_identity_relation (NODE_T * p, FILE_T out, int phase) { #define GOOD(p) (locate (p, IDENTIFIER) != NO_NODE && IS (MOID (locate ((p), IDENTIFIER)), REF_SYMBOL)) NODE_T * lhs = SUB (p); NODE_T * op = NEXT (lhs); NODE_T * rhs = NEXT (op); if (GOOD (lhs) && GOOD (rhs)) { if (phase == L_DECLARE) { NODE_T * lidf = locate (lhs, IDENTIFIER); NODE_T * ridf = locate (rhs, IDENTIFIER); inline_ref_identifier (lidf, out, L_DECLARE); inline_ref_identifier (ridf, out, L_DECLARE); } else if (phase == L_EXECUTE) { NODE_T * lidf = locate (lhs, IDENTIFIER); NODE_T * ridf = locate (rhs, IDENTIFIER); inline_ref_identifier (lidf, out, L_EXECUTE); inline_ref_identifier (ridf, out, L_EXECUTE); } else if (phase == L_YIELD) { NODE_T * lidf = locate (lhs, IDENTIFIER); NODE_T * ridf = locate (rhs, IDENTIFIER); if (IS (op, IS_SYMBOL)) { undentf (out, snprintf (line, SNPRINTF_SIZE, "ADDRESS (")); inline_ref_identifier (lidf, out, L_YIELD); undentf (out, snprintf (line, SNPRINTF_SIZE, ") == ADDRESS (")); inline_ref_identifier (ridf, out, L_YIELD); undentf (out, snprintf (line, SNPRINTF_SIZE, ")")); } else { undentf (out, snprintf (line, SNPRINTF_SIZE, "ADDRESS (")); inline_ref_identifier (lidf, out, L_YIELD); undentf (out, snprintf (line, SNPRINTF_SIZE, ") != ADDRESS (")); inline_ref_identifier (ridf, out, L_YIELD); undentf (out, snprintf (line, SNPRINTF_SIZE, ")")); } } } else if (GOOD (lhs) && locate (rhs, NIHIL) != NO_NODE) { if (phase == L_DECLARE) { NODE_T * lidf = locate (lhs, IDENTIFIER); inline_ref_identifier (lidf, out, L_DECLARE); } else if (phase == L_EXECUTE) { NODE_T * lidf = locate (lhs, IDENTIFIER); inline_ref_identifier (lidf, out, L_EXECUTE); } else if (phase == L_YIELD) { NODE_T * lidf = locate (lhs, IDENTIFIER); if (IS (op, IS_SYMBOL)) { indentf (out, snprintf (line, SNPRINTF_SIZE, "IS_NIL (*")); inline_ref_identifier (lidf, out, L_YIELD); undentf (out, snprintf (line, SNPRINTF_SIZE, ")")); } else { indentf (out, snprintf (line, SNPRINTF_SIZE, "!IS_NIL (*")); inline_ref_identifier (lidf, out, L_YIELD); undentf (out, snprintf (line, SNPRINTF_SIZE, ")")); } } } #undef GOOD } /*! \brief code unit \param p starting node \param out object file \param phase phase of code generation **/ static void inline_unit (NODE_T * p, FILE_T out, int phase) { if (p == NO_NODE) { return; } else if (constant_unit (p) && locate (p, DENOTATION) == NO_NODE) { constant_folder (p, out, phase); } else if (IS (p, UNIT)) { inline_unit (SUB (p), out, phase); } else if (IS (p, TERTIARY)) { inline_unit (SUB (p), out, phase); } else if (IS (p, SECONDARY)) { inline_unit (SUB (p), out, phase); } else if (IS (p, PRIMARY)) { inline_unit (SUB (p), out, phase); } else if (IS (p, ENCLOSED_CLAUSE)) { inline_unit (SUB (p), out, phase); } else if (IS (p, CLOSED_CLAUSE)) { inline_closed (p, out, phase); } else if (IS (p, COLLATERAL_CLAUSE)) { inline_collateral (p, out, phase); } else if (IS (p, CONDITIONAL_CLAUSE)) { inline_conditional (p, out, phase); } else if (IS (p, WIDENING)) { inline_widening (p, out, phase); } else if (IS (p, IDENTIFIER)) { inline_identifier (p, out, phase); } else if (IS (p, DEREFERENCING) && locate (SUB (p), IDENTIFIER) != NO_NODE) { inline_dereference_identifier (p, out, phase); } else if (IS (p, SLICE)) { NODE_T * prim = SUB (p); MOID_T * mode = MOID (p); MOID_T * row_mode = DEFLEX (MOID (prim)); if (mode == SUB (row_mode)) { inline_slice (p, out, phase); } else if (IS (mode, REF_SYMBOL) && IS (row_mode, REF_SYMBOL) && SUB (mode) == SUB_SUB (row_mode)) { inline_slice_ref_to_ref (p, out, phase); } else { ABEND (A68_TRUE, "strange mode for slice", NO_TEXT); } } else if (IS (p, DEREFERENCING) && locate (SUB (p), SLICE) != NO_NODE) { inline_dereference_slice (SUB (p), out, phase); } else if (IS (p, DEREFERENCING) && locate (SUB (p), SELECTION) != NO_NODE) { inline_dereference_selection (SUB (p), out, phase); } else if (IS (p, SELECTION)) { NODE_T * sec = NEXT_SUB (p); MOID_T * mode = MOID (p); MOID_T * struct_mode = MOID (sec); if (IS (struct_mode, REF_SYMBOL) && IS (mode, REF_SYMBOL)) { inline_selection_ref_to_ref (p, out, phase); } else if (IS (struct_mode, STRUCT_SYMBOL) && primitive_mode (mode)) { inline_selection (p, out, phase); } else { ABEND (A68_TRUE, "strange mode for selection", NO_TEXT); } } else if (IS (p, DENOTATION)) { inline_denotation (p, out, phase); } else if (IS (p, MONADIC_FORMULA)) { inline_monadic_formula (p, out, phase); } else if (IS (p, FORMULA)) { inline_formula (p, out, phase); } else if (IS (p, CALL)) { inline_call (p, out, phase); } else if (IS (p, CAST)) { inline_unit (NEXT_SUB (p), out, phase); } else if (IS (p, IDENTITY_RELATION)) { inline_identity_relation (p, out, phase); } } /*********************************/ /* COMPILATION OF COMPLETE UNITS */ /*********************************/ /*! \brief compile code clause \param out output file descriptor \param p starting node \return function name or NO_NODE **/ static void embed_code_clause (NODE_T * p, FILE_T out) { for (; p != NO_NODE; FORWARD (p)) { if (IS (p, ROW_CHAR_DENOTATION)) { indentf (out, snprintf (line, SNPRINTF_SIZE, "%s\n", NSYMBOL (p))); } embed_code_clause (SUB (p), out); } } /*! \brief compile push \param p starting node \param out output file descriptor **/ static void compile_push (NODE_T * p, FILE_T out) { if (primitive_mode (MOID (p))) { indentf (out, snprintf (line, SNPRINTF_SIZE, "PUSH_PRIMITIVE (p, ")); inline_unit (p, out, L_YIELD); undentf (out, snprintf (line, SNPRINTF_SIZE, ", %s);\n", inline_mode (MOID (p)))); } else if (basic_mode (MOID (p))) { indentf (out, snprintf (line, SNPRINTF_SIZE, "MOVE ((void *) STACK_TOP, (void *) ")); inline_unit (p, out, L_YIELD); undentf (out, snprintf (line, SNPRINTF_SIZE, ", %d);\n", MOID_SIZE (MOID (p)))); indentf (out, snprintf (line, SNPRINTF_SIZE, "stack_pointer += %d;\n", MOID_SIZE (MOID (p)))); } else { ABEND (A68_TRUE, "cannot push", moid_to_string (MOID (p), 80, NO_NODE)); } } /*! \brief compile assign (C source to C destination) \param p starting node \param out output file descriptor **/ static void compile_assign (NODE_T * p, FILE_T out, char * dst) { if (primitive_mode (MOID (p))) { indentf (out, snprintf (line, SNPRINTF_SIZE, "_S_ (%s) = INIT_MASK;\n", dst)); indentf (out, snprintf (line, SNPRINTF_SIZE, "_V_ (%s) = ", dst)); inline_unit (p, out, L_YIELD); undent (out, ";\n"); } else if (LONG_MODE (MOID (p))) { indentf (out, snprintf (line, SNPRINTF_SIZE, "MOVE_MP ((void *) %s, (void *) ", dst)); inline_unit (p, out, L_YIELD); undentf (out, snprintf (line, SNPRINTF_SIZE, ", %d);\n", LONG_MP_DIGITS)); } else if (basic_mode (MOID (p))) { indentf (out, snprintf (line, SNPRINTF_SIZE, "MOVE ((void *) %s, (void *) ", dst)); inline_unit (p, out, L_YIELD); undentf (out, snprintf (line, SNPRINTF_SIZE, ", %d);\n", MOID_SIZE (MOID (p)))); } else { ABEND (A68_TRUE, "cannot assign", moid_to_string (MOID (p), 80, NO_NODE)); } } /*! \brief compile denotation \param p starting node \param out output file descriptor \return function name **/ static char * compile_denotation (NODE_T * p, FILE_T out, int compose_fun) { if (denotation_mode (MOID (p))) { static char fn[NAME_SIZE]; comment_source (p, out); (void) make_name (fn, "_denotation", "", NUMBER (p)); if (compose_fun == A68_MAKE_FUNCTION) { write_fun_prelude (p, out, fn); } root_idf = NO_DEC; inline_unit (p, out, L_DECLARE); print_declarations (out, root_idf); inline_unit (p, out, L_EXECUTE); if (primitive_mode (MOID (p))) { indentf (out, snprintf (line, SNPRINTF_SIZE, "PUSH_PRIMITIVE (p, ")); inline_unit (p, out, L_YIELD); undentf (out, snprintf (line, SNPRINTF_SIZE, ", %s);\n", inline_mode (MOID (p)))); } else { indentf (out, snprintf (line, SNPRINTF_SIZE, "PUSH (p, ")); inline_unit (p, out, L_YIELD); undentf (out, snprintf (line, SNPRINTF_SIZE, ", %d);\n", MOID_SIZE (MOID (p)))); } (void) make_name (fn, "_denotation", "", NUMBER (p)); if (compose_fun == A68_MAKE_FUNCTION) { write_fun_postlude (p, out, fn); } return (fn); } else { return (NO_TEXT); } } /*! \brief compile cast \param p starting node \param out output file descriptor \return function name **/ static char * compile_cast (NODE_T * p, FILE_T out, int compose_fun) { if (basic_unit (p)) { static char fn[NAME_SIZE]; comment_source (p, out); (void) make_name (fn, "_cast", "", NUMBER (p)); if (compose_fun == A68_MAKE_FUNCTION) { write_fun_prelude (p, out, fn); } root_idf = NO_DEC; inline_unit (NEXT_SUB (p), out, L_DECLARE); print_declarations (out, root_idf); inline_unit (NEXT_SUB (p), out, L_EXECUTE); compile_push (NEXT_SUB (p), out); if (compose_fun == A68_MAKE_FUNCTION) { (void) make_name (fn, "_cast", "", NUMBER (p)); write_fun_postlude (p, out, fn); } return (fn); } else { return (NO_TEXT); } } /*! \brief compile identifier \param p starting node \param out output file descriptor \return function name **/ static char * compile_identifier (NODE_T * p, FILE_T out, int compose_fun) { if (basic_mode (MOID (p)) && basic_unit (p)) { static char fn[NAME_SIZE]; comment_source (p, out); (void) make_name (fn, "_identifier", "", NUMBER (p)); if (compose_fun == A68_MAKE_FUNCTION) { write_fun_prelude (p, out, fn); } root_idf = NO_DEC; inline_unit (p, out, L_DECLARE); print_declarations (out, root_idf); inline_unit (p, out, L_EXECUTE); compile_push (p, out); (void) make_name (fn, "_identifier", "", NUMBER (p)); if (compose_fun == A68_MAKE_FUNCTION) { write_fun_postlude (p, out, fn); } return (fn); } else { return (NO_TEXT); } } /*! \brief compile dereference identifier \param p starting node \param out output file descriptor \return function name **/ static char * compile_dereference_identifier (NODE_T * p, FILE_T out, int compose_fun) { if (basic_mode (MOID (p)) && basic_unit (p)) { static char fn[NAME_SIZE]; comment_source (p, out); (void) make_name (fn, "_deref_identifier", "", NUMBER (p)); if (compose_fun == A68_MAKE_FUNCTION) { write_fun_prelude (p, out, fn); } root_idf = NO_DEC; inline_unit (p, out, L_DECLARE); print_declarations (out, root_idf); inline_unit (p, out, L_EXECUTE); compile_push (p, out); (void) make_name (fn, "_deref_identifier", "", NUMBER (p)); if (compose_fun == A68_MAKE_FUNCTION) { write_fun_postlude (p, out, fn); } return (fn); } else { return (NO_TEXT); } } /*! \brief compile slice \param p starting node \param out output file descriptor \return function name **/ static char * compile_slice (NODE_T * p, FILE_T out, int compose_fun) { if (basic_mode (MOID (p)) && basic_unit (p)) { static char fn[NAME_SIZE]; comment_source (p, out); (void) make_name (fn, "_slice", "", NUMBER (p)); if (compose_fun == A68_MAKE_FUNCTION) { write_fun_prelude (p, out, fn); } root_idf = NO_DEC; inline_unit (p, out, L_DECLARE); print_declarations (out, root_idf); inline_unit (p, out, L_EXECUTE); compile_push (p, out); if (compose_fun == A68_MAKE_FUNCTION) { (void) make_name (fn, "_slice", "", NUMBER (p)); write_fun_postlude (p, out, fn); } return (fn); } else { return (NO_TEXT); } } /*! \brief compile slice \param p starting node \param out output file descriptor \return function name **/ static char * compile_dereference_slice (NODE_T * p, FILE_T out, int compose_fun) { if (basic_mode (MOID (p)) && basic_unit (p)) { static char fn[NAME_SIZE]; comment_source (p, out); (void) make_name (fn, "_deref_slice", "", NUMBER (p)); if (compose_fun == A68_MAKE_FUNCTION) { write_fun_prelude (p, out, fn); } root_idf = NO_DEC; inline_unit (p, out, L_DECLARE); print_declarations (out, root_idf); inline_unit (p, out, L_EXECUTE); compile_push (p, out); if (compose_fun == A68_MAKE_FUNCTION) { (void) make_name (fn, "_deref_slice", "", NUMBER (p)); write_fun_postlude (p, out, fn); } return (fn); } else { return (NO_TEXT); } } /*! \brief compile selection \param p starting node \param out output file descriptor \return function name **/ static char * compile_selection (NODE_T * p, FILE_T out, int compose_fun) { if (basic_mode (MOID (p)) && basic_unit (p)) { static char fn[NAME_SIZE]; comment_source (p, out); (void) make_name (fn, "_selection", "", NUMBER (p)); if (compose_fun == A68_MAKE_FUNCTION) { write_fun_prelude (p, out, fn); } root_idf = NO_DEC; inline_unit (p, out, L_DECLARE); print_declarations (out, root_idf); inline_unit (p, out, L_EXECUTE); compile_push (p, out); if (compose_fun == A68_MAKE_FUNCTION) { (void) make_name (fn, "_selection", "", NUMBER (p)); write_fun_postlude (p, out, fn); } return (fn); } else { return (NO_TEXT); } } /*! \brief compile selection \param p starting node \param out output file descriptor \return function name **/ static char * compile_dereference_selection (NODE_T * p, FILE_T out, int compose_fun) { if (basic_mode (MOID (p)) && basic_unit (p)) { static char fn[NAME_SIZE]; comment_source (p, out); (void) make_name (fn, "_deref_selection", "", NUMBER (p)); if (compose_fun == A68_MAKE_FUNCTION) { write_fun_prelude (p, out, fn); } root_idf = NO_DEC; inline_unit (p, out, L_DECLARE); print_declarations (out, root_idf); inline_unit (p, out, L_EXECUTE); compile_push (p, out); if (compose_fun == A68_MAKE_FUNCTION) { (void) make_name (fn, "_deref_selection", "", NUMBER (p)); write_fun_postlude (p, out, fn); } return (fn); } else { return (NO_TEXT); } } /*! \brief compile formula \param p starting node \param out output file descriptor \return function name **/ static char * compile_formula (NODE_T * p, FILE_T out, int compose_fun) { if (basic_unit (p)) { static char fn[NAME_SIZE]; comment_source (p, out); (void) make_name (fn, "_formula", "", NUMBER (p)); if (compose_fun == A68_MAKE_FUNCTION) { write_fun_prelude (p, out, fn); } root_idf = NO_DEC; inline_unit (p, out, L_DECLARE); print_declarations (out, root_idf); inline_unit (p, out, L_EXECUTE); compile_push (p, out); if (compose_fun == A68_MAKE_FUNCTION) { (void) make_name (fn, "_formula", "", NUMBER (p)); write_fun_postlude (p, out, fn); } return (fn); } else { return (NO_TEXT); } } /*! \brief compile voiding formula \param p starting node \param out output file descriptor \return function name **/ static char * compile_voiding_formula (NODE_T * p, FILE_T out, int compose_fun) { if (basic_unit (p)) { static char fn[NAME_SIZE]; char pop[NAME_SIZE]; (void) make_name (pop, PUP, "", NUMBER (p)); comment_source (p, out); (void) make_name (fn, "_void_formula", "", NUMBER (p)); if (compose_fun == A68_MAKE_FUNCTION) { write_fun_prelude (p, out, fn); } root_idf = NO_DEC; (void) add_declaration (&root_idf, "ADDR_T", 0, pop); inline_unit (p, out, L_DECLARE); print_declarations (out, root_idf); indentf (out, snprintf (line, SNPRINTF_SIZE, "%s = stack_pointer;\n", pop)); inline_unit (p, out, L_EXECUTE); indent (out, "(void) ("); inline_unit (p, out, L_YIELD); undent (out, ");\n"); indentf (out, snprintf (line, SNPRINTF_SIZE, "stack_pointer = %s;\n", pop)); if (compose_fun == A68_MAKE_FUNCTION) { (void) make_name (fn, "_void_formula", "", NUMBER (p)); write_fun_postlude (p, out, fn); } return (fn); } else { return (NO_TEXT); } } /*! \brief compile uniting \param p starting node \param out output file descriptor \return function name **/ static char * compile_uniting (NODE_T * p, FILE_T out, int compose_fun) { MOID_T *u = MOID (p), *v = MOID (SUB (p)); NODE_T *q = SUB (p); if (basic_unit (q) && ATTRIBUTE (v) != UNION_SYMBOL && primitive_mode (v)) { static char fn[NAME_SIZE]; char pop0[NAME_SIZE]; (void) make_name (pop0, PUP, "0", NUMBER (p)); comment_source (p, out); (void) make_name (fn, "_unite", "", NUMBER (p)); if (compose_fun == A68_MAKE_FUNCTION) { write_fun_prelude (p, out, fn); } root_idf = NO_DEC; (void) add_declaration (&root_idf, "ADDR_T", 0, pop0); inline_unit (q, out, L_DECLARE); print_declarations (out, root_idf); indentf (out, snprintf (line, SNPRINTF_SIZE, "%s = stack_pointer;\n", pop0)); indentf (out, snprintf (line, SNPRINTF_SIZE, "PUSH_UNION (_N_ (%d), %s);\n", NUMBER (p), internal_mode (v))); inline_unit (q, out, L_EXECUTE); compile_push (q, out); indentf (out, snprintf (line, SNPRINTF_SIZE, "stack_pointer = %s + %d;\n", pop0, MOID_SIZE (u))); if (compose_fun == A68_MAKE_FUNCTION) { write_fun_postlude (p, out, fn); } return (fn); } else { return (NO_TEXT); } } /*! \brief compile inline arguments \param out output file descriptor \param p starting node **/ static void inline_arguments (NODE_T * p, FILE_T out, int phase, int * size) { if (p == NO_NODE) { return; } else if (IS (p, UNIT) && phase == L_PUSH) { indentf (out, snprintf (line, SNPRINTF_SIZE, "EXECUTE_UNIT_TRACE (_N_ (%d));\n", NUMBER (p))); inline_arguments (NEXT (p), out, L_PUSH, size); } else if (IS (p, UNIT)) { char arg[NAME_SIZE]; (void) make_name (arg, ARG, "", NUMBER (p)); if (phase == L_DECLARE) { (void) add_declaration (&root_idf, inline_mode (MOID (p)), 1, arg); inline_unit (p, out, L_DECLARE); } else if (phase == L_INITIALISE) { inline_unit (p, out, L_EXECUTE); } else if (phase == L_EXECUTE) { indentf (out, snprintf (line, SNPRINTF_SIZE, "%s = (%s *) FRAME_OBJECT (%d);\n", arg, inline_mode (MOID (p)), *size)); (*size) += MOID_SIZE (MOID (p)); } else if (phase == L_YIELD && primitive_mode (MOID (p))) { indentf (out, snprintf (line, SNPRINTF_SIZE, "_S_ (%s) = INIT_MASK;\n", arg)); indentf (out, snprintf (line, SNPRINTF_SIZE, "_V_ (%s) = ", arg)); inline_unit (p, out, L_YIELD); undent (out, ";\n"); } else if (phase == L_YIELD && basic_mode (MOID (p))) { indentf (out, snprintf (line, SNPRINTF_SIZE, "MOVE ((void *) %s, (void *) ", arg)); inline_unit (p, out, L_YIELD); undentf (out, snprintf (line, SNPRINTF_SIZE, ", %d);\n", MOID_SIZE (MOID (p)))); } } else { inline_arguments (SUB (p), out, phase, size); inline_arguments (NEXT (p), out, phase, size); } } /*! \brief compile deproceduring \param out output file descriptor \param p starting node \return function name or NO_NODE **/ static char * compile_deproceduring (NODE_T * p, FILE_T out, int compose_fun) { NODE_T * idf = locate (SUB (p), IDENTIFIER); if (idf == NO_NODE) { return (NO_TEXT); } else if (! (SUB_MOID (idf) == MODE (VOID) || basic_mode (SUB_MOID (idf)))) { return (NO_TEXT); } else if (!(CODEX (TAX (idf)) & PROC_DECLARATION_MASK)) { return (NO_TEXT); } else { static char fn[NAME_SIZE]; char fun[NAME_SIZE]; (void) make_name (fun, FUN, "", NUMBER (idf)); comment_source (p, out); (void) make_name (fn, "_deproc", "", NUMBER (p)); if (compose_fun == A68_MAKE_FUNCTION) { write_fun_prelude (p, out, fn); } /* Declare */ root_idf = NO_DEC; (void) add_declaration (&root_idf, "A68_PROCEDURE", 1, fun); (void) add_declaration (&root_idf, "NODE_T", 1, "body"); print_declarations (out, root_idf); /* Initialise */ if (compose_fun != A68_MAKE_NOTHING) { } get_stack (idf, out, fun, "A68_PROCEDURE"); indentf (out, snprintf (line, SNPRINTF_SIZE, "body = SUB (NODE (&BODY (%s)));\n", fun)); indentf (out, snprintf (line, SNPRINTF_SIZE, "OPEN_PROC_FRAME (body, ENVIRON (%s));\n", fun)); indentf (out, snprintf (line, SNPRINTF_SIZE, "INIT_STATIC_FRAME (body);\n")); /* Execute procedure */ indent (out, "EXECUTE_UNIT_TRACE (NEXT_NEXT (body));\n"); indent (out, "if (frame_pointer == finish_frame_pointer) {\n"); indentation ++; indentf (out, snprintf (line, SNPRINTF_SIZE, "change_masks (TOP_NODE (&program), BREAKPOINT_INTERRUPT_MASK, A68_TRUE);\n")); indentation --; indent (out, "}\n"); indent (out, "CLOSE_FRAME;\n"); if (GC_MODE (SUB_MOID (idf))) { } if (compose_fun == A68_MAKE_FUNCTION) { (void) make_name (fn, "_deproc", "", NUMBER (p)); write_fun_postlude (p, out, fn); } return (fn); } } /*! \brief compile deproceduring \param out output file descriptor \param p starting node \return function name **/ static char * compile_voiding_deproceduring (NODE_T * p, FILE_T out, int compose_fun) { NODE_T * idf = locate (SUB_SUB (p), IDENTIFIER); if (idf == NO_NODE) { return (NO_TEXT); } else if (! (SUB_MOID (idf) == MODE (VOID) || basic_mode (SUB_MOID (idf)))) { return (NO_TEXT); } else if (!(CODEX (TAX (idf)) & PROC_DECLARATION_MASK)) { return (NO_TEXT); } else { static char fn[NAME_SIZE]; char fun[NAME_SIZE], pop[NAME_SIZE]; (void) make_name (fun, FUN, "", NUMBER (idf)); (void) make_name (pop, PUP, "", NUMBER (p)); comment_source (p, out); (void) make_name (fn, "_void_deproc", "", NUMBER (p)); if (compose_fun == A68_MAKE_FUNCTION) { write_fun_prelude (p, out, fn); } /* Declare */ root_idf = NO_DEC; (void) add_declaration (&root_idf, "ADDR_T", 0, pop); (void) add_declaration (&root_idf, "A68_PROCEDURE", 1, fun); (void) add_declaration (&root_idf, "NODE_T", 1, "body"); print_declarations (out, root_idf); /* Initialise */ indentf (out, snprintf (line, SNPRINTF_SIZE, "%s = stack_pointer;\n", pop)); if (compose_fun != A68_MAKE_NOTHING) { } get_stack (idf, out, fun, "A68_PROCEDURE"); indentf (out, snprintf (line, SNPRINTF_SIZE, "body = SUB (NODE (&BODY (%s)));\n", fun)); indentf (out, snprintf (line, SNPRINTF_SIZE, "OPEN_PROC_FRAME (body, ENVIRON (%s));\n", fun)); indentf (out, snprintf (line, SNPRINTF_SIZE, "INIT_STATIC_FRAME (body);\n")); /* Execute procedure */ indent (out, "EXECUTE_UNIT_TRACE (NEXT_NEXT (body));\n"); indent (out, "if (frame_pointer == finish_frame_pointer) {\n"); indentation ++; indentf (out, snprintf (line, SNPRINTF_SIZE, "change_masks (TOP_NODE (&program), BREAKPOINT_INTERRUPT_MASK, A68_TRUE);\n")); indentation --; indent (out, "}\n"); indentf (out, snprintf (line, SNPRINTF_SIZE, "stack_pointer = %s;\n", pop)); indent (out, "CLOSE_FRAME;\n"); if (compose_fun == A68_MAKE_FUNCTION) { (void) make_name (fn, "_void_deproc", "", NUMBER (p)); write_fun_postlude (p, out, fn); } return (fn); } } /*! \brief compile call \param out output file descriptor \param p starting node \return function name **/ static char * compile_call (NODE_T * p, FILE_T out, int compose_fun) { NODE_T * proc = SUB (p); NODE_T * args = NEXT (proc); NODE_T * idf = locate (proc, IDENTIFIER); if (idf == NO_NODE) { return (NO_TEXT); } else if (! (SUB_MOID (proc) == MODE (VOID) || basic_mode (SUB_MOID (proc)))) { return (NO_TEXT); } else if (DIM (MOID (proc)) == 0) { return (NO_TEXT); } else if (A68G_STANDENV_PROC (TAX (idf))) { if (basic_call (p)) { static char fn[NAME_SIZE]; char fun[NAME_SIZE]; (void) make_name (fun, FUN, "", NUMBER (proc)); comment_source (p, out); (void) make_name (fn, "_call", "", NUMBER (p)); if (compose_fun == A68_MAKE_FUNCTION) { write_fun_prelude (p, out, fn); } root_idf = NO_DEC; inline_unit (p, out, L_DECLARE); print_declarations (out, root_idf); inline_unit (p, out, L_EXECUTE); compile_push (p, out); if (compose_fun == A68_MAKE_FUNCTION) { (void) make_name (fn, "_call", "", NUMBER (p)); write_fun_postlude (p, out, fn); } return (fn); } else { return (NO_TEXT); } } else if (!(CODEX (TAX (idf)) & PROC_DECLARATION_MASK)) { return (NO_TEXT); } else if (DIM (PARTIAL_PROC (GINFO (proc))) != 0) { return (NO_TEXT); } else if (!basic_argument (args)) { return (NO_TEXT); } else { static char fn[NAME_SIZE]; char fun[NAME_SIZE], pop[NAME_SIZE]; int size; /* Declare */ (void) make_name (fun, FUN, "", NUMBER (proc)); (void) make_name (pop, PUP, "", NUMBER (p)); comment_source (p, out); (void) make_name (fn, "_call", "", NUMBER (p)); if (compose_fun == A68_MAKE_FUNCTION) { write_fun_prelude (p, out, fn); } /* Compute arguments */ size = 0; root_idf = NO_DEC; inline_arguments (args, out, L_DECLARE, &size); (void) add_declaration (&root_idf, "ADDR_T", 0, pop); (void) add_declaration (&root_idf, "A68_PROCEDURE", 1, fun); (void) add_declaration (&root_idf, "NODE_T", 1, "body"); print_declarations (out, root_idf); /* Initialise */ indentf (out, snprintf (line, SNPRINTF_SIZE, "%s = stack_pointer;\n", pop)); if (compose_fun != A68_MAKE_NOTHING) { } inline_arguments (args, out, L_INITIALISE, &size); get_stack (idf, out, fun, "A68_PROCEDURE"); indentf (out, snprintf (line, SNPRINTF_SIZE, "body = SUB (NODE (&BODY (%s)));\n", fun)); indentf (out, snprintf (line, SNPRINTF_SIZE, "OPEN_PROC_FRAME (body, ENVIRON (%s));\n", fun)); indentf (out, snprintf (line, SNPRINTF_SIZE, "INIT_STATIC_FRAME (body);\n")); size = 0; inline_arguments (args, out, L_EXECUTE, &size); size = 0; inline_arguments (args, out, L_YIELD, &size); /* Execute procedure */ indentf (out, snprintf (line, SNPRINTF_SIZE, "stack_pointer = %s;\n", pop)); indent (out, "EXECUTE_UNIT_TRACE (NEXT_NEXT_NEXT (body));\n"); indent (out, "if (frame_pointer == finish_frame_pointer) {\n"); indentation ++; indentf (out, snprintf (line, SNPRINTF_SIZE, "change_masks (TOP_NODE (&program), BREAKPOINT_INTERRUPT_MASK, A68_TRUE);\n")); indentation --; indent (out, "}\n"); indent (out, "CLOSE_FRAME;\n"); if (GC_MODE (SUB_MOID (proc))) { } if (compose_fun == A68_MAKE_FUNCTION) { (void) make_name (fn, "_call", "", NUMBER (p)); write_fun_postlude (p, out, fn); } return (fn); } } /*! \brief compile call \param out output file descriptor \param p starting node \return function name **/ static char * compile_voiding_call (NODE_T * p, FILE_T out, int compose_fun) { NODE_T * proc = SUB (locate (p, CALL)); NODE_T * args = NEXT (proc); NODE_T * idf = locate (proc, IDENTIFIER); if (idf == NO_NODE) { return (NO_TEXT); } else if (! (SUB_MOID (proc) == MODE (VOID) || basic_mode (SUB_MOID (proc)))) { return (NO_TEXT); } else if (DIM (MOID (proc)) == 0) { return (NO_TEXT); } else if (A68G_STANDENV_PROC (TAX (idf))) { return (NO_TEXT); } else if (!(CODEX (TAX (idf)) & PROC_DECLARATION_MASK)) { return (NO_TEXT); } else if (DIM (PARTIAL_PROC (GINFO (proc))) != 0) { return (NO_TEXT); } else if (!basic_argument (args)) { return (NO_TEXT); } else { static char fn[NAME_SIZE]; char fun[NAME_SIZE], pop[NAME_SIZE]; int size; /* Declare */ (void) make_name (fun, FUN, "", NUMBER (proc)); (void) make_name (pop, PUP, "", NUMBER (p)); comment_source (p, out); (void) make_name (fn, "_void_call", "", NUMBER (p)); if (compose_fun == A68_MAKE_FUNCTION) { write_fun_prelude (p, out, fn); } /* Compute arguments */ size = 0; root_idf = NO_DEC; inline_arguments (args, out, L_DECLARE, &size); (void) add_declaration (&root_idf, "ADDR_T", 0, pop); (void) add_declaration (&root_idf, "A68_PROCEDURE", 1, fun); (void) add_declaration (&root_idf, "NODE_T", 1, "body"); print_declarations (out, root_idf); /* Initialise */ indentf (out, snprintf (line, SNPRINTF_SIZE, "%s = stack_pointer;\n", pop)); if (compose_fun != A68_MAKE_NOTHING) { } inline_arguments (args, out, L_INITIALISE, &size); get_stack (idf, out, fun, "A68_PROCEDURE"); indentf (out, snprintf (line, SNPRINTF_SIZE, "body = SUB (NODE (&BODY (%s)));\n", fun)); indentf (out, snprintf (line, SNPRINTF_SIZE, "OPEN_PROC_FRAME (body, ENVIRON (%s));\n", fun)); indentf (out, snprintf (line, SNPRINTF_SIZE, "INIT_STATIC_FRAME (body);\n")); size = 0; inline_arguments (args, out, L_EXECUTE, &size); size = 0; inline_arguments (args, out, L_YIELD, &size); /* Execute procedure */ indentf (out, snprintf (line, SNPRINTF_SIZE, "stack_pointer = %s;\n", pop)); indent (out, "EXECUTE_UNIT_TRACE (NEXT_NEXT_NEXT (body));\n"); indent (out, "if (frame_pointer == finish_frame_pointer) {\n"); indentation ++; indentf (out, snprintf (line, SNPRINTF_SIZE, "change_masks (TOP_NODE (&program), BREAKPOINT_INTERRUPT_MASK, A68_TRUE);\n")); indentation --; indent (out, "}\n"); indent (out, "CLOSE_FRAME;\n"); indentf (out, snprintf (line, SNPRINTF_SIZE, "stack_pointer = %s;\n", pop)); if (compose_fun == A68_MAKE_FUNCTION) { (void) make_name (fn, "_void_call", "", NUMBER (p)); write_fun_postlude (p, out, fn); } return (fn); } } /*! \brief compile voiding assignation \param p starting node \param out output file descriptor \return function name **/ static char * compile_voiding_assignation_selection (NODE_T * p, FILE_T out, int compose_fun) { NODE_T * dst = SUB (locate (p, ASSIGNATION)); NODE_T * src = NEXT_NEXT (dst); if (BASIC (dst, SELECTION) && basic_unit (src) && basic_mode_non_row (MOID (dst))) { NODE_T * field = SUB (locate (dst, SELECTION)); NODE_T * sec = NEXT (field); NODE_T * idf = locate (sec, IDENTIFIER); char sel[NAME_SIZE], ref[NAME_SIZE], pop[NAME_SIZE]; char * field_idf = NSYMBOL (SUB (field)); static char fn[NAME_SIZE]; comment_source (p, out); (void) make_name (pop, PUP, "", NUMBER (p)); (void) make_name (fn, "_void_assign", "", NUMBER (p)); if (compose_fun == A68_MAKE_FUNCTION) { write_fun_prelude (p, out, fn); } /* Declare */ root_idf = NO_DEC; if (signed_in (BOOK_DECL, L_DECLARE, NSYMBOL (idf)) == NO_BOOK) { (void) make_name (ref, NSYMBOL (idf), "", NUMBER (field)); (void) make_name (sel, SEL, "", NUMBER (field)); indentf (out, snprintf (line, SNPRINTF_SIZE, "A68_REF * %s; /* %s */\n", ref, NSYMBOL (idf))); indentf (out, snprintf (line, SNPRINTF_SIZE, "%s * %s;\n", inline_mode (SUB_MOID (field)), sel)); sign_in (BOOK_DECL, L_DECLARE, NSYMBOL (idf), (void *) field_idf, NUMBER (field)); } else { int n = NUMBER (signed_in (BOOK_DECL, L_DECLARE, NSYMBOL (idf))); (void) make_name (ref, NSYMBOL (idf), "", n); (void) make_name (sel, SEL, "", n); } inline_unit (src, out, L_DECLARE); (void) add_declaration (&root_idf, "ADDR_T", 0, pop); print_declarations (out, root_idf); indentf (out, snprintf (line, SNPRINTF_SIZE, "%s = stack_pointer;\n", pop)); /* Initialise */ if (signed_in (BOOK_DECL, L_EXECUTE, NSYMBOL (idf)) == NO_BOOK) { get_stack (idf, out, ref, "A68_REF"); indentf (out, snprintf (line, SNPRINTF_SIZE, "%s = (%s *) & (ADDRESS (%s)[%d]);\n", sel, inline_mode (SUB_MOID (field)), ref, OFFSET_OFF (field))); sign_in (BOOK_DECL, L_EXECUTE, NSYMBOL (idf), (void *) field_idf, NUMBER (field)); } inline_unit (src, out, L_EXECUTE); /* Generate */ compile_assign (src, out, sel); indentf (out, snprintf (line, SNPRINTF_SIZE, "stack_pointer = %s;\n", pop)); if (compose_fun == A68_MAKE_FUNCTION) { (void) make_name (fn, "_void_assign", "", NUMBER (p)); write_fun_postlude (p, out, fn); } return (fn); } else { return (NO_TEXT); } } /*! \brief compile voiding assignation \param p starting node \param out output file descriptor \return function name **/ static char * compile_voiding_assignation_slice (NODE_T * p, FILE_T out, int compose_fun) { NODE_T * dst = SUB (locate (p, ASSIGNATION)); NODE_T * src = NEXT_NEXT (dst); NODE_T * slice = locate (SUB (dst), SLICE); NODE_T * prim = SUB (slice); MOID_T * mode = SUB_MOID (dst); MOID_T * row_mode = DEFLEX (MOID (prim)); if (IS (row_mode, REF_SYMBOL) && basic_slice (slice) && basic_unit (src) && basic_mode_non_row (MOID (src))) { NODE_T * indx = NEXT (prim); char * symbol = NSYMBOL (SUB (prim)); char drf[NAME_SIZE], idf[NAME_SIZE], arr[NAME_SIZE], tup[NAME_SIZE], elm[NAME_SIZE], pop[NAME_SIZE]; static char fn[NAME_SIZE]; int k; comment_source (p, out); (void) make_name (pop, PUP, "", NUMBER (p)); (void) make_name (fn, "_void_assign", "", NUMBER (p)); if (compose_fun == A68_MAKE_FUNCTION) { write_fun_prelude (p, out, fn); } /* Declare */ root_idf = NO_DEC; (void) add_declaration (&root_idf, "ADDR_T", 0, pop); if (signed_in (BOOK_DECL, L_DECLARE, symbol) == NO_BOOK) { (void) make_name (idf, symbol, "", NUMBER (prim)); (void) make_name (arr, ARR, "", NUMBER (prim)); (void) make_name (tup, TUP, "", NUMBER (prim)); (void) make_name (elm, ELM, "", NUMBER (prim)); (void) make_name (drf, DRF, "", NUMBER (prim)); (void) add_declaration (&root_idf, "A68_REF", 1, idf); (void) add_declaration (&root_idf, "A68_REF", 0, elm); (void) add_declaration (&root_idf, "A68_ARRAY", 1, arr); (void) add_declaration (&root_idf, "A68_TUPLE", 1, tup); (void) add_declaration (&root_idf, inline_mode (mode), 1, drf); sign_in (BOOK_DECL, L_DECLARE, symbol, (void *) indx, NUMBER (prim)); } else { int n = NUMBER (signed_in (BOOK_DECL, L_EXECUTE, symbol)); (void) make_name (idf, symbol, "", n); (void) make_name (arr, ARR, "", n); (void) make_name (tup, TUP, "", n); (void) make_name (elm, ELM, "", n); (void) make_name (drf, DRF, "", n); } k = 0; inline_indexer (indx, out, L_DECLARE, &k, NO_TEXT); inline_unit (src, out, L_DECLARE); print_declarations (out, root_idf); /* Initialise */ indentf (out, snprintf (line, SNPRINTF_SIZE, "%s = stack_pointer;\n", pop)); if (signed_in (BOOK_DECL, L_EXECUTE, symbol) == NO_BOOK) { NODE_T * pidf = locate (prim, IDENTIFIER); get_stack (pidf, out, idf, "A68_REF"); indentf (out, snprintf (line, SNPRINTF_SIZE, "GET_DESCRIPTOR (%s, %s, DEREF (A68_ROW, %s));\n", arr, tup, idf)); indentf (out, snprintf (line, SNPRINTF_SIZE, "%s = ARRAY (%s);\n", elm, arr)); sign_in (BOOK_DECL, L_EXECUTE, NSYMBOL (p), (void *) indx, NUMBER (prim)); } k = 0; inline_indexer (indx, out, L_EXECUTE, &k, NO_TEXT); indentf (out, snprintf (line, SNPRINTF_SIZE, "OFFSET (& %s) += ROW_ELEMENT (%s, ", elm, arr)); k = 0; inline_indexer (indx, out, L_YIELD, &k, tup); undentf (out, snprintf (line, SNPRINTF_SIZE, ");\n")); indentf (out, snprintf (line, SNPRINTF_SIZE, "%s = DEREF (%s, & %s);\n", drf, inline_mode (mode), elm)); inline_unit (src, out, L_EXECUTE); /* Generate */ compile_assign (src, out, drf); indentf (out, snprintf (line, SNPRINTF_SIZE, "stack_pointer = %s;\n", pop)); if (compose_fun == A68_MAKE_FUNCTION) { (void) make_name (fn, "_void_assign", "", NUMBER (p)); write_fun_postlude (p, out, fn); } return (fn); } else { return (NO_TEXT); } } /*! \brief compile voiding assignation \param p starting node \param out output file descriptor \return function name **/ static char * compile_voiding_assignation_identifier (NODE_T * p, FILE_T out, int compose_fun) { NODE_T * dst = SUB (locate (p, ASSIGNATION)); NODE_T * src = NEXT_NEXT (dst); if (BASIC (dst, IDENTIFIER) && basic_unit (src) && basic_mode_non_row (MOID (src))) { static char fn[NAME_SIZE]; char idf[NAME_SIZE], pop[NAME_SIZE]; NODE_T * q = locate (dst, IDENTIFIER); /* Declare */ (void) make_name (pop, PUP, "", NUMBER (p)); comment_source (p, out); (void) make_name (fn, "_void_assign", "", NUMBER (p)); if (compose_fun == A68_MAKE_FUNCTION) { write_fun_prelude (p, out, fn); } root_idf = NO_DEC; if (signed_in (BOOK_DEREF, L_DECLARE, NSYMBOL (q)) == NO_BOOK) { (void) make_name (idf, NSYMBOL (q), "", NUMBER (p)); (void) add_declaration (&root_idf, inline_mode (SUB_MOID (dst)), 1, idf); sign_in (BOOK_DEREF, L_DECLARE, NSYMBOL (q), NULL, NUMBER (p)); } else { (void) make_name (idf, NSYMBOL (q), "", NUMBER (signed_in (BOOK_DEREF, L_DECLARE, NSYMBOL (p)))); } inline_unit (dst, out, L_DECLARE); inline_unit (src, out, L_DECLARE); (void) add_declaration (&root_idf, "ADDR_T", 0, pop); print_declarations (out, root_idf); /* Initialise */ indentf (out, snprintf (line, SNPRINTF_SIZE, "%s = stack_pointer;\n", pop)); inline_unit (dst, out, L_EXECUTE); if (signed_in (BOOK_DEREF, L_EXECUTE, NSYMBOL (q)) == NO_BOOK) { if (BODY (TAX (q)) != NO_TAG) { indentf (out, snprintf (line, SNPRINTF_SIZE, "%s = (%s *) LOCAL_ADDRESS (", idf, inline_mode (SUB_MOID (dst)))); inline_unit (dst, out, L_YIELD); undent (out, ");\n"); sign_in (BOOK_DEREF, L_EXECUTE, NSYMBOL (q), NULL, NUMBER (p)); } else { indentf (out, snprintf (line, SNPRINTF_SIZE, "%s = DEREF (%s, ", idf, inline_mode (SUB_MOID (dst)))); inline_unit (dst, out, L_YIELD); undent (out, ");\n"); sign_in (BOOK_DEREF, L_EXECUTE, NSYMBOL (q), NULL, NUMBER (p)); } } inline_unit (src, out, L_EXECUTE); compile_assign (src, out, idf); indentf (out, snprintf (line, SNPRINTF_SIZE, "stack_pointer = %s;\n", pop)); if (compose_fun == A68_MAKE_FUNCTION) { (void) make_name (fn, "_void_assign", "", NUMBER (p)); write_fun_postlude (p, out, fn); } return (fn); } else { return (NO_TEXT); } } /*! \brief compile identity-relation \param p starting node \param out output file descriptor \return function name **/ static char * compile_identity_relation (NODE_T * p, FILE_T out, int compose_fun) { #define GOOD(p) (locate (p, IDENTIFIER) != NO_NODE && IS (MOID (locate ((p), IDENTIFIER)), REF_SYMBOL)) NODE_T * lhs = SUB (p); NODE_T * op = NEXT (lhs); NODE_T * rhs = NEXT (op); if (GOOD (lhs) && GOOD (rhs)) { static char fn[NAME_SIZE]; comment_source (p, out); (void) make_name (fn, "_identity", "", NUMBER (p)); if (compose_fun == A68_MAKE_FUNCTION) { write_fun_prelude (p, out, fn); } root_idf = NO_DEC; inline_identity_relation (p, out, L_DECLARE); print_declarations (out, root_idf); inline_identity_relation (p, out, L_EXECUTE); indentf (out, snprintf (line, SNPRINTF_SIZE, "PUSH_PRIMITIVE (p, ")); inline_identity_relation (p, out, L_YIELD); undentf (out, snprintf (line, SNPRINTF_SIZE, ", A68_BOOL);\n")); if (compose_fun == A68_MAKE_FUNCTION) { (void) make_name (fn, "_identity", "", NUMBER (p)); write_fun_postlude (p, out, fn); } return (fn); } else if (GOOD (lhs) && locate (rhs, NIHIL) != NO_NODE) { static char fn[NAME_SIZE]; comment_source (p, out); (void) make_name (fn, "_identity", "", NUMBER (p)); if (compose_fun == A68_MAKE_FUNCTION) { write_fun_prelude (p, out, fn); } root_idf = NO_DEC; inline_identity_relation (p, out, L_DECLARE); print_declarations (out, root_idf); inline_identity_relation (p, out, L_EXECUTE); indentf (out, snprintf (line, SNPRINTF_SIZE, "PUSH_PRIMITIVE (p, ")); inline_identity_relation (p, out, L_YIELD); undentf (out, snprintf (line, SNPRINTF_SIZE, ", A68_BOOL);\n")); if (compose_fun == A68_MAKE_FUNCTION) { (void) make_name (fn, "_identity", "", NUMBER (p)); write_fun_postlude (p, out, fn); } return (fn); } else { return (NO_TEXT); } #undef GOOD } /*! \brief compile closed clause \param out output file descriptor \param p starting node **/ static void compile_declaration_list (NODE_T * p, FILE_T out, int * decs, char * pop) { for (; p != NO_NODE; FORWARD (p)) { switch (ATTRIBUTE (p)) { case MODE_DECLARATION: case PROCEDURE_DECLARATION: case BRIEF_OPERATOR_DECLARATION: case PRIORITY_DECLARATION: { /* No action needed */ (* decs) ++; return; } case OPERATOR_DECLARATION: { indentf (out, snprintf (line, SNPRINTF_SIZE, "genie_operator_dec (_N_ (%d));", NUMBER (SUB (p)))); inline_comment_source (p, out); undent (out, NEWLINE_STRING); (* decs) ++; break; } case IDENTITY_DECLARATION: { indentf (out, snprintf (line, SNPRINTF_SIZE, "genie_identity_dec (_N_ (%d));", NUMBER (SUB (p)))); inline_comment_source (p, out); undent (out, NEWLINE_STRING); (* decs) ++; break; } case VARIABLE_DECLARATION: { char declarer[NAME_SIZE]; (void) make_name (declarer, DEC, "", NUMBER (SUB (p))); indent (out, "{"); inline_comment_source (p, out); undent (out, NEWLINE_STRING); indentation ++; indentf (out, snprintf (line, SNPRINTF_SIZE, "NODE_T *%s = NO_NODE;\n", declarer)); indentf (out, snprintf (line, SNPRINTF_SIZE, "genie_variable_dec (_N_ (%d), &%s, stack_pointer);\n", NUMBER (SUB (p)), declarer)); indentf (out, snprintf (line, SNPRINTF_SIZE, "stack_pointer = %s;\n", pop)); indentation --; indent (out, "}\n"); (* decs) ++; break; } case PROCEDURE_VARIABLE_DECLARATION: { indentf (out, snprintf (line, SNPRINTF_SIZE, "genie_proc_variable_dec (_N_ (%d));", NUMBER (SUB (p)))); inline_comment_source (p, out); undent (out, NEWLINE_STRING); indentf (out, snprintf (line, SNPRINTF_SIZE, "stack_pointer = %s;\n", pop)); (* decs) ++; break; } default: { compile_declaration_list (SUB (p), out, decs, pop); break; } } } } static void compile_serial_clause (NODE_T * p, FILE_T out, NODE_T ** last, int * units, int * decs, char * pop, int compose_fun) { for (; p != NO_NODE; FORWARD (p)) { if (compose_fun == A68_MAKE_OTHERS) { if (IS (p, UNIT)) { (* units) ++; } if (IS (p, DECLARATION_LIST)) { (* decs) ++; } if (IS (p, UNIT) || IS (p, DECLARATION_LIST)) { if (compile_unit (p, out, A68_MAKE_FUNCTION) == NO_TEXT) { if (IS (p, UNIT) && IS (SUB (p), TERTIARY)) { compile_units (SUB_SUB (p), out); } else { compile_units (SUB (p), out); } } else if (SUB (p) != NO_NODE && GINFO (SUB (p)) != NO_GINFO && COMPILE_NODE (GINFO (SUB (p))) > 0) { COMPILE_NODE (GINFO (p)) = COMPILE_NODE (GINFO (SUB (p))); COMPILE_NAME (GINFO (p)) = COMPILE_NAME (GINFO (SUB (p))); } return; } else { compile_serial_clause (SUB (p), out, last, units, decs, pop, compose_fun); } } else switch (ATTRIBUTE (p)) { case UNIT: { (* last) = p; CODE_EXECUTE (p); inline_comment_source (p, out); undent (out, NEWLINE_STRING); (* units) ++; return; } case SEMI_SYMBOL: { if (IS (* last, UNIT) && MOID (* last) == MODE (VOID)) { break; } else if (IS (* last, DECLARATION_LIST)) { break; } else { indentf (out, snprintf (line, SNPRINTF_SIZE, "stack_pointer = %s;\n", pop)); } break; } case DECLARATION_LIST: { (* last) = p; compile_declaration_list (SUB (p), out, decs, pop); break; } default: { compile_serial_clause (SUB (p), out, last, units, decs, pop, compose_fun); break; } } } } /*! \brief embed serial clause \param out output file descriptor \param p starting node */ static void embed_serial_clause (NODE_T * p, FILE_T out, char * pop) { NODE_T * last = NO_NODE; int units = 0, decs = 0; indentf (out, snprintf (line, SNPRINTF_SIZE, "OPEN_STATIC_FRAME (_N_ (%d));\n", NUMBER (p))); init_static_frame (out, p); compile_serial_clause (p, out, &last, &units, &decs, pop, A68_MAKE_FUNCTION); indent (out, "CLOSE_FRAME;\n"); } /*! \brief compile code clause \param out output file descriptor \param p starting node \return function name **/ static char * compile_code_clause (NODE_T * p, FILE_T out, int compose_fun) { static char fn[NAME_SIZE]; comment_source (p, out); (void) make_name (fn, "_code", "", NUMBER (p)); if (compose_fun == A68_MAKE_FUNCTION) { write_fun_prelude (p, out, fn); } embed_code_clause (SUB (p), out); if (compose_fun == A68_MAKE_FUNCTION) { (void) make_name (fn, "_code", "", NUMBER (p)); write_fun_postlude (p, out, fn); } return (fn); } /*! \brief compile closed clause \param out output file descriptor \param p starting node \return function name **/ static char * compile_closed_clause (NODE_T * p, FILE_T out, int compose_fun) { NODE_T *sc = NEXT_SUB (p); if (MOID (p) == MODE (VOID) && LABELS (TABLE (sc)) == NO_TAG) { static char fn[NAME_SIZE]; char pop[NAME_SIZE]; int units = 0, decs = 0; NODE_T * last = NO_NODE; compile_serial_clause (sc, out, &last, &units, &decs, pop, A68_MAKE_OTHERS); (void) make_name (pop, PUP, "", NUMBER (p)); comment_source (p, out); (void) make_name (fn, "_closed", "", NUMBER (p)); if (compose_fun == A68_MAKE_FUNCTION) { write_fun_prelude (p, out, fn); } root_idf = NO_DEC; (void) add_declaration (&root_idf, "ADDR_T", 0, pop); print_declarations (out, root_idf); indentf (out, snprintf (line, SNPRINTF_SIZE, "%s = stack_pointer;\n", pop)); embed_serial_clause (sc, out, pop); if (compose_fun == A68_MAKE_FUNCTION) { (void) make_name (fn, "_closed", "", NUMBER (p)); write_fun_postlude (p, out, fn); } return (fn); } else { return (NO_TEXT); } } /*! \brief compile collateral clause \param out output file descriptor \param p starting node \return function name **/ static char * compile_collateral_clause (NODE_T * p, FILE_T out, int compose_fun) { if (basic_unit (p) && IS (MOID (p), STRUCT_SYMBOL)) { static char fn[NAME_SIZE]; comment_source (p, out); (void) make_name (fn, "_collateral", "", NUMBER (p)); if (compose_fun == A68_MAKE_FUNCTION) { write_fun_prelude (p, out, fn); } root_idf = NO_DEC; inline_collateral_units (NEXT_SUB (p), out, L_DECLARE); print_declarations (out, root_idf); inline_collateral_units (NEXT_SUB (p), out, L_EXECUTE); inline_collateral_units (NEXT_SUB (p), out, L_YIELD); if (compose_fun == A68_MAKE_FUNCTION) { (void) make_name (fn, "_collateral", "", NUMBER (p)); write_fun_postlude (p, out, fn); } return (fn); } else { return (NO_TEXT); } } /*! \brief compile conditional clause \param out output file descriptor \param p starting node \return function name **/ static char * compile_basic_conditional (NODE_T * p, FILE_T out, int compose_fun) { static char fn[NAME_SIZE]; NODE_T * q = SUB (p); if (! (basic_mode (MOID (p)) || MOID (p) == MODE (VOID))) { return (NO_TEXT); } p = q; if (!basic_conditional (p)) { return (NO_TEXT); } comment_source (p, out); (void) make_name (fn, "_conditional", "", NUMBER (q)); if (compose_fun == A68_MAKE_FUNCTION) { write_fun_prelude (q, out, fn); } /* Collect declarations */ if (IS (p, IF_PART) || IS (p, OPEN_PART)) { root_idf = NO_DEC; inline_unit (SUB (NEXT_SUB (p)), out, L_DECLARE); print_declarations (out, root_idf); inline_unit (SUB (NEXT_SUB (p)), out, L_EXECUTE); indent (out, "if ("); inline_unit (SUB (NEXT_SUB (p)), out, L_YIELD); undent (out, ") {\n"); indentation ++; } else { ABEND (A68_TRUE, "if-part expected", NO_TEXT); } FORWARD (p); if (IS (p, THEN_PART) || IS (p, CHOICE)) { int pop = temp_book_pointer; (void) compile_unit (SUB (NEXT_SUB (p)), out, A68_MAKE_NOTHING); indentation --; temp_book_pointer = pop; } else { ABEND (A68_TRUE, "then-part expected", NO_TEXT); } FORWARD (p); if (IS (p, ELSE_PART) || IS (p, CHOICE)) { int pop = temp_book_pointer; indent (out, "} else {\n"); indentation ++; (void) compile_unit (SUB (NEXT_SUB (p)), out, A68_MAKE_NOTHING); indentation --; temp_book_pointer = pop; } /* Done */ indent (out, "}\n"); if (compose_fun == A68_MAKE_FUNCTION) { (void) make_name (fn, "_conditional", "", NUMBER (q)); write_fun_postlude (q, out, fn); } return (fn); } /*! \brief compile conditional clause \param out output file descriptor \param p starting node \return function name **/ static char * compile_conditional_clause (NODE_T * p, FILE_T out, int compose_fun) { static char fn[NAME_SIZE]; char pop[NAME_SIZE]; int units = 0, decs = 0; NODE_T * q, * last; /* We only compile IF basic unit or ELIF basic unit, so we save on opening frames */ /* Check worthiness of the clause */ if (MOID (p) != MODE (VOID)) { return (NO_TEXT); } q = SUB (p); while (q != NO_NODE && is_one_of (q, IF_PART, OPEN_PART, ELIF_IF_PART, ELSE_OPEN_PART, STOP)) { if (! basic_serial (NEXT_SUB (q), 1)) { return (NO_TEXT); } FORWARD (q); while (q != NO_NODE && (IS (q, THEN_PART) || IS (q, ELSE_PART) || IS (q, CHOICE))) { if (LABELS (TABLE (NEXT_SUB (q))) != NO_TAG) { return (NO_TEXT); } FORWARD (q); } if (q != NO_NODE && is_one_of (q, ELIF_PART, BRIEF_ELIF_PART, STOP)) { q = SUB (q); } else if (q != NO_NODE && is_one_of (q, FI_SYMBOL, CLOSE_SYMBOL)) { FORWARD (q); } } /* Generate embedded units */ q = SUB (p); while (q != NO_NODE && is_one_of (q, IF_PART, OPEN_PART, ELIF_IF_PART, ELSE_OPEN_PART, STOP)) { FORWARD (q); while (q != NO_NODE && (IS (q, THEN_PART) || IS (q, ELSE_PART) || IS (q, CHOICE))) { last = NO_NODE; units = decs = 0; compile_serial_clause (NEXT_SUB (q), out, &last, &units, &decs, pop, A68_MAKE_OTHERS); FORWARD (q); } if (q != NO_NODE && is_one_of (q, ELIF_PART, BRIEF_ELIF_PART, STOP)) { q = SUB (q); } else if (q != NO_NODE && is_one_of (q, FI_SYMBOL, CLOSE_SYMBOL)) { FORWARD (q); } } /* Prep and Dec */ (void) make_name (fn, "_conditional", "", NUMBER (p)); (void) make_name (pop, PUP, "", NUMBER (p)); comment_source (p, out); if (compose_fun == A68_MAKE_FUNCTION) { write_fun_prelude (p, out, fn); } root_idf = NO_DEC; q = SUB (p); while (q != NO_NODE && is_one_of (q, IF_PART, OPEN_PART, ELIF_IF_PART, ELSE_OPEN_PART, STOP)) { inline_unit (SUB (NEXT_SUB (q)), out, L_DECLARE); FORWARD (q); while (q != NO_NODE && (IS (q, THEN_PART) || IS (q, ELSE_PART) || IS (q, CHOICE))) { FORWARD (q); } if (q != NO_NODE && is_one_of (q, ELIF_PART, BRIEF_ELIF_PART, STOP)) { q = SUB (q); } else if (q != NO_NODE && is_one_of (q, FI_SYMBOL, CLOSE_SYMBOL)) { FORWARD (q); } } (void) add_declaration (&root_idf, "ADDR_T", 0, pop); print_declarations (out, root_idf); /* Generate the function body */ indentf (out, snprintf (line, SNPRINTF_SIZE, "%s = stack_pointer;\n", pop)); q = SUB (p); while (q != NO_NODE && is_one_of (q, IF_PART, OPEN_PART, ELIF_IF_PART, ELSE_OPEN_PART, STOP)) { inline_unit (SUB (NEXT_SUB (q)), out, L_EXECUTE); FORWARD (q); while (q != NO_NODE && (IS (q, THEN_PART) || IS (q, ELSE_PART) || IS (q, CHOICE))) { FORWARD (q); } if (q != NO_NODE && is_one_of (q, ELIF_PART, BRIEF_ELIF_PART, STOP)) { q = SUB (q); } else if (q != NO_NODE && is_one_of (q, FI_SYMBOL, CLOSE_SYMBOL)) { FORWARD (q); } } q = SUB (p); while (q != NO_NODE && is_one_of (q, IF_PART, OPEN_PART, ELIF_IF_PART, ELSE_OPEN_PART, STOP)) { BOOL_T else_part = A68_FALSE; if (is_one_of (q, IF_PART, OPEN_PART, STOP) ) { indent (out, "if ("); } else { indent (out, "} else if ("); } inline_unit (SUB (NEXT_SUB (q)), out, L_YIELD); undent (out, ") {\n"); FORWARD (q); while (q != NO_NODE && (IS (q, THEN_PART) || IS (q, ELSE_PART) || IS (q, CHOICE))) { if (else_part) { indent (out, "} else {\n"); } indentation ++; embed_serial_clause (NEXT_SUB (q), out, pop); indentation --; else_part = A68_TRUE; FORWARD (q); } if (q != NO_NODE && is_one_of (q, ELIF_PART, BRIEF_ELIF_PART, STOP)) { q = SUB (q); } else if (q != NO_NODE && is_one_of (q, FI_SYMBOL, CLOSE_SYMBOL)) { FORWARD (q); } } indent (out, "}\n"); if (compose_fun == A68_MAKE_FUNCTION) { (void) make_name (fn, "_conditional", "", NUMBER (p)); write_fun_postlude (p, out, fn); } return (fn); } /*! \brief compile unit from integral-case in-part \param p position in tree \param k value of enquiry clause \param count unit counter \return whether a unit was compiled **/ BOOL_T compile_int_case_units (NODE_T * p, FILE_T out, NODE_T * sym, int k, int * count, int compose_fun) { if (p == NO_NODE) { return (A68_FALSE); } else { if (IS (p, UNIT)) { if (k == * count) { if (compose_fun == A68_MAKE_FUNCTION) { indentf (out, snprintf (line, SNPRINTF_SIZE, "case %d: {\n", k)); indentation ++; indentf (out, snprintf (line, SNPRINTF_SIZE, "OPEN_STATIC_FRAME (_N_ (%d));\n", NUMBER (sym))); CODE_EXECUTE (p); inline_comment_source (p, out); undent (out, NEWLINE_STRING); indent (out, "CLOSE_FRAME;\n"); indent (out, "break;\n"); indentation --; indent (out, "}\n"); } else if (compose_fun == A68_MAKE_OTHERS) { if (compile_unit (p, out, A68_MAKE_FUNCTION) == NO_TEXT) { if (IS (p, UNIT) && IS (SUB (p), TERTIARY)) { compile_units (SUB_SUB (p), out); } else { compile_units (SUB (p), out); } } else if (SUB (p) != NO_NODE && GINFO (SUB (p)) != NO_GINFO && COMPILE_NODE (GINFO (SUB (p))) > 0) { COMPILE_NODE (GINFO (p)) = COMPILE_NODE (GINFO (SUB (p))); COMPILE_NAME (GINFO (p)) = COMPILE_NAME (GINFO (SUB (p))); } } return (A68_TRUE); } else { (* count)++; return (A68_FALSE); } } else { if (compile_int_case_units (SUB (p), out, sym, k, count, compose_fun)) { return (A68_TRUE); } else { return (compile_int_case_units (NEXT (p), out, sym, k, count, compose_fun)); } } } } /*! \brief compile integral-case-clause \param p position in tree **/ static char * compile_int_case_clause (NODE_T * p, FILE_T out, int compose_fun) { static char fn[NAME_SIZE]; char pop[NAME_SIZE]; int units = 0, decs = 0, k = 0, count = 0; NODE_T * q, * last; /* We only compile CASE basic unit */ /* Check worthiness of the clause */ if (MOID (p) != MODE (VOID)) { return (NO_TEXT); } q = SUB (p); if (q != NO_NODE && is_one_of (q, CASE_PART, OPEN_PART, STOP)) { if (! basic_serial (NEXT_SUB (q), 1)) { return (NO_TEXT); } FORWARD (q); } else { return (NO_TEXT); } while (q != NO_NODE && is_one_of (q, CASE_IN_PART, OUT_PART, CHOICE, STOP)) { if (LABELS (TABLE (NEXT_SUB (q))) != NO_TAG) { return (NO_TEXT); } FORWARD (q); } if (q != NO_NODE && is_one_of (q, ESAC_SYMBOL, CLOSE_SYMBOL)) { FORWARD (q); } else { return (NO_TEXT); } /* Generate embedded units */ q = SUB (p); if (q != NO_NODE && is_one_of (q, CASE_PART, OPEN_PART, STOP)) { FORWARD (q); if (q != NO_NODE && is_one_of (q, CASE_IN_PART, CHOICE, STOP)) { last = NO_NODE; units = decs = 0; k = 0; do { count = 1; k ++; } while (compile_int_case_units (NEXT_SUB (q), out, NO_NODE, k, & count, A68_MAKE_OTHERS)); FORWARD (q); } if (q != NO_NODE && is_one_of (q, OUT_PART, CHOICE, STOP)) { last = NO_NODE; units = decs = 0; compile_serial_clause (NEXT_SUB (q), out, &last, &units, &decs, pop, A68_MAKE_OTHERS); FORWARD (q); } } /* Prep and Dec */ (void) make_name (pop, PUP, "", NUMBER (p)); comment_source (p, out); (void) make_name (fn, "_case", "", NUMBER (p)); if (compose_fun == A68_MAKE_FUNCTION) { write_fun_prelude (p, out, fn); } root_idf = NO_DEC; q = SUB (p); inline_unit (SUB (NEXT_SUB (q)), out, L_DECLARE); (void) add_declaration (&root_idf, "ADDR_T", 0, pop); print_declarations (out, root_idf); /* Generate the function body */ indentf (out, snprintf (line, SNPRINTF_SIZE, "%s = stack_pointer;\n", pop)); q = SUB (p); inline_unit (SUB (NEXT_SUB (q)), out, L_EXECUTE); indent (out, "switch ("); inline_unit (SUB (NEXT_SUB (q)), out, L_YIELD); undent (out, ") {\n"); indentation ++; FORWARD (q); k = 0; do { count = 1; k ++; } while (compile_int_case_units (NEXT_SUB (q), out, SUB (q), k, & count, A68_MAKE_FUNCTION)); FORWARD (q); if (q != NO_NODE && is_one_of (q, OUT_PART, CHOICE, STOP)) { indent (out, "default: {\n"); indentation ++; embed_serial_clause (NEXT_SUB (q), out, pop); indent (out, "break;\n"); indentation --; indent (out, "}\n"); } indentation --; indent (out, "}\n"); if (compose_fun == A68_MAKE_FUNCTION) { (void) make_name (fn, "_case", "", NUMBER (p)); write_fun_postlude (p, out, fn); } return (fn); } /*! \brief compile loop clause \param out output file descriptor \param p starting node \return function name **/ static char * compile_loop_clause (NODE_T * p, FILE_T out, int compose_fun) { NODE_T *for_part = NO_NODE, *from_part = NO_NODE, *by_part = NO_NODE, *to_part = NO_NODE, * downto_part = NO_NODE, * while_part = NO_NODE, * sc; static char fn[NAME_SIZE]; char idf[NAME_SIZE], z[NAME_SIZE], pop[NAME_SIZE]; NODE_T * q = SUB (p), * last = NO_NODE; int units, decs; BOOL_T need_for = A68_FALSE, need_while = A68_FALSE, gc, need_reinit; /* FOR identifier */ if (IS (q, FOR_PART)) { need_for = A68_TRUE; for_part = NEXT_SUB (q); FORWARD (q); } /* FROM unit */ if (IS (p, FROM_PART)) { need_for = A68_TRUE; from_part = NEXT_SUB (q); if (! basic_unit (from_part)) { return (NO_TEXT); } FORWARD (q); } /* BY unit */ if (IS (q, BY_PART)) { need_for = A68_TRUE; by_part = NEXT_SUB (q); if (! basic_unit (by_part)) { return (NO_TEXT); } FORWARD (q); } /* TO unit, DOWNTO unit */ if (IS (q, TO_PART)) { need_for = A68_TRUE; 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); } if (IS (q, WHILE_PART)) { BOOL_T pop_lma, good_unit; if (need_for) { return (NO_TEXT); } need_while = A68_TRUE; pop_lma = long_mode_allowed; long_mode_allowed = A68_FALSE; /* We only compile WHILE basic unit, so we save on opening frames */ good_unit = basic_serial (NEXT_SUB (q), 1); long_mode_allowed = pop_lma; if (! good_unit) { return (NO_TEXT); } while_part = q; FORWARD (q); } /* We cannot yet compile DO UNTIL OD, only basic and classic A68 loops */ if (IS (q, DO_PART) || IS (q, ALT_DO_PART)) { sc = q = NEXT_SUB (q); if (IS (q, SERIAL_CLAUSE)) { FORWARD (q); } if (q != NO_NODE && IS (q, UNTIL_PART)) { return (NO_TEXT); } } else { return (NO_TEXT); } if (LABELS (TABLE (sc)) != NO_TAG) { return (NO_TEXT); } /* Loop clause is compiled */ units = decs = 0; compile_serial_clause (sc, out, &last, &units, &decs, pop, A68_MAKE_OTHERS); gc = (decs > 0); comment_source (p, out); (void) make_name (fn, "_loop", "", NUMBER (p)); if (compose_fun == A68_MAKE_FUNCTION) { write_fun_prelude (p, out, fn); } root_idf = NO_DEC; if (need_for) { (void) make_name (idf, "k", "", NUMBER (p)); (void) add_declaration (&root_idf, "int", 0, idf); if (for_part != NO_NODE) { (void) make_name (z, "z", "", NUMBER (p)); (void) add_declaration (&root_idf, "A68_INT", 1, z); } } if (from_part != NO_NODE) { inline_unit (from_part, out, L_DECLARE); } if (by_part != NO_NODE) { inline_unit (by_part, out, L_DECLARE); } if (to_part != NO_NODE) { inline_unit (to_part, out, L_DECLARE); } if (downto_part != NO_NODE) { inline_unit (downto_part, out, L_DECLARE); } if (while_part != NO_NODE) { inline_unit (SUB (NEXT_SUB (while_part)), out, L_DECLARE); } (void) make_name (pop, PUP, "", NUMBER (p)); (void) add_declaration (&root_idf, "ADDR_T", 0, pop); print_declarations (out, root_idf); indentf (out, snprintf (line, SNPRINTF_SIZE, "%s = stack_pointer;\n", pop)); if (from_part != NO_NODE) { inline_unit (from_part, out, L_EXECUTE); } if (by_part != NO_NODE) { inline_unit (by_part, out, L_EXECUTE); } if (to_part != NO_NODE) { inline_unit (to_part, out, L_EXECUTE); } if (downto_part != NO_NODE) { inline_unit (downto_part, out, L_EXECUTE); } if (while_part != NO_NODE) { inline_unit (SUB (NEXT_SUB (while_part)), out, L_EXECUTE); } indentf (out, snprintf (line, SNPRINTF_SIZE, "OPEN_STATIC_FRAME (_N_ (%d));\n", NUMBER (sc))); init_static_frame (out, sc); if (for_part != NO_NODE) { indentf (out, snprintf (line, SNPRINTF_SIZE, "%s = (A68_INT *) (FRAME_OBJECT (OFFSET (TAX (_N_ (%d)))));\n", z, NUMBER (for_part))); } /* The loop in C */ if (!need_while && ! need_for) { indent (out, "while (A68_TRUE) {\n"); } else if (need_while && ! need_for) { indent (out, "while ("); inline_unit (SUB (NEXT_SUB (while_part)), out, L_YIELD); undent (out, ") {\n"); } else { /* Initialisation */ indentf (out, snprintf (line, SNPRINTF_SIZE, "for (%s = ", idf)); if (from_part == NO_NODE) { undent (out, "1"); } else { inline_unit (from_part, out, L_YIELD); } undent (out, "; "); /* Condition */ if (to_part == NO_NODE && downto_part == NO_NODE && while_part == NO_NODE) { undent (out, "A68_TRUE"); } else { undent (out, idf); if (to_part != NO_NODE) { undent (out, " <= "); } else if (downto_part != NO_NODE) { undent (out, " >= "); } inline_unit (to_part, out, L_YIELD); } undent (out, "; "); /* Increment */ if (by_part == NO_NODE) { undent (out, idf); if (to_part != NO_NODE) { undent (out, " ++"); } else if (downto_part != NO_NODE) { undent (out, " --"); } else { undent (out, " ++"); } } else { undent (out, idf); if (to_part != NO_NODE) { undent (out, " += "); } else if (downto_part != NO_NODE) { undent (out, " -= "); } else { undent (out, " += "); } inline_unit (by_part, out, L_YIELD); } undent (out, ") {\n"); } indentation++; if (gc) { indent (out, "/* PREEMPTIVE_GC; */\n"); } if (for_part != NO_NODE) { indentf (out, snprintf (line, SNPRINTF_SIZE, "_S_ (%s) = INIT_MASK;\n", z)); indentf (out, snprintf (line, SNPRINTF_SIZE, "_V_ (%s) = %s;\n", z, idf)); } units = decs = 0; compile_serial_clause (sc, out, &last, &units, &decs, pop, A68_MAKE_FUNCTION); /* Re-initialise if necessary */ need_reinit = (BOOL_T) (AP_INCREMENT (TABLE (sc)) > 0 || need_initialise_frame (sc)); if (need_reinit) { indent (out, "if ("); if (to_part == NO_NODE && downto_part == NO_NODE) { undent (out, "A68_TRUE"); } else { undent (out, idf); if (to_part != NO_NODE) { undent (out, " < "); } else if (downto_part != NO_NODE) { undent (out, " > "); } inline_unit (to_part, out, L_YIELD); } undent (out, ") {\n"); indentation++; if (AP_INCREMENT (TABLE (sc)) > 0) { indentf (out, snprintf (line, SNPRINTF_SIZE, "FRAME_CLEAR (%d);\n", AP_INCREMENT (TABLE (sc)))); } if (need_initialise_frame (sc)) { indentf (out, snprintf (line, SNPRINTF_SIZE, "initialise_frame (_N_ (%d));\n", NUMBER (sc))); } indentation--; indent (out, "}\n"); } /* End of loop */ indentation--; indent (out, "}\n"); indent (out, "CLOSE_FRAME;\n"); indentf (out, snprintf (line, SNPRINTF_SIZE, "stack_pointer = %s;\n", pop)); if (compose_fun == A68_MAKE_FUNCTION) { (void) make_name (fn, "_loop", "", NUMBER (p)); write_fun_postlude (p, out, fn); } return (fn); } /*! \brief compile serial units \param out output file descriptor \param p starting node \return function name **/ static char * compile_unit (NODE_T * p, FILE_T out, BOOL_T compose_fun) { /**/ #define COMPILE(p, out, fun, compose_fun) {\ char * fn = (fun) (p, out, compose_fun);\ if (compose_fun == A68_MAKE_FUNCTION && fn != NO_TEXT) {\ ABEND (strlen (fn) > 32, ERROR_INTERNAL_CONSISTENCY, NO_TEXT);\ COMPILE_NAME (GINFO (p)) = new_string (fn, NO_TEXT);\ if (SUB (p) != NO_NODE && COMPILE_NODE (GINFO (SUB (p))) > 0) {\ COMPILE_NODE (GINFO (p)) = COMPILE_NODE (GINFO (SUB (p)));\ } else {\ COMPILE_NODE (GINFO (p)) = NUMBER (p);\ }\ return (COMPILE_NAME (GINFO (p)));\ } else {\ COMPILE_NAME (GINFO (p)) = NO_TEXT;\ COMPILE_NODE (GINFO (p)) = 0;\ return (NO_TEXT);\ }} /**/ LOW_SYSTEM_STACK_ALERT (p); if (p == NO_NODE) { return (NO_TEXT); } else if (is_one_of (p, UNIT, TERTIARY, SECONDARY, PRIMARY, ENCLOSED_CLAUSE, STOP)) { COMPILE (SUB (p), out, compile_unit, compose_fun); } if (DEBUG_LEVEL >= 3) { /* Control structure */ if (IS (p, CLOSED_CLAUSE)) { COMPILE (p, out, compile_closed_clause, compose_fun); } else if (IS (p, COLLATERAL_CLAUSE)) { COMPILE (p, out, compile_collateral_clause, compose_fun); } else if (IS (p, CONDITIONAL_CLAUSE)) { char * fn2 = compile_basic_conditional (p, out, compose_fun); if (compose_fun == A68_MAKE_FUNCTION && fn2 != NO_TEXT) { ABEND (strlen (fn2) > 32, ERROR_INTERNAL_CONSISTENCY, NO_TEXT); COMPILE_NAME (GINFO (p)) = new_string (fn2, NO_TEXT); if (SUB (p) != NO_NODE && COMPILE_NODE (GINFO (SUB (p))) > 0) { COMPILE_NODE (GINFO (p)) = COMPILE_NODE (GINFO (SUB (p))); } else { COMPILE_NODE (GINFO (p)) = NUMBER (p); } return (COMPILE_NAME (GINFO (p))); } else { COMPILE (p, out, compile_conditional_clause, compose_fun); } } else if (IS (p, CASE_CLAUSE)) { COMPILE (p, out, compile_int_case_clause, compose_fun); } else if (IS (p, LOOP_CLAUSE)) { COMPILE (p, out, compile_loop_clause, compose_fun); } } if (DEBUG_LEVEL >= 2) { /* Simple constructions */ if (IS (p, VOIDING) && IS (SUB (p), ASSIGNATION) && locate (SUB_SUB (p), IDENTIFIER) != NO_NODE) { COMPILE (p, out, compile_voiding_assignation_identifier, compose_fun); } else if (IS (p, VOIDING) && IS (SUB (p), ASSIGNATION) && locate (SUB_SUB (p), SLICE) != NO_NODE) { COMPILE (p, out, compile_voiding_assignation_slice, compose_fun); } else if (IS (p, VOIDING) && IS (SUB (p), ASSIGNATION) && locate (SUB_SUB (p), SELECTION) != NO_NODE) { COMPILE (p, out, compile_voiding_assignation_selection, compose_fun); } else if (IS (p, SLICE)) { COMPILE (p, out, compile_slice, compose_fun); } else if (IS (p, DEREFERENCING) && locate (SUB (p), SLICE) != NO_NODE) { COMPILE (p, out, compile_dereference_slice, compose_fun); } else if (IS (p, SELECTION)) { COMPILE (p, out, compile_selection, compose_fun); } else if (IS (p, DEREFERENCING) && locate (SUB (p), SELECTION) != NO_NODE) { COMPILE (p, out, compile_dereference_selection, compose_fun); } else if (IS (p, CAST)) { COMPILE (p, out, compile_cast, compose_fun); } else if (IS (p, VOIDING) && IS (SUB (p), FORMULA)) { COMPILE (SUB (p), out, compile_voiding_formula, compose_fun); } else if (IS (p, VOIDING) && IS (SUB (p), MONADIC_FORMULA)) { COMPILE (SUB (p), out, compile_voiding_formula, compose_fun); } else if (IS (p, DEPROCEDURING)) { COMPILE (p, out, compile_deproceduring, compose_fun); } else if (IS (p, VOIDING) && IS (SUB (p), DEPROCEDURING)) { COMPILE (p, out, compile_voiding_deproceduring, compose_fun); } else if (IS (p, CALL)) { COMPILE (p, out, compile_call, compose_fun); } else if (IS (p, VOIDING) && IS (SUB (p), CALL)) { COMPILE (p, out, compile_voiding_call, compose_fun); } else if (IS (p, IDENTITY_RELATION)) { COMPILE (p, out, compile_identity_relation, compose_fun); } else if (IS (p, UNITING)) { COMPILE (p, out, compile_uniting, compose_fun); } } if (DEBUG_LEVEL >= 1) { /* Debugging stuff, only basic */ if (IS (p, DENOTATION)) { COMPILE (p, out, compile_denotation, compose_fun); } else if (IS (p, IDENTIFIER)) { COMPILE (p, out, compile_identifier, compose_fun); } else if (IS (p, DEREFERENCING) && locate (SUB (p), IDENTIFIER) != NO_NODE) { COMPILE (p, out, compile_dereference_identifier, compose_fun); } else if (IS (p, MONADIC_FORMULA)) { COMPILE (p, out, compile_formula, compose_fun); } else if (IS (p, FORMULA)) { COMPILE (p, out, compile_formula, compose_fun); } } if (IS (p, CODE_CLAUSE)) { COMPILE (p, out, compile_code_clause, compose_fun); } return (NO_TEXT); #undef COMPILE } /*! \brief compile units \param p starting node \param out output file descriptor **/ void compile_units (NODE_T * p, FILE_T out) { ADDR_T pop_temp_heap_pointer = temp_heap_pointer; /* At the end we discard temporary declarations */ for (; p != NO_NODE; FORWARD (p)) { if (IS (p, UNIT) || IS (p, CODE_CLAUSE)) { if (compile_unit (p, out, A68_MAKE_FUNCTION) == NO_TEXT) { compile_units (SUB (p), out); } else if (SUB (p) != NO_NODE && GINFO (SUB (p)) != NO_GINFO && COMPILE_NODE (GINFO (SUB (p))) > 0) { COMPILE_NODE (GINFO (p)) = COMPILE_NODE (GINFO (SUB (p))); COMPILE_NAME (GINFO (p)) = COMPILE_NAME (GINFO (SUB (p))); } } else { compile_units (SUB (p), out); } } temp_heap_pointer = pop_temp_heap_pointer; } /*! \brief compiler driver \param p module to compile \param out output file descriptor **/ void compiler (FILE_T out) { if (OPTION_OPTIMISE (&program) == A68_FALSE) { return; } indentation = 0; temp_book_pointer = 0; root_idf = NO_DEC; global_level = A68_MAX_INT; global_pointer = 0; get_global_level (SUB (TOP_NODE (&program))); max_lex_lvl = 0; genie_preprocess (TOP_NODE (&program), & max_lex_lvl, NULL); write_prelude (out); get_global_level (TOP_NODE (&program)); stack_pointer = stack_start; expr_stack_limit = stack_end - storage_overhead; compile_units (TOP_NODE (&program), out); ABEND (indentation != 0, "indentation error", NO_TEXT); } algol68g-2.4.1/source/genie.c0000644000175000001440000060430211771450002012613 00000000000000/*! \file genie.c \brief routines executing primitive A68 actions */ /* This file is part of Algol68G - an Algol 68 interpreter. Copyright (C) 2001-2012 J. Marcel van der Veer . This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 3 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see . */ #if defined HAVE_CONFIG_H #include "a68g-config.h" #endif #include "a68g.h" A68_HANDLE nil_handle = { INIT_MASK, NO_BYTE, 0, NO_MOID, NO_HANDLE, NO_HANDLE }; A68_REF nil_ref = { (STATUS_MASK) (INIT_MASK | NIL_MASK), 0, 0, NO_HANDLE }; #define IF_ROW(m)\ (IS (m, FLEX_SYMBOL) || IS (m, ROW_SYMBOL) || m == MODE (STRING)) ADDR_T frame_pointer = 0, stack_pointer = 0, heap_pointer = 0, handle_pointer = 0, global_pointer = 0, frame_start, frame_end, stack_start, stack_end; BOOL_T do_confirm_exit = A68_TRUE; BYTE_T *stack_segment = NO_BYTE, *heap_segment = NO_BYTE, *handle_segment = NO_BYTE; NODE_T *last_unit = NO_NODE; int global_level = 0, ret_code, ret_line_number, ret_char_number; int max_lex_lvl = 0; jmp_buf genie_exit_label; int frame_stack_size, expr_stack_size, heap_size, handle_pool_size; int stack_limit, frame_stack_limit, expr_stack_limit; int storage_overhead; A68_PROCEDURE on_gc_event; static A68_REF genie_make_rowrow (NODE_T *, MOID_T *, int, ADDR_T); static A68_REF genie_make_ref_row_of_row (NODE_T *, MOID_T *, MOID_T *, ADDR_T); static A68_REF genie_make_ref_row_row (NODE_T *, MOID_T *, MOID_T *, ADDR_T); static A68_REF genie_clone (NODE_T *, MOID_T *, A68_REF *, A68_REF *); static A68_REF genie_store (NODE_T *, MOID_T *, A68_REF *, A68_REF *); static void genie_clone_stack (NODE_T *, MOID_T *, A68_REF *, A68_REF *); static void genie_serial_units_no_label (NODE_T *, int, NODE_T **); /* Genie routines */ static PROP_T genie_and_function (NODE_T *); static PROP_T genie_assertion (NODE_T *); static PROP_T genie_assignation_constant (NODE_T *); static PROP_T genie_assignation (NODE_T *); static PROP_T genie_call (NODE_T *); static PROP_T genie_cast (NODE_T *); static PROP_T genie_closed (volatile NODE_T *); static PROP_T genie_coercion (NODE_T *); static PROP_T genie_collateral (NODE_T *); static PROP_T genie_column_function (NODE_T *); static PROP_T genie_conditional (volatile NODE_T *); static PROP_T genie_constant (NODE_T *); static PROP_T genie_denotation (NODE_T *); static PROP_T genie_deproceduring (NODE_T *); static PROP_T genie_dereference_frame_identifier (NODE_T *); static PROP_T genie_dereference_generic_identifier (NODE_T *); static PROP_T genie_dereference_selection_name_quick (NODE_T *); static PROP_T genie_dereference_slice_name_quick (NODE_T *); static PROP_T genie_dereferencing (NODE_T *); static PROP_T genie_dereferencing_quick (NODE_T *); static PROP_T genie_diagonal_function (NODE_T *); static PROP_T genie_dyadic (NODE_T *); static PROP_T genie_dyadic_quick (NODE_T *); static PROP_T genie_enclosed (volatile NODE_T *); static PROP_T genie_field_selection (NODE_T *); static PROP_T genie_format_text (NODE_T *); static PROP_T genie_formula (NODE_T *); static PROP_T genie_generator (NODE_T *); static PROP_T genie_identifier (NODE_T *); static PROP_T genie_identifier_standenv (NODE_T *); static PROP_T genie_identifier_standenv_proc (NODE_T *); static PROP_T genie_identity_relation (NODE_T *); static PROP_T genie_int_case (volatile NODE_T *); static PROP_T genie_frame_identifier (NODE_T *); static PROP_T genie_loop (volatile NODE_T *); static PROP_T genie_monadic (NODE_T *); static PROP_T genie_nihil (NODE_T *); static PROP_T genie_or_function (NODE_T *); static PROP_T genie_routine_text (NODE_T *); static PROP_T genie_row_function (NODE_T *); static PROP_T genie_rowing (NODE_T *); static PROP_T genie_rowing_ref_row_of_row (NODE_T *); static PROP_T genie_rowing_ref_row_row (NODE_T *); static PROP_T genie_rowing_row_of_row (NODE_T *); static PROP_T genie_rowing_row_row (NODE_T *); static PROP_T genie_selection_name_quick (NODE_T *); static PROP_T genie_selection (NODE_T *); static PROP_T genie_selection_value_quick (NODE_T *); static PROP_T genie_skip (NODE_T *); static PROP_T genie_slice_name_quick (NODE_T *); static PROP_T genie_slice (NODE_T *); static PROP_T genie_transpose_function (NODE_T *); static PROP_T genie_united_case (volatile NODE_T *); static PROP_T genie_uniting (NODE_T *); static PROP_T genie_unit (NODE_T *); static PROP_T genie_voiding_assignation_constant (NODE_T *); static PROP_T genie_voiding_assignation (NODE_T *); static PROP_T genie_voiding (NODE_T *); static PROP_T genie_widening_int_to_real (NODE_T *); static PROP_T genie_widening (NODE_T *); static PROP_T genie_assignation_quick (NODE_T * p); static PROP_T genie_loop (volatile NODE_T *); #if defined HAVE_PARALLEL_CLAUSE static PROP_T genie_parallel (NODE_T *); #endif /*! \brief nop for the genie, for instance '+' for INT or REAL \param p position in tree **/ void genie_idle (NODE_T * p) { (void) p; } /*! \brief unimplemented feature handler \param p position in tree **/ void genie_unimplemented (NODE_T * p) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_UNIMPLEMENTED); exit_genie (p, A68_RUNTIME_ERROR); } /*! \brief PROC system = (STRING) INT \param p position in tree **/ void genie_system (NODE_T * p) { int sys_ret_code, size; A68_REF cmd; A68_REF ref_z; POP_REF (p, &cmd); CHECK_INIT (p, INITIALISED (&cmd), MODE (STRING)); size = 1 + a68_string_size (p, cmd); ref_z = heap_generator (p, MODE (C_STRING), 1 + size); sys_ret_code = system (a_to_c_string (p, DEREF (char, &ref_z), cmd)); PUSH_PRIMITIVE (p, sys_ret_code, A68_INT); } /*! \brief set flags throughout tree \param p position in tree **/ void change_masks (NODE_T * p, unsigned mask, BOOL_T set) { for (; p != NO_NODE; FORWARD (p)) { change_masks (SUB (p), mask, set); if (LINE_NUMBER (p) > 0) { if (set == A68_TRUE) { STATUS_SET (p, mask); } else { STATUS_CLEAR (p, mask); } } } } /*! \brief leave interpretation \param p position in tree \param ret exit code **/ void exit_genie (NODE_T * p, int ret) { #if defined HAVE_CURSES genie_curses_end (p); #endif if (!in_execution) { return; } if (ret == A68_RUNTIME_ERROR && in_monitor) { return; } else if (ret == A68_RUNTIME_ERROR && OPTION_DEBUG (&program)) { diagnostics_to_terminal (TOP_LINE (&program), A68_RUNTIME_ERROR); single_step (p, (unsigned) BREAKPOINT_ERROR_MASK); in_execution = A68_FALSE; ret_line_number = LINE_NUMBER (p); ret_code = ret; longjmp (genie_exit_label, 1); } else { if (ret > A68_FORCE_QUIT) { ret -= A68_FORCE_QUIT; } #if defined HAVE_PARALLEL_CLAUSE if (!is_main_thread ()) { genie_set_exit_from_threads (ret); } else { in_execution = A68_FALSE; ret_line_number = LINE_NUMBER (p); ret_code = ret; longjmp (genie_exit_label, 1); } #else in_execution = A68_FALSE; ret_line_number = LINE_NUMBER (p); ret_code = ret; longjmp (genie_exit_label, 1); #endif } } /*! \brief genie init rng **/ void genie_init_rng (void) { time_t t; if (time (&t) != -1) { struct tm *u = localtime (&t); int seed = TM_SEC (u) + 60 * (TM_MIN (u) + 60 * TM_HOUR (u)); init_rng ((long unsigned) seed); } } /*! \brief tie label to the clause it is defined in \param p position in tree **/ void tie_label_to_serial (NODE_T * p) { for (; p != NO_NODE; FORWARD (p)) { if (IS (p, SERIAL_CLAUSE)) { BOOL_T valid_follow; if (NEXT (p) == NO_NODE) { valid_follow = A68_TRUE; } else if (IS (NEXT (p), CLOSE_SYMBOL)) { valid_follow = A68_TRUE; } else if (IS (NEXT (p), END_SYMBOL)) { valid_follow = A68_TRUE; } else if (IS (NEXT (p), EDOC_SYMBOL)) { valid_follow = A68_TRUE; } else if (IS (NEXT (p), OD_SYMBOL)) { valid_follow = A68_TRUE; } else { valid_follow = A68_FALSE; } if (valid_follow) { JUMP_TO (TABLE (SUB (p))) = NO_NODE; } } tie_label_to_serial (SUB (p)); } } /*! \brief tie label to the clause it is defined in \param p position in tree \param unit associated unit **/ static void tie_label (NODE_T * p, NODE_T * unit) { for (; p != NO_NODE; FORWARD (p)) { if (IS (p, DEFINING_IDENTIFIER)) { UNIT (TAX (p)) = unit; } tie_label (SUB (p), unit); } } /*! \brief tie label to the clause it is defined in \param p position in tree **/ void tie_label_to_unit (NODE_T * p) { for (; p != NO_NODE; FORWARD (p)) { if (IS (p, LABELED_UNIT)) { tie_label (SUB_SUB (p), NEXT_SUB (p)); } tie_label_to_unit (SUB (p)); } } /*! \brief fast way to indicate a mode \param p position in tree **/ static int mode_attribute (MOID_T * p) { if (IS (p, REF_SYMBOL)) { return (REF_SYMBOL); } else if (IS (p, PROC_SYMBOL)) { return (PROC_SYMBOL); } else if (IS (p, UNION_SYMBOL)) { return (UNION_SYMBOL); } else if (p == MODE (INT)) { return (MODE_INT); } else if (p == MODE (LONG_INT)) { return (MODE_LONG_INT); } else if (p == MODE (LONGLONG_INT)) { return (MODE_LONGLONG_INT); } else if (p == MODE (REAL)) { return (MODE_REAL); } else if (p == MODE (LONG_REAL)) { return (MODE_LONG_REAL); } else if (p == MODE (LONGLONG_REAL)) { return (MODE_LONGLONG_REAL); } else if (p == MODE (COMPLEX)) { return (MODE_COMPLEX); } else if (p == MODE (LONG_COMPLEX)) { return (MODE_LONG_COMPLEX); } else if (p == MODE (LONGLONG_COMPLEX)) { return (MODE_LONGLONG_COMPLEX); } else if (p == MODE (BOOL)) { return (MODE_BOOL); } else if (p == MODE (CHAR)) { return (MODE_CHAR); } else if (p == MODE (BITS)) { return (MODE_BITS); } else if (p == MODE (LONG_BITS)) { return (MODE_LONG_BITS); } else if (p == MODE (LONGLONG_BITS)) { return (MODE_LONGLONG_BITS); } else if (p == MODE (BYTES)) { return (MODE_BYTES); } else if (p == MODE (LONG_BYTES)) { return (MODE_LONG_BYTES); } else if (p == MODE (FILE)) { return (MODE_FILE); } else if (p == MODE (FORMAT)) { return (MODE_FORMAT); } else if (p == MODE (PIPE)) { return (MODE_PIPE); } else if (p == MODE (SOUND)) { return (MODE_SOUND); } else { return (MODE_NO_CHECK); } } /*! \brief perform tasks before interpretation \param p position in tree \param max_lev maximum level found **/ void genie_preprocess (NODE_T * p, int *max_lev, void *compile_lib) { #if defined HAVE_COMPILER static char * last_compile_name = NO_TEXT; static PROP_PROC * last_compile_unit = NO_PPROC; #endif for (; p != NO_NODE; FORWARD (p)) { if (STATUS_TEST (p, BREAKPOINT_MASK)) { if (!(STATUS_TEST (p, INTERRUPTIBLE_MASK))) { STATUS_CLEAR (p, BREAKPOINT_MASK); } } if (GINFO (p) != NO_GINFO) { IS_COERCION (GINFO (p)) = is_coercion (p); IS_NEW_LEXICAL_LEVEL (GINFO (p)) = is_new_lexical_level (p); /* The default */ UNIT (&GPROP (p)) = genie_unit; SOURCE (&GPROP (p)) = p; #if defined HAVE_COMPILER if (OPTION_OPTIMISE (&program) && COMPILE_NAME (GINFO (p)) != NO_TEXT && compile_lib != NULL) { if (COMPILE_NAME (GINFO (p)) == last_compile_name) { /* copy */ UNIT (&GPROP (p)) = last_compile_unit; } else { /* look up */ /* Next line provokes a warning that cannot be suppressed, not even by this POSIX workaround. Tant pis. */ * (void **) &(UNIT (&GPROP (p))) = dlsym (compile_lib, COMPILE_NAME (GINFO (p))); ABEND (UNIT (&GPROP (p)) == NULL, "compiler cannot resolve", dlerror ()); last_compile_name = COMPILE_NAME (GINFO (p)); last_compile_unit = UNIT (&GPROP (p)); } } #endif } if (MOID (p) != NO_MOID) { SIZE (MOID (p)) = moid_size (MOID (p)); SHORT_ID (MOID (p)) = mode_attribute (MOID (p)); if (GINFO (p) != NO_GINFO) { NEED_DNS (GINFO (p)) = A68_FALSE; if (IS (MOID (p), REF_SYMBOL)) { NEED_DNS (GINFO (p)) = A68_TRUE; } else if (IS (MOID (p), PROC_SYMBOL)) { NEED_DNS (GINFO (p)) = A68_TRUE; } else if (IS (MOID (p), FORMAT_SYMBOL)) { NEED_DNS (GINFO (p)) = A68_TRUE; } } } if (TABLE (p) != NO_TABLE) { if (LEX_LEVEL (p) > *max_lev) { *max_lev = LEX_LEVEL (p); } } if (IS (p, FORMAT_TEXT)) { TAG_T *q = TAX (p); if (q != NO_TAG && NODE (q) != NO_NODE) { NODE (q) = p; } } else if (IS (p, DEFINING_IDENTIFIER)) { TAG_T *q = TAX (p); if (q != NO_TAG && NODE (q) != NO_NODE && TABLE (NODE (q)) != NO_TABLE) { LEVEL (GINFO (p)) = LEX_LEVEL (NODE (q)); } } else if (IS (p, IDENTIFIER)) { TAG_T *q = TAX (p); if (q != NO_TAG && NODE (q) != NO_NODE && TABLE (NODE (q)) != NO_TABLE) { LEVEL (GINFO (p)) = LEX_LEVEL (NODE (q)); OFFSET (GINFO (p)) = &stack_segment[FRAME_INFO_SIZE + OFFSET (q)]; } } else if (IS (p, OPERATOR)) { TAG_T *q = TAX (p); if (q != NO_TAG && NODE (q) != NO_NODE && TABLE (NODE (q)) != NO_TABLE) { LEVEL (GINFO (p)) = LEX_LEVEL (NODE (q)); OFFSET (GINFO (p)) = &stack_segment[FRAME_INFO_SIZE + OFFSET (q)]; } } if (SUB (p) != NO_NODE) { if (GINFO (p) != NO_GINFO) { GPARENT (SUB (p)) = p; } genie_preprocess (SUB (p), max_lev, compile_lib); } } } /*! \brief get outermost lexical level in the user program \param p position in tree **/ void get_global_level (NODE_T * p) { for (; p != NO_NODE; FORWARD (p)) { if (LINE_NUMBER (p) != 0 && IS (p, UNIT)) { if (LEX_LEVEL (p) < global_level) { global_level = LEX_LEVEL (p); } } get_global_level (SUB (p)); } } /*! \brief free heap allocated by genie \param p position in tree **/ void free_genie_heap (NODE_T * p) { for (; p != NO_NODE; FORWARD (p)) { free_genie_heap (SUB (p)); if (GINFO (p) != NO_GINFO && CONSTANT (GINFO (p)) != NO_CONSTANT) { free (CONSTANT (GINFO (p))); CONSTANT (GINFO (p)) = NO_CONSTANT; } } } /*! \brief driver for the interpreter **/ void genie (void * compile_lib) { MOID_T *m; /* Fill in final info for modes */ for (m = TOP_MOID (&program); m != NO_MOID; FORWARD (m)) { SIZE (m) = moid_size (m); SHORT_ID (m) = mode_attribute (m); } /* Preprocessing */ max_lex_lvl = 0; /* genie_lex_levels (TOP_NODE (&program), 1); */ genie_preprocess (TOP_NODE (&program), &max_lex_lvl, compile_lib); change_masks (TOP_NODE (&program), BREAKPOINT_INTERRUPT_MASK, A68_FALSE); watchpoint_expression = NO_TEXT; frame_stack_limit = frame_end - storage_overhead; expr_stack_limit = stack_end - storage_overhead; if (OPTION_REGRESSION_TEST (&program)) { init_rng (1); } else { genie_init_rng (); } io_close_tty_line (); if (OPTION_TRACE (&program)) { ASSERT (snprintf (output_line, SNPRINTF_SIZE, "genie: frame stack %dk, expression stack %dk, heap %dk, handles %dk\n", frame_stack_size / KILOBYTE, expr_stack_size / KILOBYTE, heap_size / KILOBYTE, handle_pool_size / KILOBYTE) >= 0); WRITE (STDOUT_FILENO, output_line); } install_signal_handlers (); set_default_event_procedure (&on_gc_event); do_confirm_exit = A68_TRUE; /* Dive into the program */ if (setjmp (genie_exit_label) == 0) { NODE_T *p = SUB (TOP_NODE (&program)); /* If we are to stop in the monitor, set a breakpoint on the first unit */ if (OPTION_DEBUG (&program)) { change_masks (TOP_NODE (&program), BREAKPOINT_TEMPORARY_MASK, A68_TRUE); WRITE (STDOUT_FILENO, "Execution begins ..."); } RESET_ERRNO; ret_code = 0; global_level = A68_MAX_INT; global_pointer = 0; get_global_level (p); frame_pointer = frame_start; stack_pointer = stack_start; FRAME_DYNAMIC_LINK (frame_pointer) = 0; FRAME_DNS (frame_pointer) = 0; FRAME_STATIC_LINK (frame_pointer) = 0; FRAME_NUMBER (frame_pointer) = 0; FRAME_TREE (frame_pointer) = (NODE_T *) p; FRAME_LEXICAL_LEVEL (frame_pointer) = LEX_LEVEL (p); FRAME_PARAMETER_LEVEL (frame_pointer) = LEX_LEVEL (p); FRAME_PARAMETERS (frame_pointer) = frame_pointer; initialise_frame (p); genie_init_heap (p); genie_init_transput (TOP_NODE (&program)); cputime_0 = seconds (); /* Here we go .. */ in_execution = A68_TRUE; last_unit = TOP_NODE (&program); #if ! defined HAVE_WIN32 (void) alarm (1); #endif /* ! defined HAVE_WIN32 */ if (OPTION_TRACE (&program)) { WIS (TOP_NODE (&program)); } (void) genie_enclosed (TOP_NODE (&program)); } else { /* Here we have jumped out of the interpreter. What happened? */ if (OPTION_DEBUG (&program)) { WRITE (STDOUT_FILENO, "Execution discontinued"); } if (ret_code == A68_RERUN) { diagnostics_to_terminal (TOP_LINE (&program), A68_RUNTIME_ERROR); genie (compile_lib); } else if (ret_code == A68_RUNTIME_ERROR) { if (OPTION_BACKTRACE (&program)) { int printed = 0; ASSERT (snprintf (output_line, SNPRINTF_SIZE, "\nStack backtrace") >= 0); WRITE (STDOUT_FILENO, output_line); stack_dump (STDOUT_FILENO, frame_pointer, 16, &printed); WRITE (STDOUT_FILENO, NEWLINE_STRING); } if (FILE_LISTING_OPENED (&program)) { int printed = 0; ASSERT (snprintf (output_line, SNPRINTF_SIZE, "\nStack backtrace") >= 0); WRITE (FILE_LISTING_FD (&program), output_line); stack_dump (FILE_LISTING_FD (&program), frame_pointer, 32, &printed); } } } in_execution = A68_FALSE; } /* This file contains interpreter ("genie") routines related to executing primitive A68 actions. The genie is self-optimising as when it traverses the tree, it stores terminals it ends up in at the root where traversing for that terminal started. Such piece of information is called a PROP. */ /*! \brief shows line where 'p' is at and draws a '-' beneath the position \param f file number \param p position in tree **/ void where_in_source (FILE_T f, NODE_T * p) { write_source_line (f, LINE (INFO (p)), p, A68_NO_DIAGNOSTICS); } /* Since Algol 68 can pass procedures as parameters, we use static links rather than a display. */ /*! \brief initialise PROC and OP identities \param p starting node of a declaration \param seq chain to link nodes into \param count number of constants initialised **/ static void genie_init_proc_op (NODE_T * p, NODE_T ** seq, int *count) { for (; p != NO_NODE; FORWARD (p)) { switch (ATTRIBUTE (p)) { case OP_SYMBOL: case PROC_SYMBOL: case OPERATOR_PLAN: case DECLARER: { break; } case DEFINING_IDENTIFIER: case DEFINING_OPERATOR: { /* Store position so we need not search again */ NODE_T *save = *seq; (*seq) = p; SEQUENCE (*seq) = save; (*count)++; return; } default: { genie_init_proc_op (SUB (p), seq, count); break; } } } } /*! \brief initialise PROC and OP identity declarations \param p position in tree \param count number of constants initialised **/ void genie_find_proc_op (NODE_T * p, int *count) { for (; p != NO_NODE; FORWARD (p)) { if (GINFO (p) != NO_GINFO && IS_NEW_LEXICAL_LEVEL (GINFO (p))) { /* Don't enter a new lexical level - it will have its own initialisation */ return; } else if (IS (p, PROCEDURE_DECLARATION) || IS (p, BRIEF_OPERATOR_DECLARATION)) { genie_init_proc_op (SUB (p), &(SEQUENCE (TABLE (p))), count); return; } else { genie_find_proc_op (SUB (p), count); } } } void initialise_frame (NODE_T * p) { if (INITIALISE_ANON (TABLE (p))) { TAG_T *_a_; INITIALISE_ANON (TABLE (p)) = A68_FALSE; for (_a_ = ANONYMOUS (TABLE (p)); _a_ != NO_TAG; FORWARD (_a_)) { if (PRIO (_a_) == ROUTINE_TEXT) { int youngest = YOUNGEST_ENVIRON (TAX (NODE (_a_))); A68_PROCEDURE *_z_ = (A68_PROCEDURE *) (FRAME_OBJECT (OFFSET (_a_))); STATUS (_z_) = INIT_MASK; NODE (&(BODY (_z_))) = NODE (_a_); if (youngest > 0) { STATIC_LINK_FOR_FRAME (ENVIRON (_z_), 1 + youngest); } else { ENVIRON (_z_) = 0; } LOCALE (_z_) = NO_HANDLE; MOID (_z_) = MOID (_a_); INITIALISE_ANON (TABLE (p)) = A68_TRUE; } else if (PRIO (_a_) == FORMAT_TEXT) { int youngest = YOUNGEST_ENVIRON (TAX (NODE (_a_))); A68_FORMAT *_z_ = (A68_FORMAT *) (FRAME_OBJECT (OFFSET (_a_))); STATUS (_z_) = INIT_MASK; BODY (_z_) = NODE (_a_); if (youngest > 0) { STATIC_LINK_FOR_FRAME (ENVIRON (_z_), 1 + youngest); } else { ENVIRON (_z_) = 0; } INITIALISE_ANON (TABLE (p)) = A68_TRUE; } } } if (PROC_OPS (TABLE (p))) { NODE_T *_q_; ADDR_T pop_sp; if (SEQUENCE (TABLE (p)) == NO_NODE) { int count = 0; genie_find_proc_op (p, &count); PROC_OPS (TABLE (p)) = (BOOL_T) (count > 0); } pop_sp = stack_pointer; for (_q_ = SEQUENCE (TABLE (p)); _q_ != NO_NODE; _q_ = SEQUENCE (_q_)) { NODE_T *u = NEXT_NEXT (_q_); if (IS (u, ROUTINE_TEXT)) { NODE_T *src = SOURCE (&(GPROP (u))); *(A68_PROCEDURE *) FRAME_OBJECT (OFFSET (TAX (_q_))) = *(A68_PROCEDURE *) (FRAME_OBJECT (OFFSET (TAX (src)))); } else if ((IS (u, UNIT) && IS (SUB (u), ROUTINE_TEXT))) { NODE_T *src = SOURCE (&(GPROP (SUB (u)))); *(A68_PROCEDURE *) FRAME_OBJECT (OFFSET (TAX (_q_))) = *(A68_PROCEDURE *) (FRAME_OBJECT (OFFSET (TAX (src)))); } } } INITIALISE_FRAME (TABLE (p)) = (BOOL_T) (INITIALISE_ANON (TABLE (p)) || PROC_OPS (TABLE (p))); } /*! \brief whether item at "w" of mode "q" is initialised \param p position in tree \param w pointer to object \param q mode of object **/ void genie_check_initialisation (NODE_T * p, BYTE_T * w, MOID_T * q) { switch (SHORT_ID (q)) { case REF_SYMBOL: { A68_REF *z = (A68_REF *) w; CHECK_INIT (p, INITIALISED (z), q); return; } case PROC_SYMBOL: { A68_PROCEDURE *z = (A68_PROCEDURE *) w; CHECK_INIT (p, INITIALISED (z), q); return; } case MODE_INT: { A68_INT *z = (A68_INT *) w; CHECK_INIT (p, INITIALISED (z), q); return; } case MODE_REAL: { A68_REAL *z = (A68_REAL *) w; CHECK_INIT (p, INITIALISED (z), q); return; } case MODE_COMPLEX: { A68_REAL *r = (A68_REAL *) w; A68_REAL *i = (A68_REAL *) (w + ALIGNED_SIZE_OF (A68_REAL)); CHECK_INIT (p, INITIALISED (r), q); CHECK_INIT (p, INITIALISED (i), q); return; } case MODE_LONG_INT: case MODE_LONGLONG_INT: case MODE_LONG_REAL: case MODE_LONGLONG_REAL: case MODE_LONG_BITS: case MODE_LONGLONG_BITS: { MP_T *z = (MP_T *) w; CHECK_INIT (p, (unsigned) z[0] & INIT_MASK, q); return; } case MODE_LONG_COMPLEX: { MP_T *r = (MP_T *) w; MP_T *i = (MP_T *) (w + size_long_mp ()); CHECK_INIT (p, (unsigned) r[0] & INIT_MASK, q); CHECK_INIT (p, (unsigned) i[0] & INIT_MASK, q); return; } case MODE_LONGLONG_COMPLEX: { MP_T *r = (MP_T *) w; MP_T *i = (MP_T *) (w + size_longlong_mp ()); CHECK_INIT (p, (unsigned) r[0] & INIT_MASK, q); CHECK_INIT (p, (unsigned) i[0] & INIT_MASK, q); return; } case MODE_BOOL: { A68_BOOL *z = (A68_BOOL *) w; CHECK_INIT (p, INITIALISED (z), q); return; } case MODE_CHAR: { A68_CHAR *z = (A68_CHAR *) w; CHECK_INIT (p, INITIALISED (z), q); return; } case MODE_BITS: { A68_BITS *z = (A68_BITS *) w; CHECK_INIT (p, INITIALISED (z), q); return; } case MODE_BYTES: { A68_BYTES *z = (A68_BYTES *) w; CHECK_INIT (p, INITIALISED (z), q); return; } case MODE_LONG_BYTES: { A68_LONG_BYTES *z = (A68_LONG_BYTES *) w; CHECK_INIT (p, INITIALISED (z), q); return; } case MODE_FILE: { A68_FILE *z = (A68_FILE *) w; CHECK_INIT (p, INITIALISED (z), q); return; } case MODE_FORMAT: { A68_FORMAT *z = (A68_FORMAT *) w; CHECK_INIT (p, INITIALISED (z), q); return; } case MODE_PIPE: { A68_REF *pipe_read = (A68_REF *) w; A68_REF *pipe_write = (A68_REF *) (w + A68_REF_SIZE); A68_INT *pid = (A68_INT *) (w + 2 * A68_REF_SIZE); CHECK_INIT (p, INITIALISED (pipe_read), q); CHECK_INIT (p, INITIALISED (pipe_write), q); CHECK_INIT (p, INITIALISED (pid), q); return; } case MODE_SOUND: { A68_SOUND *z = (A68_SOUND *) w; CHECK_INIT (p, INITIALISED (z), q); return; } } } /*! \brief push constant stored in the tree \param p position in tree \return a propagator for this action **/ static PROP_T genie_constant (NODE_T * p) { PUSH (p, CONSTANT (GINFO (p)), SIZE (GINFO (p))); return (GPROP (p)); } /*! \brief unite value in the stack and push result \param p position in tree \return a propagator for this action **/ static PROP_T genie_uniting (NODE_T * p) { PROP_T self; ADDR_T sp = stack_pointer; MOID_T *u = MOID (p), *v = MOID (SUB (p)); int size = MOID_SIZE (u); if (ATTRIBUTE (v) != UNION_SYMBOL) { PUSH_UNION (p, (void *) unites_to (v, u)); EXECUTE_UNIT (SUB (p)); STACK_DNS (p, SUB (v), frame_pointer); } else { A68_UNION *m = (A68_UNION *) STACK_TOP; EXECUTE_UNIT (SUB (p)); STACK_DNS (p, SUB (v), frame_pointer); VALUE (m) = (void *) unites_to ((MOID_T *) VALUE (m), u); } stack_pointer = sp + size; UNIT (&self) = genie_uniting; SOURCE (&self) = p; return (self); } /*! \brief store widened constant as a constant \param p position in tree \param m mode of object \param self propagator to set **/ static void make_constant_widening (NODE_T * p, MOID_T * m, PROP_T * self) { if (SUB (p) != NO_NODE && CONSTANT (GINFO (SUB (p))) != NO_CONSTANT) { int size = MOID_SIZE (m); UNIT (self) = genie_constant; CONSTANT (GINFO (p)) = (void *) get_heap_space ((unsigned) size); SIZE (GINFO (p)) = size; COPY (CONSTANT (GINFO (p)), (void *) (STACK_OFFSET (-size)), size); } } /*! \brief (optimised) push INT widened to REAL \param p position in tree \return a propagator for this action **/ static PROP_T genie_widening_int_to_real (NODE_T * p) { A68_INT *i = (A68_INT *) STACK_TOP; A68_REAL *z = (A68_REAL *) STACK_TOP; EXECUTE_UNIT (SUB (p)); INCREMENT_STACK_POINTER (p, ALIGNED_SIZE_OF (A68_REAL) - ALIGNED_SIZE_OF (A68_INT)); VALUE (z) = (double) VALUE (i); STATUS (z) = INIT_MASK; return (GPROP (p)); } /*! \brief widen value in the stack \param p position in tree \return a propagator for this action **/ static PROP_T genie_widening (NODE_T * p) { #define COERCE_FROM_TO(p, a, b) (MOID (p) == (b) && MOID (SUB (p)) == (a)) PROP_T self; UNIT (&self) = genie_widening; SOURCE (&self) = p; /* INT widenings */ if (COERCE_FROM_TO (p, MODE (INT), MODE (REAL))) { (void) genie_widening_int_to_real (p); UNIT (&self) = genie_widening_int_to_real; make_constant_widening (p, MODE (REAL), &self); } else if (COERCE_FROM_TO (p, MODE (INT), MODE (LONG_INT))) { EXECUTE_UNIT (SUB (p)); genie_lengthen_int_to_long_mp (p); make_constant_widening (p, MODE (LONG_INT), &self); } else if (COERCE_FROM_TO (p, MODE (LONG_INT), MODE (LONGLONG_INT))) { EXECUTE_UNIT (SUB (p)); genie_lengthen_long_mp_to_longlong_mp (p); make_constant_widening (p, MODE (LONGLONG_INT), &self); } else if (COERCE_FROM_TO (p, MODE (LONG_INT), MODE (LONG_REAL))) { EXECUTE_UNIT (SUB (p)); /* 1-1 mapping */ make_constant_widening (p, MODE (LONG_REAL), &self); } else if (COERCE_FROM_TO (p, MODE (LONGLONG_INT), MODE (LONGLONG_REAL))) { EXECUTE_UNIT (SUB (p)); /* 1-1 mapping */ make_constant_widening (p, MODE (LONGLONG_REAL), &self); } /* REAL widenings */ else if (COERCE_FROM_TO (p, MODE (REAL), MODE (LONG_REAL))) { EXECUTE_UNIT (SUB (p)); genie_lengthen_real_to_long_mp (p); make_constant_widening (p, MODE (LONG_REAL), &self); } else if (COERCE_FROM_TO (p, MODE (LONG_REAL), MODE (LONGLONG_REAL))) { EXECUTE_UNIT (SUB (p)); genie_lengthen_long_mp_to_longlong_mp (p); make_constant_widening (p, MODE (LONGLONG_REAL), &self); } else if (COERCE_FROM_TO (p, MODE (REAL), MODE (COMPLEX))) { EXECUTE_UNIT (SUB (p)); PUSH_PRIMITIVE (p, 0.0, A68_REAL); make_constant_widening (p, MODE (COMPLEX), &self); } else if (COERCE_FROM_TO (p, MODE (LONG_REAL), MODE (LONG_COMPLEX))) { MP_T *z; int digits = get_mp_digits (MODE (LONG_REAL)); EXECUTE_UNIT (SUB (p)); STACK_MP (z, p, digits); SET_MP_ZERO (z, digits); z[0] = (MP_T) INIT_MASK; make_constant_widening (p, MODE (LONG_COMPLEX), &self); } else if (COERCE_FROM_TO (p, MODE (LONGLONG_REAL), MODE (LONGLONG_COMPLEX))) { MP_T *z; int digits = get_mp_digits (MODE (LONGLONG_REAL)); EXECUTE_UNIT (SUB (p)); STACK_MP (z, p, digits); SET_MP_ZERO (z, digits); z[0] = (MP_T) INIT_MASK; make_constant_widening (p, MODE (LONGLONG_COMPLEX), &self); } /* COMPLEX widenings */ else if (COERCE_FROM_TO (p, MODE (COMPLEX), MODE (LONG_COMPLEX))) { EXECUTE_UNIT (SUB (p)); genie_lengthen_complex_to_long_complex (p); make_constant_widening (p, MODE (LONG_COMPLEX), &self); } else if (COERCE_FROM_TO (p, MODE (LONG_COMPLEX), MODE (LONGLONG_COMPLEX))) { EXECUTE_UNIT (SUB (p)); genie_lengthen_long_complex_to_longlong_complex (p); make_constant_widening (p, MODE (LONGLONG_COMPLEX), &self); } /* BITS widenings */ else if (COERCE_FROM_TO (p, MODE (BITS), MODE (LONG_BITS))) { EXECUTE_UNIT (SUB (p)); /* Treat unsigned as int, but that's ok */ genie_lengthen_int_to_long_mp (p); make_constant_widening (p, MODE (LONG_BITS), &self); } else if (COERCE_FROM_TO (p, MODE (LONG_BITS), MODE (LONGLONG_BITS))) { EXECUTE_UNIT (SUB (p)); genie_lengthen_long_mp_to_longlong_mp (p); make_constant_widening (p, MODE (LONGLONG_BITS), &self); } /* Miscellaneous widenings */ else if (COERCE_FROM_TO (p, MODE (BYTES), MODE (ROW_CHAR))) { A68_BYTES z; EXECUTE_UNIT (SUB (p)); POP_OBJECT (p, &z, A68_BYTES); PUSH_REF (p, c_string_to_row_char (p, VALUE (&z), BYTES_WIDTH)); } else if (COERCE_FROM_TO (p, MODE (LONG_BYTES), MODE (ROW_CHAR))) { A68_LONG_BYTES z; EXECUTE_UNIT (SUB (p)); POP_OBJECT (p, &z, A68_LONG_BYTES); PUSH_REF (p, c_string_to_row_char (p, VALUE (&z), LONG_BYTES_WIDTH)); } else if (COERCE_FROM_TO (p, MODE (BITS), MODE (ROW_BOOL))) { A68_BITS x; A68_REF z, row; A68_ARRAY arr; A68_TUPLE tup; int k; unsigned bit; BYTE_T *base; EXECUTE_UNIT (SUB (p)); POP_OBJECT (p, &x, A68_BITS); z = heap_generator (p, MODE (ROW_BOOL), ALIGNED_SIZE_OF (A68_ARRAY) + ALIGNED_SIZE_OF (A68_TUPLE)); row = heap_generator (p, MODE (ROW_BOOL), BITS_WIDTH * MOID_SIZE (MODE (BOOL))); DIM (&arr) = 1; MOID (&arr) = MODE (BOOL); ELEM_SIZE (&arr) = MOID_SIZE (MODE (BOOL)); SLICE_OFFSET (&arr) = 0; FIELD_OFFSET (&arr) = 0; ARRAY (&arr) = row; LWB (&tup) = 1; UPB (&tup) = BITS_WIDTH; SHIFT (&tup) = LWB (&tup); SPAN (&tup) = 1; K (&tup) = 0; PUT_DESCRIPTOR (arr, tup, &z); base = ADDRESS (&row) + MOID_SIZE (MODE (BOOL)) * (BITS_WIDTH - 1); bit = 1; for (k = BITS_WIDTH - 1; k >= 0; k--, base -= MOID_SIZE (MODE (BOOL)), bit <<= 1) { STATUS ((A68_BOOL *) base) = INIT_MASK; VALUE ((A68_BOOL *) base) = (BOOL_T) ((VALUE (&x) & bit) != 0 ? A68_TRUE : A68_FALSE); } PUSH_REF (p, z); } else if (COERCE_FROM_TO (p, MODE (LONG_BITS), MODE (ROW_BOOL)) || COERCE_FROM_TO (p, MODE (LONGLONG_BITS), MODE (ROW_BOOL))) { MOID_T *m = MOID (SUB (p)); A68_REF z, row; A68_ARRAY arr; A68_TUPLE tup; int size = get_mp_size (m), k, width = get_mp_bits_width (m), words = get_mp_bits_words (m); unsigned *bits; BYTE_T *base; MP_T *x; ADDR_T pop_sp = stack_pointer; /* Calculate and convert BITS value */ EXECUTE_UNIT (SUB (p)); x = (MP_T *) STACK_OFFSET (-size); bits = stack_mp_bits (p, x, m); /* Make [] BOOL */ z = heap_generator (p, MODE (ROW_BOOL), ALIGNED_SIZE_OF (A68_ARRAY) + ALIGNED_SIZE_OF (A68_TUPLE)); row = heap_generator (p, MODE (ROW_BOOL), width * MOID_SIZE (MODE (BOOL))); DIM (&arr) = 1; MOID (&arr) = MODE (BOOL); ELEM_SIZE (&arr) = MOID_SIZE (MODE (BOOL)); SLICE_OFFSET (&arr) = 0; FIELD_OFFSET (&arr) = 0; ARRAY (&arr) = row; LWB (&tup) = 1; UPB (&tup) = width; SHIFT (&tup) = LWB (&tup); SPAN (&tup) = 1; K (&tup) = 0; PUT_DESCRIPTOR (arr, tup, &z); base = ADDRESS (&row) + (width - 1) * MOID_SIZE (MODE (BOOL)); k = width; while (k > 0) { unsigned bit = 0x1; int j; for (j = 0; j < MP_BITS_BITS && k >= 0; j++) { STATUS ((A68_BOOL *) base) = INIT_MASK; VALUE ((A68_BOOL *) base) = (BOOL_T) ((bits[words - 1] & bit) ? A68_TRUE : A68_FALSE); base -= MOID_SIZE (MODE (BOOL)); bit <<= 1; k--; } words--; } if (CONSTANT (GINFO (SUB (p))) != NO_CONSTANT) { UNIT (&self) = genie_constant; BLOCK_GC_HANDLE (&z); CONSTANT (GINFO (p)) = (void *) get_heap_space ((size_t) A68_REF_SIZE); SIZE (GINFO (p)) = A68_REF_SIZE; COPY (CONSTANT (GINFO (p)), &z, A68_REF_SIZE); } stack_pointer = pop_sp; PUSH_REF (p, z); } else { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_CANNOT_WIDEN, MOID (SUB (p)), MOID (p)); exit_genie (p, A68_RUNTIME_ERROR); } return (self); #undef COERCE_FROM_TO } /*! \brief cast a jump to a PROC VOID without executing the jump \param p position in tree **/ static void genie_proceduring (NODE_T * p) { A68_PROCEDURE z; NODE_T *jump = SUB (p); NODE_T *q = SUB (jump); NODE_T *label = (IS (q, GOTO_SYMBOL) ? NEXT (q) : q); STATUS (&z) = INIT_MASK; NODE (&(BODY (&z))) = jump; STATIC_LINK_FOR_FRAME (ENVIRON (&z), 1 + TAG_LEX_LEVEL (TAX (label))); LOCALE (&z) = NO_HANDLE; MOID (&z) = MODE (PROC_VOID); PUSH_PROCEDURE (p, z); } /*! \brief (optimised) dereference value of a unit \param p position in tree \return a propagator for this action **/ static PROP_T genie_dereferencing_quick (NODE_T * p) { A68_REF *z = (A68_REF *) STACK_TOP; ADDR_T pop_sp = stack_pointer; BYTE_T *stack_top = STACK_TOP; EXECUTE_UNIT (SUB (p)); stack_pointer = pop_sp; CHECK_REF (p, *z, MOID (SUB (p))); PUSH (p, ADDRESS (z), MOID_SIZE (MOID (p))); genie_check_initialisation (p, stack_top, MOID (p)); return (GPROP (p)); } /*! \brief dereference an identifier \param p position in tree \return a propagator for this action **/ static PROP_T genie_dereference_frame_identifier (NODE_T * p) { A68_REF *z; MOID_T *deref = SUB_MOID (p); BYTE_T *stack_top = STACK_TOP; FRAME_GET (z, A68_REF, p); PUSH (p, ADDRESS (z), MOID_SIZE (deref)); genie_check_initialisation (p, stack_top, deref); return (GPROP (p)); } /*! \brief dereference an identifier \param p position in tree \return a propagator for this action **/ static PROP_T genie_dereference_generic_identifier (NODE_T * p) { A68_REF *z; MOID_T *deref = SUB_MOID (p); BYTE_T *stack_top = STACK_TOP; FRAME_GET (z, A68_REF, p); CHECK_REF (p, *z, MOID (SUB (p))); PUSH (p, ADDRESS (z), MOID_SIZE (deref)); genie_check_initialisation (p, stack_top, deref); return (GPROP (p)); } /*! \brief slice REF [] A to A \param p position in tree \return a propagator for this action **/ static PROP_T genie_dereference_slice_name_quick (NODE_T * p) { NODE_T *q, *prim = SUB (p); A68_ARRAY *a; A68_TUPLE *t; A68_REF *z; MOID_T *ref_mode = MOID (p); MOID_T *deref_mode = SUB (ref_mode); int size = MOID_SIZE (deref_mode), row_index; ADDR_T pop_sp = stack_pointer; BYTE_T *stack_top = STACK_TOP; /* Get REF [] */ z = (A68_REF *) STACK_TOP; EXECUTE_UNIT (prim); stack_pointer = pop_sp; CHECK_REF (p, *z, ref_mode); GET_DESCRIPTOR (a, t, DEREF (A68_ROW, z)); for (row_index = 0, q = SEQUENCE (p); q != NO_NODE; t++, q = SEQUENCE (q)) { A68_INT *j = (A68_INT *) STACK_TOP; int k; EXECUTE_UNIT (q); k = VALUE (j); if (k < LWB (t) || k > UPB (t)) { diagnostic_node (A68_RUNTIME_ERROR, q, ERROR_INDEX_OUT_OF_BOUNDS); exit_genie (q, A68_RUNTIME_ERROR); } row_index += (SPAN (t) * k - SHIFT (t)); stack_pointer = pop_sp; } /* Push element */ PUSH (p, &((ADDRESS (&(ARRAY (a))))[ROW_ELEMENT (a, row_index)]), size); genie_check_initialisation (p, stack_top, deref_mode); return (GPROP (p)); } /*! \brief dereference SELECTION from a name \param p position in tree \return a propagator for this action **/ static PROP_T genie_dereference_selection_name_quick (NODE_T * p) { NODE_T *selector = SUB (p); MOID_T *struct_mode = MOID (NEXT (selector)); MOID_T *result_mode = SUB_MOID (selector); int size = MOID_SIZE (result_mode); A68_REF *z = (A68_REF *) STACK_TOP; ADDR_T pop_sp = stack_pointer; BYTE_T *stack_top; EXECUTE_UNIT (NEXT (selector)); CHECK_REF (selector, *z, struct_mode); OFFSET (z) += OFFSET (NODE_PACK (SUB (selector))); stack_pointer = pop_sp; stack_top = STACK_TOP; PUSH (p, ADDRESS (z), size); genie_check_initialisation (p, stack_top, result_mode); return (GPROP (p)); } /*! \brief dereference name in the stack \param p position in tree \return a propagator for this action **/ static PROP_T genie_dereferencing (NODE_T * p) { A68_REF z; PROP_T self; EXECUTE_UNIT_2 (SUB (p), self); POP_REF (p, &z); CHECK_REF (p, z, MOID (SUB (p))); PUSH (p, ADDRESS (&z), MOID_SIZE (MOID (p))); genie_check_initialisation (p, STACK_OFFSET (-MOID_SIZE (MOID (p))), MOID (p)); if (UNIT (&self) == genie_frame_identifier) { if (IS_IN_FRAME (&z)) { UNIT (&self) = genie_dereference_frame_identifier; } else { UNIT (&self) = genie_dereference_generic_identifier; } UNIT (&PROP (GINFO (SOURCE (&self)))) = UNIT (&self); } else if (UNIT (&self) == genie_slice_name_quick) { UNIT (&self) = genie_dereference_slice_name_quick; UNIT (&PROP (GINFO (SOURCE (&self)))) = UNIT (&self); } else if (UNIT (&self) == genie_selection_name_quick) { UNIT (&self) = genie_dereference_selection_name_quick; UNIT (&PROP (GINFO (SOURCE (&self)))) = UNIT (&self); } else { UNIT (&self) = genie_dereferencing_quick; SOURCE (&self) = p; } return (self); } /*! \brief deprocedure PROC in the stack \param p position in tree \return a propagator for this action **/ static PROP_T genie_deproceduring (NODE_T * p) { PROP_T self; A68_PROCEDURE *z; ADDR_T pop_sp = stack_pointer, pop_fp = frame_pointer; NODE_T *proc = SUB (p); MOID_T *proc_mode = MOID (proc); UNIT (&self) = genie_deproceduring; SOURCE (&self) = p; /* Get procedure */ z = (A68_PROCEDURE *) STACK_TOP; EXECUTE_UNIT (proc); stack_pointer = pop_sp; genie_check_initialisation (p, (BYTE_T *) z, proc_mode); genie_call_procedure (p, proc_mode, proc_mode, MODE (VOID), z, pop_sp, pop_fp); STACK_DNS (p, MOID (p), frame_pointer); return (self); } /*! \brief voiden value in the stack \param p position in tree \return a propagator for this action **/ static PROP_T genie_voiding (NODE_T * p) { PROP_T self, source; ADDR_T sp_for_voiding = stack_pointer; SOURCE (&self) = p; EXECUTE_UNIT_2 (SUB (p), source); stack_pointer = sp_for_voiding; if (UNIT (&source) == genie_assignation_quick) { UNIT (&self) = genie_voiding_assignation; SOURCE (&self) = SOURCE (&source); } else if (UNIT (&source) == genie_assignation_constant) { UNIT (&self) = genie_voiding_assignation_constant; SOURCE (&self) = SOURCE (&source); } else { UNIT (&self) = genie_voiding; } return (self); } /*! \brief coerce value in the stack \param p position in tree \return a propagator for this action **/ static PROP_T genie_coercion (NODE_T * p) { PROP_T self; UNIT (&self) = genie_coercion; SOURCE (&self) = p; switch (ATTRIBUTE (p)) { case VOIDING: { self = genie_voiding (p); break; } case UNITING: { self = genie_uniting (p); break; } case WIDENING: { self = genie_widening (p); break; } case ROWING: { self = genie_rowing (p); break; } case DEREFERENCING: { self = genie_dereferencing (p); break; } case DEPROCEDURING: { self = genie_deproceduring (p); break; } case PROCEDURING: { genie_proceduring (p); break; } } GPROP (p) = self; return (self); } /*! \brief push argument units \param p position in tree \param seq chain to link nodes into **/ static void genie_argument (NODE_T * p, NODE_T ** seq) { for (; p != NO_NODE; FORWARD (p)) { if (IS (p, UNIT)) { EXECUTE_UNIT (p); STACK_DNS (p, MOID (p), frame_pointer); SEQUENCE (*seq) = p; (*seq) = p; return; } else if (IS (p, TRIMMER)) { return; } else { genie_argument (SUB (p), seq); } } } /*! \brief evaluate partial call \param p position in tree \param pr_mode full mode of procedure object \param pproc mode of resulting proc \param pmap mode of the locale \param z procedure object to call \param pop_sp stack pointer value to restore \param pop_fp frame pointer value to restore **/ void genie_partial_call (NODE_T * p, MOID_T * pr_mode, MOID_T * pproc, MOID_T * pmap, A68_PROCEDURE z, ADDR_T pop_sp, ADDR_T pop_fp) { int voids = 0; BYTE_T *u, *v; PACK_T *s, *t; A68_REF ref; A68_HANDLE *loc; /* Get locale for the new procedure descriptor. Copy is necessary */ if (LOCALE (&z) == NO_HANDLE) { int size = 0; for (s = PACK (pr_mode); s != NO_PACK; FORWARD (s)) { size += (ALIGNED_SIZE_OF (A68_BOOL) + MOID_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[ALIGNED_SIZE_OF (A68_BOOL) + MOID_SIZE (MOID (s))]); FORWARD (s); } if (u != NULL && MOID (t) == MODE (VOID)) { /* Move to next field in locale */ voids++; u = &(u[ALIGNED_SIZE_OF (A68_BOOL) + MOID_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[ALIGNED_SIZE_OF (A68_BOOL)]), v, MOID_SIZE (MOID (t))); u = &(u[ALIGNED_SIZE_OF (A68_BOOL) + MOID_SIZE (MOID (s))]); v = &(v[MOID_SIZE (MOID (t))]); FORWARD (s); } } stack_pointer = pop_sp; LOCALE (&z) = loc; /* Is closure complete? */ if (voids == 0) { /* Closure is complete. Push locale onto the stack and call procedure body */ stack_pointer = pop_sp; u = POINTER (loc); v = STACK_ADDRESS (stack_pointer); s = PACK (pr_mode); for (; s != NO_PACK; FORWARD (s)) { int size = MOID_SIZE (MOID (s)); COPY (v, &u[ALIGNED_SIZE_OF (A68_BOOL)], size); u = &(u[ALIGNED_SIZE_OF (A68_BOOL) + size]); v = &(v[MOID_SIZE (MOID (s))]); INCREMENT_STACK_POINTER (p, size); } genie_call_procedure (p, pr_mode, pproc, MODE (VOID), &z, pop_sp, pop_fp); } else { /* Closure is not complete. Return procedure body */ PUSH_PROCEDURE (p, z); } } /*! \brief closure and deproceduring of routines with PARAMSETY \param p position in tree \param pr_mode full mode of procedure object \param pproc mode of resulting proc \param pmap mode of the locale \param z procedure object to call \param pop_sp stack pointer value to restore \param pop_fp frame pointer value to restore **/ void genie_call_procedure (NODE_T * p, MOID_T * pr_mode, MOID_T * pproc, MOID_T * pmap, A68_PROCEDURE * z, ADDR_T pop_sp, ADDR_T pop_fp) { if (pmap != MODE (VOID) && pr_mode != pmap) { genie_partial_call (p, pr_mode, pproc, pmap, *z, pop_sp, pop_fp); } else if (STATUS (z) & STANDENV_PROC_MASK) { (void) ((*(PROCEDURE (&(BODY (z))))) (p)); } else if (STATUS (z) & SKIP_PROCEDURE_MASK) { stack_pointer = pop_sp; genie_push_undefined (p, SUB ((MOID (z)))); } else { NODE_T *body = NODE (&(BODY (z))); if (IS (body, ROUTINE_TEXT)) { NODE_T *entry = SUB (body); PACK_T *args = PACK (pr_mode); ADDR_T fp0 = 0; /* Copy arguments from stack to frame */ OPEN_PROC_FRAME (entry, ENVIRON (z)); INIT_STATIC_FRAME (entry); FRAME_DNS (frame_pointer) = pop_fp; for (; args != NO_PACK; FORWARD (args)) { int size = MOID_SIZE (MOID (args)); COPY ((FRAME_OBJECT (fp0)), STACK_ADDRESS (pop_sp + fp0), size); fp0 += size; } stack_pointer = pop_sp; ARGSIZE (GINFO (p)) = fp0; /* Interpret routine text */ if (DIM (pr_mode) > 0) { /* With PARAMETERS */ entry = NEXT (NEXT_NEXT (entry)); } else { /* Without PARAMETERS */ entry = NEXT_NEXT (entry); } EXECUTE_UNIT_TRACE (entry); if (frame_pointer == finish_frame_pointer) { change_masks (TOP_NODE (&program), BREAKPOINT_INTERRUPT_MASK, A68_TRUE); } CLOSE_FRAME; STACK_DNS (p, SUB (pr_mode), frame_pointer); } else { OPEN_PROC_FRAME (body, ENVIRON (z)); INIT_STATIC_FRAME (body); FRAME_DNS (frame_pointer) = pop_fp; EXECUTE_UNIT_TRACE (body); if (frame_pointer == finish_frame_pointer) { change_masks (TOP_NODE (&program), BREAKPOINT_INTERRUPT_MASK, A68_TRUE); } CLOSE_FRAME; STACK_DNS (p, SUB (pr_mode), frame_pointer); } } } /*! \brief call event routine \param p position in tree \return a propagator for this action **/ void genie_call_event_routine (NODE_T *p, MOID_T *m, A68_PROCEDURE *proc, ADDR_T pop_sp, ADDR_T pop_fp) { if (NODE (&(BODY (proc))) != NO_NODE) { A68_PROCEDURE save = *proc; set_default_event_procedure (proc); genie_call_procedure (p, MOID (&save), m, m, &save, pop_sp, pop_fp); (*proc) = save; } } /*! \brief call PROC with arguments and push result \param p position in tree \return a propagator for this action **/ static PROP_T genie_call_standenv_quick (NODE_T * p) { NODE_T *pr = SUB (p), *q = SEQUENCE (p); TAG_T *proc = TAX (SOURCE (&GPROP (pr))); /* Get arguments */ for (; q != NO_NODE; q = SEQUENCE (q)) { EXECUTE_UNIT (q); STACK_DNS (p, MOID (q), frame_pointer); } (void) ((*(PROCEDURE (proc))) (p)); return (GPROP (p)); } /*! \brief call PROC with arguments and push result \param p position in tree \return a propagator for this action **/ static PROP_T genie_call_quick (NODE_T * p) { A68_PROCEDURE z; NODE_T *proc = SUB (p); ADDR_T pop_sp = stack_pointer, pop_fp = frame_pointer; /* Get procedure */ EXECUTE_UNIT (proc); POP_OBJECT (proc, &z, A68_PROCEDURE); genie_check_initialisation (p, (BYTE_T *) &z, MOID (proc)); /* Get arguments */ if (SEQUENCE (p) == NO_NODE && ! STATUS_TEST (p, SEQUENCE_MASK)) { NODE_T top_seq; NODE_T *seq = &top_seq; GINFO_T g; GINFO (&top_seq) = &g; genie_argument (NEXT (proc), &seq); SEQUENCE (p) = SEQUENCE (&top_seq); STATUS_SET (p, SEQUENCE_MASK); } else { NODE_T *q = SEQUENCE (p); for (; q != NO_NODE; q = SEQUENCE (q)) { EXECUTE_UNIT (q); STACK_DNS (p, MOID (q), frame_pointer); } } genie_call_procedure (p, MOID (&z), PARTIAL_PROC (GINFO (proc)), PARTIAL_LOCALE (GINFO (proc)), &z, pop_sp, pop_fp); return (GPROP (p)); } /*! \brief call PROC with arguments and push result \param p position in tree \return a propagator for this action **/ static PROP_T genie_call (NODE_T * p) { PROP_T self; A68_PROCEDURE z; NODE_T *proc = SUB (p); ADDR_T pop_sp = stack_pointer, pop_fp = frame_pointer; UNIT (&self) = genie_call_quick; SOURCE (&self) = p; /* Get procedure */ EXECUTE_UNIT (proc); POP_OBJECT (proc, &z, A68_PROCEDURE); genie_check_initialisation (p, (BYTE_T *) &z, MOID (proc)); /* Get arguments */ if (SEQUENCE (p) == NO_NODE && ! STATUS_TEST (p, SEQUENCE_MASK)) { NODE_T top_seq; NODE_T *seq = &top_seq; GINFO_T g; GINFO (&top_seq) = &g; genie_argument (NEXT (proc), &seq); SEQUENCE (p) = SEQUENCE (&top_seq); STATUS_SET (p, SEQUENCE_MASK); } else { NODE_T *q = SEQUENCE (p); for (; q != NO_NODE; q = SEQUENCE (q)) { EXECUTE_UNIT (q); } } genie_call_procedure (p, MOID (&z), PARTIAL_PROC (GINFO (proc)), PARTIAL_LOCALE (GINFO (proc)), &z, pop_sp, pop_fp); if (PARTIAL_LOCALE (GINFO (proc)) != MODE (VOID) && MOID (&z) != PARTIAL_LOCALE (GINFO (proc))) { /* skip */ ; } else if (STATUS (&z) & STANDENV_PROC_MASK) { if (UNIT (&GPROP (proc)) == genie_identifier_standenv_proc) { UNIT (&self) = genie_call_standenv_quick; } } return (self); } /*! \brief construct a descriptor "ref_new" for a trim of "ref_old" \param p position in tree \param ref_new new descriptor \param ref_old old descriptor \param offset calculates the offset of the trim **/ static void genie_trimmer (NODE_T * p, BYTE_T * *ref_new, BYTE_T * *ref_old, int *offset) { if (p != NO_NODE) { if (IS (p, UNIT)) { A68_INT k; A68_TUPLE *t; EXECUTE_UNIT (p); POP_OBJECT (p, &k, A68_INT); t = (A68_TUPLE *) * ref_old; CHECK_INDEX (p, &k, t); (*offset) += SPAN (t) * VALUE (&k) - SHIFT (t); /* * (*ref_old) += ALIGNED_SIZE_OF (A68_TUPLE); */ (*ref_old) += sizeof (A68_TUPLE); } else if (IS (p, TRIMMER)) { A68_INT k; NODE_T *q; int L, U, D; A68_TUPLE *old_tup = (A68_TUPLE *) * ref_old; A68_TUPLE *new_tup = (A68_TUPLE *) * ref_new; /* TRIMMER is (l:u@r) with all units optional or (empty) */ q = SUB (p); if (q == NO_NODE) { L = LWB (old_tup); U = UPB (old_tup); D = 0; } else { BOOL_T absent = A68_TRUE; /* Lower index */ if (q != NO_NODE && IS (q, UNIT)) { EXECUTE_UNIT (q); POP_OBJECT (p, &k, A68_INT); if (VALUE (&k) < LWB (old_tup)) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_INDEX_OUT_OF_BOUNDS); exit_genie (p, A68_RUNTIME_ERROR); } L = VALUE (&k); FORWARD (q); absent = A68_FALSE; } else { L = LWB (old_tup); } if (q != NO_NODE && (IS (q, COLON_SYMBOL) || IS (q, DOTDOT_SYMBOL))) { FORWARD (q); absent = A68_FALSE; } /* Upper index */ if (q != NO_NODE && IS (q, UNIT)) { EXECUTE_UNIT (q); POP_OBJECT (p, &k, A68_INT); if (VALUE (&k) > UPB (old_tup)) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_INDEX_OUT_OF_BOUNDS); exit_genie (p, A68_RUNTIME_ERROR); } U = VALUE (&k); FORWARD (q); absent = A68_FALSE; } else { U = UPB (old_tup); } if (q != NO_NODE && IS (q, AT_SYMBOL)) { FORWARD (q); } /* Revised lower bound */ if (q != NO_NODE && IS (q, UNIT)) { EXECUTE_UNIT (q); POP_OBJECT (p, &k, A68_INT); D = L - VALUE (&k); FORWARD (q); } else { D = (absent ? 0 : L - 1); } } LWB (new_tup) = L - D; UPB (new_tup) = U - D; /* (L - D) + (U - L) */ SPAN (new_tup) = SPAN (old_tup); SHIFT (new_tup) = SHIFT (old_tup) - D * SPAN (new_tup); (*ref_old) += sizeof (A68_TUPLE); (*ref_new) += sizeof (A68_TUPLE); } else { genie_trimmer (SUB (p), ref_new, ref_old, offset); genie_trimmer (NEXT (p), ref_new, ref_old, offset); } } } /*! \brief calculation of subscript \param p position in tree \param ref_heap \param sum calculates the index of the subscript \param seq chain to link nodes into **/ void genie_subscript (NODE_T * p, A68_TUPLE ** tup, int *sum, NODE_T ** seq) { for (; p != NO_NODE; FORWARD (p)) { switch (ATTRIBUTE (p)) { case UNIT: { A68_INT *k; A68_TUPLE *t = *tup; EXECUTE_UNIT (p); POP_ADDRESS (p, k, A68_INT); CHECK_INDEX (p, k, t); (*tup)++; (*sum) += (SPAN (t) * VALUE (k) - SHIFT (t)); SEQUENCE (*seq) = p; (*seq) = p; return; } case GENERIC_ARGUMENT: case GENERIC_ARGUMENT_LIST: { genie_subscript (SUB (p), tup, sum, seq); } } } } /*! \brief slice REF [] A to REF A \param p position in tree \return a propagator for this action **/ static PROP_T genie_slice_name_quick (NODE_T * p) { NODE_T *q, *pr = SUB (p); A68_REF *z = (A68_REF *) STACK_TOP; A68_ARRAY *a; ADDR_T pop_sp, scope; A68_TUPLE *t; int sindex; /* Get row and save row from garbage collector */ EXECUTE_UNIT (pr); CHECK_REF (p, *z, MOID (SUB (p))); GET_DESCRIPTOR (a, t, DEREF (A68_ROW, z)); pop_sp = stack_pointer; for (sindex = 0, q = SEQUENCE (p); q != NO_NODE; t++, q = SEQUENCE (q)) { A68_INT *j = (A68_INT *) STACK_TOP; int k; EXECUTE_UNIT (q); k = VALUE (j); if (k < LWB (t) || k > UPB (t)) { diagnostic_node (A68_RUNTIME_ERROR, q, ERROR_INDEX_OUT_OF_BOUNDS); exit_genie (q, A68_RUNTIME_ERROR); } sindex += (SPAN (t) * k - SHIFT (t)); stack_pointer = pop_sp; } /* Leave reference to element on the stack, preserving scope */ scope = REF_SCOPE (z); *z = ARRAY (a); OFFSET (z) += ROW_ELEMENT (a, sindex); REF_SCOPE (z) = scope; return (GPROP (p)); } /*! \brief push slice of a rowed object \param p position in tree \return a propagator for this action **/ static PROP_T genie_slice (NODE_T * p) { PROP_T self, primary; ADDR_T pop_sp, scope = PRIMAL_SCOPE; BOOL_T slice_of_name = (BOOL_T) (IS (MOID (SUB (p)), REF_SYMBOL)); MOID_T *result_mode = slice_of_name ? SUB_MOID (p) : MOID (p); NODE_T *indexer = NEXT_SUB (p); UNIT (&self) = genie_slice; SOURCE (&self) = p; pop_sp = stack_pointer; /* Get row */ EXECUTE_UNIT_2 (SUB (p), primary); /* In case of slicing a REF [], we need the [] internally, so dereference */ if (slice_of_name) { A68_REF z; POP_REF (p, &z); CHECK_REF (p, z, MOID (SUB (p))); scope = REF_SCOPE (&z); PUSH_REF (p, * DEREF (A68_REF, &z)); } if (ANNOTATION (indexer) == SLICE) { /* SLICING subscripts one element from an array */ A68_REF z; A68_ARRAY *a; A68_TUPLE *t; int sindex; POP_REF (p, &z); CHECK_REF (p, z, MOID (SUB (p))); GET_DESCRIPTOR (a, t, &z); if (SEQUENCE (p) == NO_NODE && ! STATUS_TEST (p, SEQUENCE_MASK)) { NODE_T top_seq; NODE_T *seq = &top_seq; GINFO_T g; GINFO (&top_seq) = &g; sindex = 0; genie_subscript (indexer, &t, &sindex, &seq); SEQUENCE (p) = SEQUENCE (&top_seq); STATUS_SET (p, SEQUENCE_MASK); } else { NODE_T *q; for (sindex = 0, q = SEQUENCE (p); q != NO_NODE; t++, q = SEQUENCE (q)) { A68_INT *j = (A68_INT *) STACK_TOP; int k; EXECUTE_UNIT (q); k = VALUE (j); if (k < LWB (t) || k > UPB (t)) { diagnostic_node (A68_RUNTIME_ERROR, q, ERROR_INDEX_OUT_OF_BOUNDS); exit_genie (q, A68_RUNTIME_ERROR); } sindex += (SPAN (t) * k - SHIFT (t)); } } /* Slice of a name yields a name */ stack_pointer = pop_sp; if (slice_of_name) { A68_REF name = ARRAY (a); OFFSET (&name) += ROW_ELEMENT (a, sindex); REF_SCOPE (&name) = scope; PUSH_REF (p, name); if (STATUS_TEST (p, SEQUENCE_MASK)) { UNIT (&self) = genie_slice_name_quick; SOURCE (&self) = p; } } else { BYTE_T *stack_top = STACK_TOP; PUSH (p, &((ADDRESS (&(ARRAY (a))))[ROW_ELEMENT (a, sindex)]), MOID_SIZE (result_mode)); genie_check_initialisation (p, stack_top, result_mode); } return (self); } else if (ANNOTATION (indexer) == TRIMMER) { /* Trimming selects a subarray from an array */ int offset; A68_REF z, ref_desc_copy; A68_ARRAY *old_des, *new_des; BYTE_T *ref_new, *ref_old; ref_desc_copy = heap_generator (p, MOID (p), ALIGNED_SIZE_OF (A68_ARRAY) + DIM (DEFLEX (result_mode)) * ALIGNED_SIZE_OF (A68_TUPLE)); /* Get descriptor */ POP_REF (p, &z); /* Get indexer */ CHECK_REF (p, z, MOID (SUB (p))); old_des = DEREF (A68_ARRAY, &z); new_des = DEREF (A68_ARRAY, &ref_desc_copy); ref_old = ADDRESS (&z) + ALIGNED_SIZE_OF (A68_ARRAY); ref_new = ADDRESS (&ref_desc_copy) + ALIGNED_SIZE_OF (A68_ARRAY); DIM (new_des) = DIM (DEFLEX (result_mode)); MOID (new_des) = MOID (old_des); ELEM_SIZE (new_des) = ELEM_SIZE (old_des); offset = SLICE_OFFSET (old_des); genie_trimmer (indexer, &ref_new, &ref_old, &offset); SLICE_OFFSET (new_des) = offset; FIELD_OFFSET (new_des) = FIELD_OFFSET (old_des); ARRAY (new_des) = ARRAY (old_des); /* Trim of a name is a name */ if (slice_of_name) { A68_REF ref_new2 = heap_generator (p, MOID (p), A68_REF_SIZE); * DEREF (A68_REF, &ref_new2) = ref_desc_copy; REF_SCOPE (&ref_new2) = scope; PUSH_REF (p, ref_new2); } else { PUSH_REF (p, ref_desc_copy); } return (self); } else { ABEND (A68_TRUE, "impossible state in genie_slice", NO_TEXT); return (self); } } /*! \brief push value of denotation \param p position in tree \return a propagator for this action **/ static PROP_T genie_denotation (NODE_T * p) { MOID_T *moid = MOID (p); PROP_T self; UNIT (&self) = genie_denotation; SOURCE (&self) = p; if (moid == MODE (INT)) { /* INT denotation */ A68_INT z; NODE_T *s = IS (SUB (p), SHORTETY) ? NEXT_SUB (p) : SUB (p); if (genie_string_to_value_internal (p, moid, NSYMBOL (s), (BYTE_T *) & z) == A68_FALSE) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_IN_DENOTATION, moid); exit_genie (p, A68_RUNTIME_ERROR); } UNIT (&self) = genie_constant; STATUS (&z) = INIT_MASK; CONSTANT (GINFO (p)) = (void *) get_heap_space ((size_t) ALIGNED_SIZE_OF (A68_INT)); SIZE (GINFO (p)) = ALIGNED_SIZE_OF (A68_INT); COPY (CONSTANT (GINFO (p)), &z, ALIGNED_SIZE_OF (A68_INT)); PUSH_PRIMITIVE (p, VALUE ((A68_INT *) (CONSTANT (GINFO (p)))), A68_INT); } else if (moid == MODE (REAL)) { /* REAL denotation */ A68_REAL z; NODE_T *s = IS (SUB (p), SHORTETY) ? NEXT_SUB (p) : SUB (p); if (genie_string_to_value_internal (p, moid, NSYMBOL (s), (BYTE_T *) & z) == A68_FALSE) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_IN_DENOTATION, moid); exit_genie (p, A68_RUNTIME_ERROR); } STATUS (&z) = INIT_MASK; UNIT (&self) = genie_constant; CONSTANT (GINFO (p)) = (void *) get_heap_space ((size_t) ALIGNED_SIZE_OF (A68_REAL)); SIZE (GINFO (p)) = ALIGNED_SIZE_OF (A68_REAL); COPY (CONSTANT (GINFO (p)), &z, ALIGNED_SIZE_OF (A68_REAL)); PUSH_PRIMITIVE (p, VALUE ((A68_REAL *) (CONSTANT (GINFO (p)))), A68_REAL); } else if (moid == MODE (LONG_INT) || moid == MODE (LONGLONG_INT)) { /* [LONG] LONG INT denotation */ int digits = get_mp_digits (moid); MP_T *z; int size = get_mp_size (moid); NODE_T *number; if (IS (SUB (p), SHORTETY) || IS (SUB (p), LONGETY)) { number = NEXT_SUB (p); } else { number = SUB (p); } STACK_MP (z, p, digits); if (genie_string_to_value_internal (p, moid, NSYMBOL (number), (BYTE_T *) z) == A68_FALSE) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_IN_DENOTATION, moid); exit_genie (p, A68_RUNTIME_ERROR); } z[0] = (MP_T) INIT_MASK; UNIT (&self) = genie_constant; CONSTANT (GINFO (p)) = (void *) get_heap_space ((size_t) size); SIZE (GINFO (p)) = size; COPY (CONSTANT (GINFO (p)), z, size); } else if (moid == MODE (LONG_REAL) || moid == MODE (LONGLONG_REAL)) { /* [LONG] LONG REAL denotation */ int digits = get_mp_digits (moid); MP_T *z; int size = get_mp_size (moid); NODE_T *number; if (IS (SUB (p), SHORTETY) || IS (SUB (p), LONGETY)) { number = NEXT_SUB (p); } else { number = SUB (p); } STACK_MP (z, p, digits); if (genie_string_to_value_internal (p, moid, NSYMBOL (number), (BYTE_T *) z) == A68_FALSE) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_IN_DENOTATION, moid); exit_genie (p, A68_RUNTIME_ERROR); } z[0] = (MP_T) INIT_MASK; UNIT (&self) = genie_constant; CONSTANT (GINFO (p)) = (void *) get_heap_space ((size_t) size); SIZE (GINFO (p)) = size; COPY (CONSTANT (GINFO (p)), z, size); } else if (moid == MODE (BITS)) { /* BITS denotation */ A68_BITS z; NODE_T *s = IS (SUB (p), SHORTETY) ? NEXT_SUB (p) : SUB (p); if (genie_string_to_value_internal (p, moid, NSYMBOL (s), (BYTE_T *) & z) == A68_FALSE) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_IN_DENOTATION, moid); exit_genie (p, A68_RUNTIME_ERROR); } UNIT (&self) = genie_constant; STATUS (&z) = INIT_MASK; CONSTANT (GINFO (p)) = (void *) get_heap_space ((size_t) ALIGNED_SIZE_OF (A68_BITS)); SIZE (GINFO (p)) = ALIGNED_SIZE_OF (A68_BITS); COPY (CONSTANT (GINFO (p)), &z, ALIGNED_SIZE_OF (A68_BITS)); PUSH_PRIMITIVE (p, VALUE ((A68_BITS *) (CONSTANT (GINFO (p)))), A68_BITS); } else if (moid == MODE (LONG_BITS) || moid == MODE (LONGLONG_BITS)) { /* [LONG] LONG BITS denotation */ int digits = get_mp_digits (moid); MP_T *z; int size = get_mp_size (moid); NODE_T *number; if (IS (SUB (p), SHORTETY) || IS (SUB (p), LONGETY)) { number = NEXT_SUB (p); } else { number = SUB (p); } STACK_MP (z, p, digits); if (genie_string_to_value_internal (p, moid, NSYMBOL (number), (BYTE_T *) z) == A68_FALSE) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_IN_DENOTATION, moid); exit_genie (p, A68_RUNTIME_ERROR); } z[0] = (MP_T) INIT_MASK; UNIT (&self) = genie_constant; CONSTANT (GINFO (p)) = (void *) get_heap_space ((size_t) size); SIZE (GINFO (p)) = size; COPY (CONSTANT (GINFO (p)), z, size); } else if (moid == MODE (BOOL)) { /* BOOL denotation */ A68_BOOL z; ASSERT (genie_string_to_value_internal (p, MODE (BOOL), NSYMBOL (p), (BYTE_T *) & z) == A68_TRUE); PUSH_PRIMITIVE (p, VALUE (&z), A68_BOOL); } else if (moid == MODE (CHAR)) { /* CHAR denotation */ PUSH_PRIMITIVE (p, TO_UCHAR (NSYMBOL (p)[0]), A68_CHAR); } else if (moid == MODE (ROW_CHAR)) { /* [] CHAR denotation - permanent string in the heap */ A68_REF z; A68_ARRAY *arr; A68_TUPLE *tup; z = c_to_a_string (p, NSYMBOL (p), DEFAULT_WIDTH); GET_DESCRIPTOR (arr, tup, &z); BLOCK_GC_HANDLE (&z); BLOCK_GC_HANDLE (&(ARRAY (arr))); UNIT (&self) = genie_constant; CONSTANT (GINFO (p)) = (void *) get_heap_space ((size_t) A68_REF_SIZE); SIZE (GINFO (p)) = A68_REF_SIZE; COPY (CONSTANT (GINFO (p)), &z, A68_REF_SIZE); PUSH_REF (p, *(A68_REF *) (CONSTANT (GINFO (p)))); } else if (moid == MODE (VOID)) { /* VOID denotation: EMPTY */ ; } return (self); } /*! \brief push a local identifier \param p position in tree \return a propagator for this action **/ static PROP_T genie_frame_identifier (NODE_T * p) { BYTE_T *z; FRAME_GET (z, BYTE_T, p); PUSH (p, z, MOID_SIZE (MOID (p))); return (GPROP (p)); } /*! \brief push standard environ routine as PROC \param p position in tree \return a propagator for this action **/ static PROP_T genie_identifier_standenv_proc (NODE_T * p) { A68_PROCEDURE z; TAG_T *q = TAX (p); STATUS (&z) = (STATUS_MASK) (INIT_MASK | STANDENV_PROC_MASK); PROCEDURE (&(BODY (&z))) = PROCEDURE (q); ENVIRON (&z) = 0; LOCALE (&z) = NO_HANDLE; MOID (&z) = MOID (p); PUSH_PROCEDURE (p, z); return (GPROP (p)); } /*! \brief (optimised) push identifier from standard environ \param p position in tree \return a propagator for this action **/ static PROP_T genie_identifier_standenv (NODE_T * p) { (void) ((*(PROCEDURE (TAX (p)))) (p)); return (GPROP (p)); } /*! \brief push identifier onto the stack \param p position in tree \return a propagator for this action **/ static PROP_T genie_identifier (NODE_T * p) { static PROP_T self; TAG_T *q = TAX (p); SOURCE (&self) = p; if (A68G_STANDENV_PROC (q)) { if (IS (MOID (q), PROC_SYMBOL)) { (void) genie_identifier_standenv_proc (p); UNIT (&self) = genie_identifier_standenv_proc; } else { (void) genie_identifier_standenv (p); UNIT (&self) = genie_identifier_standenv; } } else if (STATUS_TEST (q, CONSTANT_MASK)) { int size = MOID_SIZE (MOID (p)); BYTE_T *sp_0 = STACK_TOP; (void) genie_frame_identifier (p); CONSTANT (GINFO (p)) = (void *) get_heap_space ((size_t) size); SIZE (GINFO (p)) = size; COPY (CONSTANT (GINFO (p)), (void *) sp_0, size); UNIT (&self) = genie_constant; } else { (void) genie_frame_identifier (p); UNIT (&self) = genie_frame_identifier; } return (self); } /*! \brief push result of cast (coercions are deeper in the tree) \param p position in tree \return a propagator for this action **/ static PROP_T genie_cast (NODE_T * p) { PROP_T self; EXECUTE_UNIT (NEXT_SUB (p)); UNIT (&self) = genie_cast; SOURCE (&self) = p; return (self); } /*! \brief execute assertion \param p position in tree \return a propagator for this action **/ static PROP_T genie_assertion (NODE_T * p) { PROP_T self; if (STATUS_TEST (p, ASSERT_MASK)) { A68_BOOL z; EXECUTE_UNIT (NEXT_SUB (p)); POP_OBJECT (p, &z, A68_BOOL); if (VALUE (&z) == A68_FALSE) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FALSE_ASSERTION); exit_genie (p, A68_RUNTIME_ERROR); } } UNIT (&self) = genie_assertion; SOURCE (&self) = p; return (self); } /*! \brief push format text \param p position in tree \return a propagator for this action **/ static PROP_T genie_format_text (NODE_T * p) { static PROP_T self; A68_FORMAT z = *(A68_FORMAT *) (FRAME_OBJECT (OFFSET (TAX (p)))); PUSH_FORMAT (p, z); UNIT (&self) = genie_format_text; SOURCE (&self) = p; return (self); } /*! \brief SELECTION from a value \param p position in tree \return a propagator for this action **/ static PROP_T genie_selection_value_quick (NODE_T * p) { NODE_T *selector = SUB (p); MOID_T *result_mode = MOID (selector); ADDR_T old_stack_pointer = stack_pointer; int size = MOID_SIZE (result_mode); int offset = OFFSET (NODE_PACK (SUB (selector))); EXECUTE_UNIT (NEXT (selector)); stack_pointer = old_stack_pointer; if (offset > 0) { MOVE (STACK_TOP, STACK_OFFSET (offset), (unsigned) size); genie_check_initialisation (p, STACK_TOP, result_mode); } INCREMENT_STACK_POINTER (selector, size); return (GPROP (p)); } /*! \brief SELECTION from a name \param p position in tree \return a propagator for this action **/ static PROP_T genie_selection_name_quick (NODE_T * p) { NODE_T *selector = SUB (p); MOID_T *struct_mode = MOID (NEXT (selector)); A68_REF *z = (A68_REF *) STACK_TOP; EXECUTE_UNIT (NEXT (selector)); CHECK_REF (selector, *z, struct_mode); OFFSET (z) += OFFSET (NODE_PACK (SUB (selector))); return (GPROP (p)); } /*! \brief push selection from secondary \param p position in tree \return a propagator for this action **/ static PROP_T genie_selection (NODE_T * p) { NODE_T *selector = SUB (p); PROP_T self; MOID_T *struct_mode = MOID (NEXT (selector)), *result_mode = MOID (selector); BOOL_T selection_of_name = (BOOL_T) (IS (struct_mode, REF_SYMBOL)); SOURCE (&self) = p; UNIT (&self) = genie_selection; EXECUTE_UNIT (NEXT (selector)); /* Multiple selections */ if (selection_of_name && (IS (SUB (struct_mode), FLEX_SYMBOL) || IS (SUB (struct_mode), ROW_SYMBOL))) { A68_REF *row1, row2, row3; int dims, desc_size; POP_ADDRESS (selector, row1, A68_REF); CHECK_REF (p, *row1, struct_mode); row1 = DEREF (A68_REF, row1); dims = DIM (DEFLEX (SUB (struct_mode))); desc_size = ALIGNED_SIZE_OF (A68_ARRAY) + dims * ALIGNED_SIZE_OF (A68_TUPLE); row2 = heap_generator (selector, result_mode, desc_size); MOVE (ADDRESS (&row2), DEREF (BYTE_T, row1), (unsigned) desc_size); MOID ((DEREF (A68_ARRAY, &row2))) = SUB_SUB (result_mode); FIELD_OFFSET (DEREF (A68_ARRAY, &row2)) += OFFSET (NODE_PACK (SUB (selector))); row3 = heap_generator (selector, result_mode, A68_REF_SIZE); * DEREF (A68_REF, &row3) = row2; PUSH_REF (selector, row3); UNIT (&self) = genie_selection; } else if (struct_mode != NO_MOID && (IS (struct_mode, FLEX_SYMBOL) || IS (struct_mode, ROW_SYMBOL))) { A68_REF *row1, row2; int dims, desc_size; POP_ADDRESS (selector, row1, A68_REF); dims = DIM (DEFLEX (struct_mode)); desc_size = ALIGNED_SIZE_OF (A68_ARRAY) + dims * ALIGNED_SIZE_OF (A68_TUPLE); row2 = heap_generator (selector, result_mode, desc_size); MOVE (ADDRESS (&row2), DEREF (BYTE_T, row1), (unsigned) desc_size); MOID ((DEREF (A68_ARRAY, &row2))) = SUB (result_mode); FIELD_OFFSET (DEREF (A68_ARRAY, &row2)) += OFFSET (NODE_PACK (SUB (selector))); PUSH_REF (selector, row2); UNIT (&self) = genie_selection; } /* Normal selections */ else if (selection_of_name && IS (SUB (struct_mode), STRUCT_SYMBOL)) { A68_REF *z = (A68_REF *) (STACK_OFFSET (-A68_REF_SIZE)); CHECK_REF (selector, *z, struct_mode); OFFSET (z) += OFFSET (NODE_PACK (SUB (selector))); UNIT (&self) = genie_selection_name_quick; } else if (IS (struct_mode, STRUCT_SYMBOL)) { DECREMENT_STACK_POINTER (selector, MOID_SIZE (struct_mode)); MOVE (STACK_TOP, STACK_OFFSET (OFFSET (NODE_PACK (SUB (selector)))), (unsigned) MOID_SIZE (result_mode)); genie_check_initialisation (p, STACK_TOP, result_mode); INCREMENT_STACK_POINTER (selector, MOID_SIZE (result_mode)); UNIT (&self) = genie_selection_value_quick; } return (self); } /*! \brief push selection from primary \param p position in tree \return a propagator for this action **/ static PROP_T genie_field_selection (NODE_T * p) { PROP_T self; ADDR_T pop_sp = stack_pointer, pop_fp = frame_pointer; NODE_T *entry = p; A68_REF *z = (A68_REF *) STACK_TOP; A68_PROCEDURE *w = (A68_PROCEDURE *) STACK_TOP; SOURCE (&self) = entry; UNIT (&self) = genie_field_selection; EXECUTE_UNIT (SUB (p)); for (p = SEQUENCE (SUB (p)); p != NO_NODE; p = SEQUENCE (p)) { BOOL_T coerce = A68_TRUE; MOID_T *m = MOID (p); MOID_T *result_mode = MOID (NODE_PACK (p)); while (coerce) { if (IS (m, REF_SYMBOL) && ISNT (SUB (m), STRUCT_SYMBOL)) { int size = MOID_SIZE (SUB (m)); stack_pointer = pop_sp; CHECK_REF (p, *z, m); PUSH (p, ADDRESS (z), size); genie_check_initialisation (p, STACK_OFFSET (-size), MOID (p)); m = SUB (m); } else if (IS (m, PROC_SYMBOL)) { genie_check_initialisation (p, (BYTE_T *) w, m); genie_call_procedure (p, m, m, MODE (VOID), w, pop_sp, pop_fp); STACK_DNS (p, MOID (p), frame_pointer); m = SUB (m); } else { coerce = A68_FALSE; } } if (IS (m, REF_SYMBOL) && IS (SUB (m), STRUCT_SYMBOL)) { CHECK_REF (p, *z, m); OFFSET (z) += OFFSET (NODE_PACK (p)); } else if (IS (m, STRUCT_SYMBOL)) { stack_pointer = pop_sp; MOVE (STACK_TOP, STACK_OFFSET (OFFSET (NODE_PACK (p))), (unsigned) MOID_SIZE (result_mode)); INCREMENT_STACK_POINTER (p, MOID_SIZE (result_mode)); } } return (self); } /*! \brief call operator \param p position in tree \param pop_sp stack pointer value to restore **/ void genie_call_operator (NODE_T * p, ADDR_T pop_sp) { A68_PROCEDURE *z; ADDR_T pop_fp = frame_pointer; MOID_T *pr_mode = MOID (TAX (p)); FRAME_GET (z, A68_PROCEDURE, p); genie_call_procedure (p, pr_mode, MOID (z), pr_mode, z, pop_sp, pop_fp); STACK_DNS (p, SUB (pr_mode), frame_pointer); } /*! \brief push result of monadic formula OP "u" \param p position in tree \return a propagator for this action **/ static PROP_T genie_monadic (NODE_T * p) { NODE_T *op = SUB (p); NODE_T *u = NEXT (op); PROP_T self; ADDR_T sp = stack_pointer; EXECUTE_UNIT (u); STACK_DNS (u, MOID (u), frame_pointer); if (PROCEDURE (TAX (op)) != NO_GPROC) { (void) ((*(PROCEDURE (TAX (op)))) (op)); } else { genie_call_operator (op, sp); } UNIT (&self) = genie_monadic; SOURCE (&self) = p; return (self); } /*! \brief push result of formula \param p position in tree \return a propagator for this action **/ static PROP_T genie_dyadic_quick (NODE_T * p) { NODE_T *u = SUB (p); NODE_T *op = NEXT (u); NODE_T *v = NEXT (op); EXECUTE_UNIT (u); STACK_DNS (u, MOID (u), frame_pointer); EXECUTE_UNIT (v); STACK_DNS (v, MOID (v), frame_pointer); (void) ((*(PROCEDURE (TAX (op)))) (op)); return (GPROP (p)); } /*! \brief push result of formula \param p position in tree \return a propagator for this action **/ static PROP_T genie_dyadic (NODE_T * p) { NODE_T *u = SUB (p); NODE_T *op = NEXT (u); NODE_T *v = NEXT (op); ADDR_T pop_sp = stack_pointer; EXECUTE_UNIT (u); STACK_DNS (u, MOID (u), frame_pointer); EXECUTE_UNIT (v); STACK_DNS (v, MOID (v), frame_pointer); if (PROCEDURE (TAX (op)) != NO_GPROC) { (void) ((*(PROCEDURE (TAX (op)))) (op)); } else { genie_call_operator (op, pop_sp); } return (GPROP (p)); } /*! \brief push result of formula \param p position in tree \return a propagator for this action **/ static PROP_T genie_formula (NODE_T * p) { PROP_T self, lhs, rhs; NODE_T *u = SUB (p); NODE_T *op = NEXT (u); ADDR_T pop_sp = stack_pointer; UNIT (&self) = genie_formula; SOURCE (&self) = p; EXECUTE_UNIT_2 (u, lhs); STACK_DNS (u, MOID (u), frame_pointer); if (op != NO_NODE) { NODE_T *v = NEXT (op); GPROC *proc = PROCEDURE (TAX (op)); EXECUTE_UNIT_2 (v, rhs); STACK_DNS (v, MOID (v), frame_pointer); UNIT (&self) = genie_dyadic; if (proc != NO_GPROC) { (void) ((*(proc)) (op)); UNIT (&self) = genie_dyadic_quick; } else { genie_call_operator (op, pop_sp); } return (self); } else if (UNIT (&lhs) == genie_monadic) { return (lhs); } return (self); } /*! \brief push NIL \param p position in tree \return a propagator for this action **/ static PROP_T genie_nihil (NODE_T * p) { PROP_T self; PUSH_REF (p, nil_ref); UNIT (&self) = genie_nihil; SOURCE (&self) = p; return (self); } /*! \brief assign a value to a name and voiden \param p position in tree \return a propagator for this action **/ static PROP_T genie_voiding_assignation_constant (NODE_T * p) { NODE_T *dst = SUB (p); NODE_T *src = SOURCE (&PROP (GINFO (NEXT_NEXT (dst)))); ADDR_T pop_sp = stack_pointer; A68_REF *z = (A68_REF *) STACK_TOP; PROP_T self; UNIT (&self) = genie_voiding_assignation_constant; SOURCE (&self) = p; EXECUTE_UNIT (dst); CHECK_REF (p, *z, MOID (p)); COPY (ADDRESS (z), CONSTANT (GINFO (src)), SIZE (GINFO (src))); stack_pointer = pop_sp; return (self); } /*! \brief assign a value to a name and voiden \param p position in tree \return a propagator for this action **/ static PROP_T genie_voiding_assignation (NODE_T * p) { NODE_T *dst = SUB (p); NODE_T *src = NEXT_NEXT (dst); MOID_T *src_mode = SUB_MOID (p); ADDR_T pop_sp = stack_pointer, pop_fp = FRAME_DNS (frame_pointer); A68_REF z; BOOL_T caution; PROP_T self; UNIT (&self) = genie_voiding_assignation; SOURCE (&self) = p; EXECUTE_UNIT (dst); POP_OBJECT (p, &z, A68_REF); caution = (BOOL_T) IS_IN_HEAP (&z); if (caution) { } CHECK_REF (p, z, MOID (p)); FRAME_DNS (frame_pointer) = REF_SCOPE (&z); EXECUTE_UNIT (src); STACK_DNS (src, src_mode, REF_SCOPE (&z)); FRAME_DNS (frame_pointer) = pop_fp; stack_pointer = pop_sp; if (HAS_ROWS (src_mode)) { genie_clone_stack (p, src_mode, &z, &z); } else { COPY_ALIGNED (ADDRESS (&z), STACK_TOP, MOID_SIZE (src_mode)); } if (caution) { } return (self); } /*! \brief assign a value to a name and push the name \param p position in tree \return a propagator for this action **/ static PROP_T genie_assignation_constant (NODE_T * p) { NODE_T *dst = SUB (p); NODE_T *src = SOURCE (&PROP (GINFO (NEXT_NEXT (dst)))); A68_REF *z = (A68_REF *) STACK_TOP; PROP_T self; UNIT (&self) = genie_assignation_constant; SOURCE (&self) = p; EXECUTE_UNIT (dst); CHECK_REF (p, *z, MOID (p)); COPY (ADDRESS (z), CONSTANT (GINFO (src)), SIZE (GINFO (src))); return (self); } /*! \brief assign a value to a name and push the name \param p position in tree \return a propagator for this action **/ static PROP_T genie_assignation_quick (NODE_T * p) { PROP_T self; NODE_T *dst = SUB (p); NODE_T *src = NEXT_NEXT (dst); MOID_T *src_mode = SUB_MOID (p); int size = MOID_SIZE (src_mode); ADDR_T pop_fp = FRAME_DNS (frame_pointer); A68_REF *z = (A68_REF *) STACK_TOP; EXECUTE_UNIT (dst); CHECK_REF (p, *z, MOID (p)); FRAME_DNS (frame_pointer) = REF_SCOPE (z); EXECUTE_UNIT (src); STACK_DNS (src, src_mode, REF_SCOPE (z)); FRAME_DNS (frame_pointer) = pop_fp; DECREMENT_STACK_POINTER (p, size); if (HAS_ROWS (src_mode)) { genie_clone_stack (p, src_mode, z, z); } else { COPY (ADDRESS (z), STACK_TOP, size); } UNIT (&self) = genie_assignation_quick; SOURCE (&self) = p; return (self); } /*! \brief assign a value to a name and push the name \param p position in tree \return a propagator for this action **/ static PROP_T genie_assignation (NODE_T * p) { PROP_T self, srp; NODE_T *dst = SUB (p); NODE_T *src = NEXT_NEXT (dst); MOID_T *src_mode = SUB_MOID (p); int size = MOID_SIZE (src_mode); ADDR_T pop_fp = FRAME_DNS (frame_pointer); A68_REF *z = (A68_REF *) STACK_TOP; EXECUTE_UNIT (dst); CHECK_REF (p, *z, MOID (p)); FRAME_DNS (frame_pointer) = REF_SCOPE (z); EXECUTE_UNIT_2 (src, srp); STACK_DNS (src, src_mode, REF_SCOPE (z)); FRAME_DNS (frame_pointer) = pop_fp; DECREMENT_STACK_POINTER (p, size); if (HAS_ROWS (src_mode)) { genie_clone_stack (p, src_mode, z, z); } else { COPY (ADDRESS (z), STACK_TOP, size); } if (UNIT (&srp) == genie_constant) { UNIT (&self) = genie_assignation_constant; } else { UNIT (&self) = genie_assignation_quick; } SOURCE (&self) = p; return (self); } /*! \brief push equality of two REFs \param p position in tree \return a propagator for this action **/ static PROP_T genie_identity_relation (NODE_T * p) { PROP_T self; NODE_T *lhs = SUB (p), *rhs = NEXT_NEXT (lhs); A68_REF x, y; UNIT (&self) = genie_identity_relation; SOURCE (&self) = p; EXECUTE_UNIT (lhs); POP_REF (p, &y); EXECUTE_UNIT (rhs); POP_REF (p, &x); if (IS (NEXT_SUB (p), IS_SYMBOL)) { PUSH_PRIMITIVE (p, (BOOL_T) (ADDRESS (&x) == ADDRESS (&y)), A68_BOOL); } else { PUSH_PRIMITIVE (p, (BOOL_T) (ADDRESS (&x) != ADDRESS (&y)), A68_BOOL); } return (self); } /*! \brief push result of ANDF \param p position in tree \return a propagator for this action **/ static PROP_T genie_and_function (NODE_T * p) { PROP_T self; A68_BOOL x; EXECUTE_UNIT (SUB (p)); POP_OBJECT (p, &x, A68_BOOL); if (VALUE (&x) == A68_TRUE) { EXECUTE_UNIT (NEXT_NEXT (SUB (p))); } else { PUSH_PRIMITIVE (p, A68_FALSE, A68_BOOL); } UNIT (&self) = genie_and_function; SOURCE (&self) = p; return (self); } /*! \brief push result of ORF \param p position in tree \return a propagator for this action **/ static PROP_T genie_or_function (NODE_T * p) { PROP_T self; A68_BOOL x; EXECUTE_UNIT (SUB (p)); POP_OBJECT (p, &x, A68_BOOL); if (VALUE (&x) == A68_FALSE) { EXECUTE_UNIT (NEXT_NEXT (SUB (p))); } else { PUSH_PRIMITIVE (p, A68_TRUE, A68_BOOL); } UNIT (&self) = genie_or_function; SOURCE (&self) = p; return (self); } /*! \brief push routine text \param p position in tree \return a propagator for this action **/ static PROP_T genie_routine_text (NODE_T * p) { static PROP_T self; A68_PROCEDURE z = *(A68_PROCEDURE *) (FRAME_OBJECT (OFFSET (TAX (p)))); PUSH_PROCEDURE (p, z); UNIT (&self) = genie_routine_text; SOURCE (&self) = p; return (self); } /*! \brief push an undefined value of the required mode \param p position in tree \param u mode of object to push **/ void genie_push_undefined (NODE_T * p, MOID_T * u) { /* For primitive modes we push an initialised value */ if (u == MODE (VOID)) { /* skip */ ; } else if (u == MODE (INT)) { PUSH_PRIMITIVE (p, 1, A68_INT); /* Because users write [~] INT ! */ } else if (u == MODE (REAL)) { PUSH_PRIMITIVE (p, (rng_53_bit ()), A68_REAL); } else if (u == MODE (BOOL)) { PUSH_PRIMITIVE (p, (BOOL_T) (rng_53_bit () < 0.5), A68_BOOL); } else if (u == MODE (CHAR)) { PUSH_PRIMITIVE (p, (char) (32 + 96 * rng_53_bit ()), A68_CHAR); } else if (u == MODE (BITS)) { PUSH_PRIMITIVE (p, (unsigned) (rng_53_bit () * A68_MAX_UNT), A68_BITS); } else if (u == MODE (COMPLEX)) { PUSH_COMPLEX (p, rng_53_bit (), rng_53_bit ()); } else if (u == MODE (BYTES)) { PUSH_BYTES (p, "SKIP"); } else if (u == MODE (LONG_BYTES)) { PUSH_LONG_BYTES (p, "SKIP"); } else if (u == MODE (STRING)) { PUSH_REF (p, empty_string (p)); } else if (u == MODE (LONG_INT) || u == MODE (LONGLONG_INT)) { int digits = get_mp_digits (u); MP_T *z; STACK_MP (z, p, digits); SET_MP_ZERO (z, digits); z[0] = (MP_T) INIT_MASK; } else if (u == MODE (LONG_REAL) || u == MODE (LONGLONG_REAL)) { int digits = get_mp_digits (u); MP_T *z; STACK_MP (z, p, digits); SET_MP_ZERO (z, digits); z[0] = (MP_T) INIT_MASK; } else if (u == MODE (LONG_BITS) || u == MODE (LONGLONG_BITS)) { int digits = get_mp_digits (u); MP_T *z; STACK_MP (z, p, digits); SET_MP_ZERO (z, digits); z[0] = (MP_T) INIT_MASK; } else if (u == MODE (LONG_COMPLEX) || u == MODE (LONGLONG_COMPLEX)) { int digits = get_mp_digits (u); MP_T *z; STACK_MP (z, p, digits); SET_MP_ZERO (z, digits); z[0] = (MP_T) INIT_MASK; STACK_MP (z, p, digits); SET_MP_ZERO (z, digits); z[0] = (MP_T) INIT_MASK; } else if (IS (u, REF_SYMBOL)) { /* All REFs are NIL */ PUSH_REF (p, nil_ref); } else if (IS (u, ROW_SYMBOL) || IS (u, FLEX_SYMBOL)) { /* [] AMODE or FLEX [] AMODE */ A68_REF er = empty_row (p, u); STATUS (&er) |= SKIP_ROW_MASK; PUSH_REF (p, er); } else if (IS (u, STRUCT_SYMBOL)) { /* STRUCT */ PACK_T *v; for (v = PACK (u); v != NO_PACK; FORWARD (v)) { genie_push_undefined (p, MOID (v)); } } else if (IS (u, UNION_SYMBOL)) { /* UNION */ ADDR_T sp = stack_pointer; PUSH_UNION (p, MOID (PACK (u))); genie_push_undefined (p, MOID (PACK (u))); stack_pointer = sp + MOID_SIZE (u); } else if (IS (u, PROC_SYMBOL)) { /* PROC */ A68_PROCEDURE z; STATUS (&z) = (STATUS_MASK) (INIT_MASK | SKIP_PROCEDURE_MASK); (NODE (&BODY (&z))) = NO_NODE; ENVIRON (&z) = 0; LOCALE (&z) = NO_HANDLE; MOID (&z) = u; PUSH_PROCEDURE (p, z); } else if (u == MODE (FORMAT)) { /* FORMAT etc. - what arbitrary FORMAT could mean anything at all? */ A68_FORMAT z; STATUS (&z) = (STATUS_MASK) (INIT_MASK | SKIP_FORMAT_MASK); BODY (&z) = NO_NODE; ENVIRON (&z) = 0; PUSH_FORMAT (p, z); } else if (u == MODE (SIMPLOUT)) { ADDR_T sp = stack_pointer; PUSH_UNION (p, MODE (STRING)); PUSH_REF (p, c_to_a_string (p, "SKIP", DEFAULT_WIDTH)); stack_pointer = sp + MOID_SIZE (u); } else if (u == MODE (SIMPLIN)) { ADDR_T sp = stack_pointer; PUSH_UNION (p, MODE (REF_STRING)); genie_push_undefined (p, MODE (REF_STRING)); stack_pointer = sp + MOID_SIZE (u); } else if (u == MODE (REF_FILE)) { PUSH_REF (p, skip_file); } else if (u == MODE (FILE)) { A68_REF *z = (A68_REF *) STACK_TOP; int size = MOID_SIZE (MODE (FILE)); ADDR_T pop_sp = stack_pointer; PUSH_REF (p, skip_file); stack_pointer = pop_sp; PUSH (p, ADDRESS (z), size); } else if (u == MODE (CHANNEL)) { PUSH_OBJECT (p, skip_channel, A68_CHANNEL); } else if (u == MODE (PIPE)) { genie_push_undefined (p, MODE (REF_FILE)); genie_push_undefined (p, MODE (REF_FILE)); genie_push_undefined (p, MODE (INT)); } else if (u == MODE (SOUND)) { A68_SOUND *z = (A68_SOUND *) STACK_TOP; int size = MOID_SIZE (MODE (SOUND)); INCREMENT_STACK_POINTER (p, size); FILL (z, 0, size); STATUS (z) = INIT_MASK; } else { BYTE_T *_sp_ = STACK_TOP; int size = ALIGNED_SIZE_OF (u); INCREMENT_STACK_POINTER (p, size); FILL (_sp_, 0, size); } } /*! \brief push an undefined value of the required mode \param p position in tree \return a propagator for this action **/ static PROP_T genie_skip (NODE_T * p) { PROP_T self; if (MOID (p) != MODE (VOID)) { genie_push_undefined (p, MOID (p)); } UNIT (&self) = genie_skip; SOURCE (&self) = p; return (self); } /*! \brief jump to the serial clause where the label is at \param p position in tree **/ static void genie_jump (NODE_T * p) { /* Stack pointer and frame pointer were saved at target serial clause */ NODE_T *jump = SUB (p); NODE_T *label = (IS (jump, GOTO_SYMBOL)) ? NEXT (jump) : jump; ADDR_T target_frame_pointer = frame_pointer; jmp_buf *jump_stat = NO_JMP_BUF; /* Find the stack frame this jump points to */ BOOL_T found = A68_FALSE; while (target_frame_pointer > 0 && !found) { found = (BOOL_T) ((TAG_TABLE (TAX (label)) == TABLE (FRAME_TREE (target_frame_pointer))) && FRAME_JUMP_STAT (target_frame_pointer) != NO_JMP_BUF); if (!found) { target_frame_pointer = FRAME_STATIC_LINK (target_frame_pointer); } } /* Beam us up, Scotty! */ #if defined HAVE_PARALLEL_CLAUSE { int curlev = running_par_level, tarlev = PAR_LEVEL (NODE (TAX (label))); if (curlev == tarlev) { /* A jump within the same thread */ jump_stat = FRAME_JUMP_STAT (target_frame_pointer); JUMP_TO (TABLE (TAX (label))) = UNIT (TAX (label)); longjmp (*(jump_stat), 1); } else if (curlev > 0 && tarlev == 0) { /* A jump out of all parallel clauses back into the main program */ genie_abend_all_threads (p, FRAME_JUMP_STAT (target_frame_pointer), label); ABEND (A68_TRUE, "should not return from genie_abend_all_threads", NO_TEXT); } else { /* A jump between threads is forbidden in Algol68G */ diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_LABEL_IN_PAR_CLAUSE); exit_genie (p, A68_RUNTIME_ERROR); } } #else jump_stat = FRAME_JUMP_STAT (target_frame_pointer); JUMP_TO (TAG_TABLE (TAX (label))) = UNIT (TAX (label)); longjmp (*(jump_stat), 1); #endif } /*! \brief execute a unit, tertiary, secondary or primary \param p position in tree \return a propagator for this action **/ static PROP_T genie_unit (NODE_T * p) { if (IS_COERCION (GINFO (p))) { GLOBAL_PROP (&program) = genie_coercion (p); } else { switch (ATTRIBUTE (p)) { case DECLARATION_LIST: { genie_declaration (SUB (p)); UNIT (&GLOBAL_PROP (&program)) = genie_unit; SOURCE (&GLOBAL_PROP (&program)) = p; break; } case UNIT: { EXECUTE_UNIT_2 (SUB (p), GLOBAL_PROP (&program)); break; } case TERTIARY: case SECONDARY: case PRIMARY: { GLOBAL_PROP (&program) = genie_unit (SUB (p)); break; } /* Ex primary */ case ENCLOSED_CLAUSE: { GLOBAL_PROP (&program) = genie_enclosed ((volatile NODE_T *) p); break; } case IDENTIFIER: { GLOBAL_PROP (&program) = genie_identifier (p); break; } case CALL: { GLOBAL_PROP (&program) = genie_call (p); break; } case SLICE: { GLOBAL_PROP (&program) = genie_slice (p); break; } case DENOTATION: { GLOBAL_PROP (&program) = genie_denotation (p); break; } case CAST: { GLOBAL_PROP (&program) = genie_cast (p); break; } case FORMAT_TEXT: { GLOBAL_PROP (&program) = genie_format_text (p); break; } /* Ex secondary */ case GENERATOR: { GLOBAL_PROP (&program) = genie_generator (p); break; } case SELECTION: { GLOBAL_PROP (&program) = genie_selection (p); break; } /* Ex tertiary */ case FORMULA: { GLOBAL_PROP (&program) = genie_formula (p); break; } case MONADIC_FORMULA: { GLOBAL_PROP (&program) = genie_monadic (p); break; } case NIHIL: { GLOBAL_PROP (&program) = genie_nihil (p); break; } case DIAGONAL_FUNCTION: { GLOBAL_PROP (&program) = genie_diagonal_function (p); break; } case TRANSPOSE_FUNCTION: { GLOBAL_PROP (&program) = genie_transpose_function (p); break; } case ROW_FUNCTION: { GLOBAL_PROP (&program) = genie_row_function (p); break; } case COLUMN_FUNCTION: { GLOBAL_PROP (&program) = genie_column_function (p); break; } /* Ex unit */ case ASSIGNATION: { GLOBAL_PROP (&program) = genie_assignation (p); break; } case IDENTITY_RELATION: { GLOBAL_PROP (&program) = genie_identity_relation (p); break; } case ROUTINE_TEXT: { GLOBAL_PROP (&program) = genie_routine_text (p); break; } case SKIP: { GLOBAL_PROP (&program) = genie_skip (p); break; } case JUMP: { UNIT (&GLOBAL_PROP (&program)) = genie_unit; SOURCE (&GLOBAL_PROP (&program)) = p; genie_jump (p); break; } case AND_FUNCTION: { GLOBAL_PROP (&program) = genie_and_function (p); break; } case OR_FUNCTION: { GLOBAL_PROP (&program) = genie_or_function (p); break; } case ASSERTION: { GLOBAL_PROP (&program) = genie_assertion (p); break; } case CODE_CLAUSE: { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_CODE); exit_genie (p, A68_RUNTIME_ERROR); break; } } } return (GPROP (p) = GLOBAL_PROP (&program)); } /*! \brief execution of serial clause without labels \param p position in tree \param p position in treeop_sp \param seq chain to link nodes into **/ void genie_serial_units_no_label (NODE_T * p, int pop_sp, NODE_T ** seq) { for (; p != NO_NODE; FORWARD (p)) { switch (ATTRIBUTE (p)) { case DECLARATION_LIST: case UNIT: { EXECUTE_UNIT_TRACE (p); SEQUENCE (*seq) = p; (*seq) = p; return; } case SEMI_SYMBOL: { /* Voiden the expression stack */ stack_pointer = pop_sp; SEQUENCE (*seq) = p; (*seq) = p; break; } default: { genie_serial_units_no_label (SUB (p), pop_sp, seq); break; } } } } /*! \brief execution of serial clause with labels \param p position in tree \param jump_to indicates node to jump to after jump \param exit_buf jump buffer for EXITs \param p position in treeop_sp **/ void genie_serial_units (NODE_T * p, NODE_T ** jump_to, jmp_buf * exit_buf, int pop_sp) { LOW_STACK_ALERT (p); for (; p != NO_NODE; FORWARD (p)) { switch (ATTRIBUTE (p)) { case DECLARATION_LIST: case UNIT: { if (*jump_to == NO_NODE) { EXECUTE_UNIT_TRACE (p); } else if (p == *jump_to) { /* If we dropped in this clause from a jump then this unit is the target */ *jump_to = NO_NODE; EXECUTE_UNIT_TRACE (p); } return; } case EXIT_SYMBOL: { if (*jump_to == NO_NODE) { longjmp (*exit_buf, 1); } break; } case SEMI_SYMBOL: { if (*jump_to == NO_NODE) { /* Voiden the expression stack */ stack_pointer = pop_sp; } break; } default: { genie_serial_units (SUB (p), jump_to, exit_buf, pop_sp); break; } } } } /*! \brief execute serial clause \param p position in tree \param exit_buf jump buffer for EXITs **/ void genie_serial_clause (NODE_T * p, jmp_buf * exit_buf) { if (LABELS (TABLE (p)) == NO_TAG) { /* No labels in this clause */ if (SEQUENCE (p) == NO_NODE && ! STATUS_TEST (p, SEQUENCE_MASK)) { NODE_T top_seq; NODE_T *seq = &top_seq; GINFO_T g; GINFO (&top_seq) = &g; genie_serial_units_no_label (SUB (p), stack_pointer, &seq); SEQUENCE (p) = SEQUENCE (&top_seq); STATUS_SET (p, SEQUENCE_MASK); STATUS_SET (p, SERIAL_MASK); if (SEQUENCE (p) != NO_NODE && SEQUENCE (SEQUENCE (p)) == NO_NODE) { STATUS_SET (p, OPTIMAL_MASK); } } else { /* A linear list without labels */ NODE_T *q; ADDR_T pop_sp = stack_pointer; STATUS_SET (p, SERIAL_CLAUSE); for (q = SEQUENCE (p); q != NO_NODE; q = SEQUENCE (q)) { switch (ATTRIBUTE (q)) { case DECLARATION_LIST: case UNIT: { EXECUTE_UNIT_TRACE (q); break; } case SEMI_SYMBOL: { stack_pointer = pop_sp; break; } } } } } else { /* Labels in this clause */ jmp_buf jump_stat; ADDR_T pop_sp = stack_pointer, pop_fp = frame_pointer; ADDR_T pop_dns = FRAME_DNS (frame_pointer); FRAME_JUMP_STAT (frame_pointer) = &jump_stat; if (!setjmp (jump_stat)) { NODE_T *jump_to = NO_NODE; genie_serial_units (SUB (p), &jump_to, exit_buf, stack_pointer); } else { /* HIjol! Restore state and look for indicated unit */ NODE_T *jump_to = JUMP_TO (TABLE (p)); stack_pointer = pop_sp; frame_pointer = pop_fp; FRAME_DNS (frame_pointer) = pop_dns; genie_serial_units (SUB (p), &jump_to, exit_buf, stack_pointer); } } } /*! \brief execute enquiry clause \param p position in tree **/ void genie_enquiry_clause (NODE_T * p) { if (SEQUENCE (p) == NO_NODE && ! STATUS_TEST (p, SEQUENCE_MASK)) { NODE_T top_seq; NODE_T *seq = &top_seq; GINFO_T g; GINFO (&top_seq) = &g; genie_serial_units_no_label (SUB (p), stack_pointer, &seq); SEQUENCE (p) = SEQUENCE (&top_seq); STATUS_SET (p, SEQUENCE_MASK); if (SEQUENCE (p) != NO_NODE && SEQUENCE (SEQUENCE (p)) == NO_NODE) { STATUS_SET (p, OPTIMAL_MASK); } } else { /* A linear list without labels (of course, it's an enquiry clause) */ NODE_T *q; ADDR_T pop_sp = stack_pointer; STATUS_SET (p, SERIAL_MASK); for (q = SEQUENCE (p); q != NO_NODE; q = SEQUENCE (q)) { switch (ATTRIBUTE (q)) { case DECLARATION_LIST: case UNIT: { EXECUTE_UNIT_TRACE (q); break; } case SEMI_SYMBOL: { stack_pointer = pop_sp; break; } } } } } /*! \brief execute collateral units \param p position in tree \param count counts collateral units **/ static void genie_collateral_units (NODE_T * p, int *count) { for (; p != NO_NODE; FORWARD (p)) { if (IS (p, UNIT)) { EXECUTE_UNIT_TRACE (p); STACK_DNS (p, MOID (p), FRAME_DNS (frame_pointer)); (*count)++; return; } else { genie_collateral_units (SUB (p), count); } } } /*! \brief execute collateral clause \param p position in tree \return a propagator for this action **/ static PROP_T genie_collateral (NODE_T * p) { PROP_T self; /* VOID clause and STRUCT display */ if (MOID (p) == MODE (VOID) || IS (MOID (p), STRUCT_SYMBOL)) { int count = 0; genie_collateral_units (SUB (p), &count); } else { /* Row display */ A68_REF new_display; int count = 0; ADDR_T sp = stack_pointer; MOID_T *m = MOID (p); genie_collateral_units (SUB (p), &count); if (DIM (DEFLEX (m)) == 1) { /* [] AMODE display */ new_display = genie_make_row (p, SLICE (DEFLEX (m)), count, sp); stack_pointer = sp; INCREMENT_STACK_POINTER (p, A68_REF_SIZE); *(A68_REF *) STACK_ADDRESS (sp) = new_display; } else { /* [,,] AMODE display, we concatenate 1 + (n-1) to n dimensions */ new_display = genie_make_rowrow (p, m, count, sp); stack_pointer = sp; INCREMENT_STACK_POINTER (p, A68_REF_SIZE); *(A68_REF *) STACK_ADDRESS (sp) = new_display; } } UNIT (&self) = genie_collateral; SOURCE (&self) = p; return (self); } /*! \brief execute unit from integral-case in-part \param p position in tree \param k value of enquiry clause \param count unit counter \return whether a unit was executed **/ BOOL_T genie_int_case_unit (NODE_T * p, int k, int *count) { if (p == NO_NODE) { return (A68_FALSE); } else { if (IS (p, UNIT)) { if (k == *count) { EXECUTE_UNIT_TRACE (p); return (A68_TRUE); } else { (*count)++; return (A68_FALSE); } } else { if (genie_int_case_unit (SUB (p), k, count)) { return (A68_TRUE); } else { return (genie_int_case_unit (NEXT (p), k, count)); } } } } /*! \brief execute unit from united-case in-part \param p position in tree \param m mode of enquiry clause \return whether a unit was executed **/ static BOOL_T genie_united_case_unit (NODE_T * p, MOID_T * m) { if (p == NO_NODE) { return (A68_FALSE); } else { if (IS (p, SPECIFIER)) { MOID_T *spec_moid = MOID (NEXT_SUB (p)); BOOL_T equal_modes; if (m != NO_MOID) { if (IS (spec_moid, UNION_SYMBOL)) { equal_modes = is_unitable (m, spec_moid, SAFE_DEFLEXING); } else { equal_modes = (BOOL_T) (m == spec_moid); } } else { equal_modes = A68_FALSE; } if (equal_modes) { NODE_T *q = NEXT_NEXT (SUB (p)); OPEN_STATIC_FRAME (p); INIT_STATIC_FRAME (p); if (IS (q, IDENTIFIER)) { if (IS (spec_moid, UNION_SYMBOL)) { COPY ((FRAME_OBJECT (OFFSET (TAX (q)))), STACK_TOP, MOID_SIZE (spec_moid)); } else { COPY ((FRAME_OBJECT (OFFSET (TAX (q)))), STACK_OFFSET (A68_UNION_SIZE), MOID_SIZE (spec_moid)); } } EXECUTE_UNIT_TRACE (NEXT_NEXT (p)); CLOSE_FRAME; return (A68_TRUE); } else { return (A68_FALSE); } } else { if (genie_united_case_unit (SUB (p), m)) { return (A68_TRUE); } else { return (genie_united_case_unit (NEXT (p), m)); } } } } /*! \brief execute identity declaration \param p position in tree **/ void genie_identity_dec (NODE_T * p) { for (; p != NO_NODE; FORWARD (p)) { if (ISNT (p, DEFINING_IDENTIFIER)) { genie_identity_dec (SUB (p)); } else { A68_REF loc; NODE_T *src = NEXT_NEXT (p); MOID_T *src_mode = MOID (p); unsigned size = (unsigned) MOID_SIZE (src_mode); BYTE_T *stack_top = STACK_TOP; ADDR_T pop_sp = stack_pointer; ADDR_T pop_dns = FRAME_DNS (frame_pointer); FRAME_DNS (frame_pointer) = frame_pointer; EXECUTE_UNIT_TRACE (src); genie_check_initialisation (src, stack_top, src_mode); STACK_DNS (src, src_mode, frame_pointer); FRAME_DNS (frame_pointer) = pop_dns; /* Make a temporary REF to the object in the frame */ STATUS (&loc) = (STATUS_MASK) (INIT_MASK | IN_FRAME_MASK); REF_HANDLE (&loc) = &nil_handle; OFFSET (&loc) = frame_pointer + FRAME_INFO_SIZE + OFFSET (TAX (p)); REF_SCOPE (&loc) = frame_pointer; ABEND (ADDRESS (&loc) != FRAME_OBJECT (OFFSET (TAX (p))), ERROR_INTERNAL_CONSISTENCY, NO_TEXT); /* Initialise the tag, value is in the stack */ if (HAS_ROWS (src_mode)) { stack_pointer = pop_sp; genie_clone_stack (p, src_mode, &loc, &nil_ref); } else if (UNIT (&GPROP (src)) == genie_constant) { STATUS_SET (TAX (p), CONSTANT_MASK); POP_ALIGNED (p, ADDRESS (&loc), size); } else { POP_ALIGNED (p, ADDRESS (&loc), size); } return; } } } /*! \brief execute variable declaration \param p position in tree \param declarer pointer to the declarer **/ void genie_variable_dec (NODE_T * p, NODE_T ** declarer, ADDR_T sp) { for (; p != NO_NODE; FORWARD (p)) { if (IS (p, VARIABLE_DECLARATION)) { genie_variable_dec (SUB (p), declarer, sp); } else { if (IS (p, DECLARER)) { (*declarer) = SUB (p); genie_generator_bounds (*declarer); FORWARD (p); } if (IS (p, DEFINING_IDENTIFIER)) { MOID_T *ref_mode = MOID (p); TAG_T *tag = TAX (p); int leap = (HEAP (tag) == LOC_SYMBOL ? LOC_SYMBOL : HEAP_SYMBOL); A68_REF *z; PREEMPTIVE_GC; z = (A68_REF *) (FRAME_OBJECT (OFFSET (TAX (p)))); genie_generator_internal (*declarer, ref_mode, BODY (tag), leap, sp); POP_REF (p, z); if (NEXT (p) != NO_NODE && IS (NEXT (p), ASSIGN_SYMBOL)) { NODE_T *src = NEXT_NEXT (p); MOID_T *src_mode = SUB_MOID (p); ADDR_T pop_sp = stack_pointer; ADDR_T pop_dns = FRAME_DNS (frame_pointer); FRAME_DNS (frame_pointer) = frame_pointer; EXECUTE_UNIT_TRACE (src); STACK_DNS (src, src_mode, frame_pointer); FRAME_DNS (frame_pointer) = pop_dns; stack_pointer = pop_sp; if (HAS_ROWS (src_mode)) { genie_clone_stack (p, src_mode, z, z); } else { MOVE (ADDRESS (z), STACK_TOP, (unsigned) MOID_SIZE (src_mode)); } } } } } } /*! \brief execute PROC variable declaration \param p position in tree **/ void genie_proc_variable_dec (NODE_T * p) { for (; p != NO_NODE; FORWARD (p)) { switch (ATTRIBUTE (p)) { case DEFINING_IDENTIFIER: { ADDR_T sp_for_voiding = stack_pointer; MOID_T *ref_mode = MOID (p); TAG_T *tag = TAX (p); int leap = (HEAP (tag) == LOC_SYMBOL ? LOC_SYMBOL : HEAP_SYMBOL); A68_REF *z = (A68_REF *) (FRAME_OBJECT (OFFSET (TAX (p)))); genie_generator_internal (p, ref_mode, BODY (tag), leap, stack_pointer); POP_REF (p, z); if (NEXT (p) != NO_NODE && IS (NEXT (p), ASSIGN_SYMBOL)) { MOID_T *src_mode = SUB_MOID (p); ADDR_T pop_sp = stack_pointer; ADDR_T pop_dns = FRAME_DNS (frame_pointer); FRAME_DNS (frame_pointer) = frame_pointer; EXECUTE_UNIT_TRACE (NEXT_NEXT (p)); STACK_DNS (p, SUB (ref_mode), frame_pointer); FRAME_DNS (frame_pointer) = pop_dns; stack_pointer = pop_sp; MOVE (ADDRESS (z), STACK_TOP, (unsigned) MOID_SIZE (src_mode)); } stack_pointer = sp_for_voiding; /* Voiding */ return; } default: { genie_proc_variable_dec (SUB (p)); break; } } } } /*! \brief execute operator declaration \param p position in tree **/ void genie_operator_dec (NODE_T * p) { for (; p != NO_NODE; FORWARD (p)) { switch (ATTRIBUTE (p)) { case DEFINING_OPERATOR: { A68_PROCEDURE *z = (A68_PROCEDURE *) (FRAME_OBJECT (OFFSET (TAX (p)))); ADDR_T pop_dns = FRAME_DNS (frame_pointer); FRAME_DNS (frame_pointer) = frame_pointer; EXECUTE_UNIT_TRACE (NEXT_NEXT (p)); STACK_DNS (p, MOID (p), frame_pointer); FRAME_DNS (frame_pointer) = pop_dns; POP_PROCEDURE (p, z); return; } default: { genie_operator_dec (SUB (p)); break; } } } } /*! \brief execute declaration \param p position in tree **/ void genie_declaration (NODE_T * p) { for (; p != NO_NODE; FORWARD (p)) { switch (ATTRIBUTE (p)) { case MODE_DECLARATION: case PROCEDURE_DECLARATION: case BRIEF_OPERATOR_DECLARATION: case PRIORITY_DECLARATION: { /* Already resolved */ return; } case IDENTITY_DECLARATION: { genie_identity_dec (SUB (p)); break; } case OPERATOR_DECLARATION: { genie_operator_dec (SUB (p)); break; } case VARIABLE_DECLARATION: { NODE_T *declarer = NO_NODE; ADDR_T pop_sp = stack_pointer; genie_variable_dec (SUB (p), &declarer, stack_pointer); /* Voiding to remove garbage from declarers */ stack_pointer = pop_sp; break; } case PROCEDURE_VARIABLE_DECLARATION: { ADDR_T pop_sp = stack_pointer; genie_proc_variable_dec (SUB (p)); stack_pointer = pop_sp; break; } default: { genie_declaration (SUB (p)); break; } } } } /* #define LABEL_FREE(p) {\ NODE_T *_m_q; ADDR_T pop_sp = stack_pointer;\ for (_m_q = SEQUENCE (p); _m_q != NO_NODE; _m_q = SEQUENCE (_m_q)) {\ switch (ATTRIBUTE (_m_q)) {\ case DECLARATION_LIST: case UNIT: {\ EXECUTE_UNIT_TRACE (_m_q);\ break;\ }\ case SEMI_SYMBOL: {\ stack_pointer = pop_sp;\ break;\ }}}} */ #define LABEL_FREE(p) {\ NODE_T *_m_q; ADDR_T pop_sp_lf = stack_pointer;\ for (_m_q = SEQUENCE (p); _m_q != NO_NODE; _m_q = SEQUENCE (_m_q)) {\ if (IS (_m_q, UNIT) || IS (_m_q, DECLARATION_LIST)) {\ EXECUTE_UNIT_TRACE (_m_q);\ }\ if (SEQUENCE (_m_q) != NO_NODE) {\ stack_pointer = pop_sp_lf;\ _m_q = SEQUENCE (_m_q);\ }\ }} #define SERIAL_CLAUSE(p)\ if (STATUS_TEST (p, OPTIMAL_MASK)) {\ EXECUTE_UNIT (SEQUENCE (p));\ } else if (STATUS_TEST (p, SERIAL_MASK)) {\ LABEL_FREE (p);\ } else {\ if (!setjmp (exit_buf)) {\ genie_serial_clause ((NODE_T *) p, (jmp_buf *) exit_buf);\ }} #define SERIAL_CLAUSE_TRACE(p)\ if (STATUS_TEST (p, OPTIMAL_MASK)) {\ EXECUTE_UNIT_TRACE (SEQUENCE (p));\ } else if (STATUS_TEST (p, SERIAL_MASK)) {\ LABEL_FREE (p);\ } else {\ if (!setjmp (exit_buf)) {\ genie_serial_clause ((NODE_T *) p, (jmp_buf *) exit_buf);\ }} #define ENQUIRY_CLAUSE(p)\ if (STATUS_TEST (p, OPTIMAL_MASK)) {\ EXECUTE_UNIT (SEQUENCE (p));\ } else if (STATUS_TEST (p, SERIAL_MASK)) {\ LABEL_FREE (p);\ } else {\ genie_enquiry_clause ((NODE_T *) p);\ } /*! \brief execute integral-case-clause \param p position in tree **/ static PROP_T genie_int_case (volatile NODE_T * p) { volatile int unit_count; volatile BOOL_T found_unit; jmp_buf exit_buf; A68_INT k; volatile NODE_T *q = SUB (p); volatile MOID_T *yield = MOID (q); /* CASE or OUSE */ OPEN_STATIC_FRAME ((NODE_T *) SUB (q)); INIT_GLOBAL_POINTER ((NODE_T *) SUB (q)); INIT_STATIC_FRAME ((NODE_T *) SUB (q)); ENQUIRY_CLAUSE (NEXT_SUB (q)); POP_OBJECT (q, &k, A68_INT); /* IN */ FORWARD (q); OPEN_STATIC_FRAME ((NODE_T *) SUB (q)); INIT_STATIC_FRAME ((NODE_T *) SUB (q)); unit_count = 1; found_unit = genie_int_case_unit (NEXT_SUB ((NODE_T *) q), (int) VALUE (&k), (int *) &unit_count); CLOSE_FRAME; /* OUT */ if (!found_unit) { FORWARD (q); switch (ATTRIBUTE (q)) { case CHOICE: case OUT_PART: { OPEN_STATIC_FRAME ((NODE_T *) SUB (q)); INIT_STATIC_FRAME ((NODE_T *) SUB (q)); SERIAL_CLAUSE (NEXT_SUB (q)); CLOSE_FRAME; break; } case CLOSE_SYMBOL: case ESAC_SYMBOL: { if (yield != MODE (VOID)) { genie_push_undefined ((NODE_T *) q, (MOID_T *) yield); } break; } default: { MOID (SUB ((NODE_T *) q)) = (MOID_T *) yield; (void) genie_int_case (q); break; } } } /* ESAC */ CLOSE_FRAME; return (GPROP (p)); } /*! \brief execute united-case-clause \param p position in tree **/ static PROP_T genie_united_case (volatile NODE_T * p) { volatile BOOL_T found_unit = A68_FALSE; volatile MOID_T *um; volatile ADDR_T pop_sp; jmp_buf exit_buf; volatile NODE_T *q = SUB (p); volatile MOID_T *yield = MOID (q); /* CASE or OUSE */ OPEN_STATIC_FRAME ((NODE_T *) SUB (q)); INIT_GLOBAL_POINTER ((NODE_T *) SUB (q)); INIT_STATIC_FRAME ((NODE_T *) SUB (q)); pop_sp = stack_pointer; ENQUIRY_CLAUSE (NEXT_SUB (q)); stack_pointer = pop_sp; um = (volatile MOID_T *) VALUE ((A68_UNION *) STACK_TOP); /* IN */ FORWARD (q); if (um != NO_MOID) { OPEN_STATIC_FRAME ((NODE_T *) SUB (q)); INIT_STATIC_FRAME ((NODE_T *) SUB (q)); found_unit = genie_united_case_unit (NEXT_SUB ((NODE_T *) q), (MOID_T *) um); CLOSE_FRAME; } else { found_unit = A68_FALSE; } /* OUT */ if (!found_unit) { FORWARD (q); switch (ATTRIBUTE (q)) { case CHOICE: case OUT_PART: { OPEN_STATIC_FRAME ((NODE_T *) SUB (q)); INIT_STATIC_FRAME ((NODE_T *) SUB (q)); SERIAL_CLAUSE (NEXT_SUB (q)); CLOSE_FRAME; break; } case CLOSE_SYMBOL: case ESAC_SYMBOL: { if (yield != MODE (VOID)) { genie_push_undefined ((NODE_T *) q, (MOID_T *) yield); } break; } default: { MOID (SUB ((NODE_T *) q)) = (MOID_T *) yield; (void) genie_united_case (q); break; } } } /* ESAC */ CLOSE_FRAME; return (GPROP (p)); } /*! \brief execute conditional-clause \param p position in tree **/ static PROP_T genie_conditional (volatile NODE_T * p) { volatile int pop_sp = stack_pointer; jmp_buf exit_buf; volatile NODE_T *q = SUB (p); volatile MOID_T *yield = MOID (q); /* IF or ELIF */ OPEN_STATIC_FRAME ((NODE_T *) SUB (q)); INIT_GLOBAL_POINTER ((NODE_T *) SUB (q)); INIT_STATIC_FRAME ((NODE_T *) SUB (q)); ENQUIRY_CLAUSE (NEXT_SUB (q)); stack_pointer = pop_sp; FORWARD (q); if (VALUE ((A68_BOOL *) STACK_TOP) == A68_TRUE) { /* THEN */ OPEN_STATIC_FRAME ((NODE_T *) SUB (q)); INIT_STATIC_FRAME ((NODE_T *) SUB (q)); SERIAL_CLAUSE (NEXT_SUB (q)); CLOSE_FRAME; } else { /* ELSE */ FORWARD (q); switch (ATTRIBUTE (q)) { case CHOICE: case ELSE_PART: { OPEN_STATIC_FRAME ((NODE_T *) SUB (q)); INIT_STATIC_FRAME ((NODE_T *) SUB (q)); SERIAL_CLAUSE (NEXT_SUB (q)); CLOSE_FRAME; break; } case CLOSE_SYMBOL: case FI_SYMBOL: { if (yield != MODE (VOID)) { genie_push_undefined ((NODE_T *) q, (MOID_T *) yield); } break; } default: { MOID (SUB ((NODE_T *) q)) = (MOID_T *) yield; (void) genie_conditional (q); break; } } } /* FI */ CLOSE_FRAME; return (GPROP (p)); } /* INCREMENT_COUNTER procures that the counter only increments if there is a for-part or a to-part. Otherwise an infinite loop would trigger overflow when the anonymous counter reaches max int, which is strange behaviour. */ #define INCREMENT_COUNTER\ if (!(for_part == NO_NODE && to_part == NO_NODE)) {\ CHECK_INT_ADDITION ((NODE_T *) p, counter, by);\ counter += by;\ } /*! \brief execute loop-clause \param p position in tree \return a propagator for this action **/ static PROP_T genie_loop (volatile NODE_T * p) { volatile ADDR_T pop_sp = stack_pointer; volatile int from, by, to, counter; volatile BOOL_T siga, conditional; /* Next line provokes inevitably: warning: variable 'for_part' might be clobbered by 'longjmp' or 'vfork' warning: variable 'to_part' might be clobbered by 'longjmp' or 'vfork' This warning can be safely ignored. */ volatile NODE_T *for_part = NO_NODE, *to_part = NO_NODE, *q = NO_NODE; jmp_buf exit_buf; /* FOR identifier */ if (IS (p, FOR_PART)) { for_part = NEXT_SUB (p); FORWARD (p); } /* FROM unit */ if (IS (p, FROM_PART)) { EXECUTE_UNIT (NEXT_SUB (p)); stack_pointer = pop_sp; from = VALUE ((A68_INT *) STACK_TOP); FORWARD (p); } else { from = 1; } /* BY unit */ if (IS (p, BY_PART)) { EXECUTE_UNIT (NEXT_SUB (p)); stack_pointer = pop_sp; by = VALUE ((A68_INT *) STACK_TOP); FORWARD (p); } else { by = 1; } /* TO unit, DOWNTO unit */ if (IS (p, TO_PART)) { if (IS (SUB (p), DOWNTO_SYMBOL)) { by = -by; } EXECUTE_UNIT (NEXT_SUB (p)); stack_pointer = pop_sp; to = VALUE ((A68_INT *) STACK_TOP); to_part = p; FORWARD (p); } else { to = (by >= 0 ? A68_MAX_INT : -A68_MAX_INT); } q = NEXT_SUB (p); /* Here the loop part starts. We open the frame only once and reinitialise if necessary */ OPEN_STATIC_FRAME ((NODE_T *) q); INIT_GLOBAL_POINTER ((NODE_T *) q); INIT_STATIC_FRAME ((NODE_T *) q); counter = from; /* Does the loop contain conditionals? */ if (IS (p, WHILE_PART)) { conditional = A68_TRUE; } else if (IS (p, DO_PART) || IS (p, ALT_DO_PART)) { NODE_T *until_part = NEXT_SUB (p); if (IS (until_part, SERIAL_CLAUSE)) { until_part = NEXT (until_part); } conditional = (BOOL_T) (until_part != NO_NODE && IS (until_part, UNTIL_PART)); } else { conditional = A68_FALSE; } if (conditional) { /* [FOR ...] [WHILE ...] DO [...] [UNTIL ...] OD */ siga = (BOOL_T) ((by > 0 && counter <= to) || (by < 0 && counter >= to) || (by == 0)); while (siga) { if (for_part != NO_NODE) { A68_INT *z = (A68_INT *) (FRAME_OBJECT (OFFSET (TAX (for_part)))); STATUS (z) = INIT_MASK; VALUE (z) = counter; } stack_pointer = pop_sp; if (IS (p, WHILE_PART)) { ENQUIRY_CLAUSE (q); stack_pointer = pop_sp; siga = (BOOL_T) (VALUE ((A68_BOOL *) STACK_TOP) != A68_FALSE); } if (siga) { /* Next line provokes inevitably: warning: variable 'do_p' might be clobbered by 'longjmp' or 'vfork' This warning can be safely ignored. */ volatile NODE_T *do_part = p, *until_part; if (IS (p, WHILE_PART)) { do_part = NEXT_SUB (NEXT (p)); OPEN_STATIC_FRAME ((NODE_T *) do_part); INIT_STATIC_FRAME ((NODE_T *) do_part); } else { do_part = NEXT_SUB (p); } if (IS (do_part, SERIAL_CLAUSE)) { SERIAL_CLAUSE_TRACE (do_part); until_part = NEXT (do_part); } else { until_part = do_part; } /* UNTIL part */ if (until_part != NO_NODE && IS (until_part, UNTIL_PART)) { NODE_T *v = NEXT_SUB (until_part); OPEN_STATIC_FRAME ((NODE_T *) v); INIT_STATIC_FRAME ((NODE_T *) v); stack_pointer = pop_sp; ENQUIRY_CLAUSE (v); stack_pointer = pop_sp; siga = (BOOL_T) (VALUE ((A68_BOOL *) STACK_TOP) == A68_FALSE); CLOSE_FRAME; } if (IS (p, WHILE_PART)) { CLOSE_FRAME; } /* Increment counter */ if (siga) { INCREMENT_COUNTER; siga = (BOOL_T) ((by > 0 && counter <= to) || (by < 0 && counter >= to) || (by == 0)); } /* The genie cannot take things to next iteration: re-initialise stack frame */ if (siga) { FRAME_CLEAR (AP_INCREMENT (TABLE (q))); if (INITIALISE_FRAME (TABLE (q))) { initialise_frame ((NODE_T *) q); } } } } } else { /* [FOR ...] DO ... OD */ siga = (BOOL_T) ((by > 0 && counter <= to) || (by < 0 && counter >= to) || (by == 0)); while (siga) { if (for_part != NO_NODE) { A68_INT *z = (A68_INT *) (FRAME_OBJECT (OFFSET (TAX (for_part)))); STATUS (z) = INIT_MASK; VALUE (z) = counter; } stack_pointer = pop_sp; SERIAL_CLAUSE_TRACE (q); INCREMENT_COUNTER; siga = (BOOL_T) ((by > 0 && counter <= to) || (by < 0 && counter >= to) || (by == 0)); /* The genie cannot take things to next iteration: re-initialise stack frame */ if (siga) { FRAME_CLEAR (AP_INCREMENT (TABLE (q))); if (INITIALISE_FRAME (TABLE (q))) { initialise_frame ((NODE_T *) q); } } } } /* OD */ CLOSE_FRAME; stack_pointer = pop_sp; return (GPROP (p)); } #undef INCREMENT_COUNTER #undef LOOP_OVERFLOW /*! \brief execute closed clause \param p position in tree \return a propagator for this action **/ static PROP_T genie_closed (volatile NODE_T * p) { jmp_buf exit_buf; volatile NODE_T *q = NEXT_SUB (p); OPEN_STATIC_FRAME ((NODE_T *) q); INIT_GLOBAL_POINTER ((NODE_T *) q); INIT_STATIC_FRAME ((NODE_T *) q); SERIAL_CLAUSE (q); CLOSE_FRAME; return (GPROP (p)); } /*! \brief execute enclosed clause \param p position in tree \return a propagator for this action **/ static PROP_T genie_enclosed (volatile NODE_T * p) { PROP_T self; UNIT (&self) = (PROP_PROC *) genie_enclosed; SOURCE (&self) = (NODE_T *) p; switch (ATTRIBUTE (p)) { case PARTICULAR_PROGRAM: { self = genie_enclosed (SUB (p)); break; } case ENCLOSED_CLAUSE: { self = genie_enclosed (SUB (p)); break; } case CLOSED_CLAUSE: { self = genie_closed ((NODE_T *) p); if (UNIT (&self) == genie_unit) { UNIT (&self) = (PROP_PROC *) genie_closed; SOURCE (&self) = (NODE_T *) p; } break; } #if defined HAVE_PARALLEL_CLAUSE case PARALLEL_CLAUSE: { (void) genie_parallel ((NODE_T *) NEXT_SUB (p)); break; } #endif case COLLATERAL_CLAUSE: { (void) genie_collateral ((NODE_T *) p); break; } case CONDITIONAL_CLAUSE: { MOID (SUB ((NODE_T *) p)) = MOID (p); (void) genie_conditional (p); UNIT (&self) = (PROP_PROC *) genie_conditional; SOURCE (&self) = (NODE_T *) p; break; } case CASE_CLAUSE: { MOID (SUB ((NODE_T *) p)) = MOID (p); (void) genie_int_case (p); UNIT (&self) = (PROP_PROC *) genie_int_case; SOURCE (&self) = (NODE_T *) p; break; } case CONFORMITY_CLAUSE: { MOID (SUB ((NODE_T *) p)) = MOID (p); (void) genie_united_case (p); UNIT (&self) = (PROP_PROC *) genie_united_case; SOURCE (&self) = (NODE_T *) p; break; } case LOOP_CLAUSE: { (void) genie_loop (SUB ((NODE_T *) p)); UNIT (&self) = (PROP_PROC *) genie_loop; SOURCE (&self) = SUB ((NODE_T *) p); break; } } GPROP (p) = self; return (self); } /* Routines for handling stowed objects. An A68G row is a reference to a descriptor in the heap: ... A68_REF row -> A68_ARRAY ----+ ARRAY: Description of row, ref to elements A68_TUPLE 1 | TUPLE: Bounds, one for every dimension ... | A68_TUPLE dim | ... | ... | Element 1 <---+ Element: Sequential row elements, in the heap ... Not always contiguous - trims! Element n */ /*! \brief size of a row \param tup first tuple \param tup dimension of row \return same **/ int get_row_size (A68_TUPLE * tup, int dim) { int span = 1, k; for (k = 0; k < dim; k++) { int stride = ROW_SIZE (&tup[k]); ABEND ((stride > 0 && span > A68_MAX_INT / stride), ERROR_INVALID_SIZE, "get_row_size"); span *= stride; } return (span); } /*! \brief initialise index for FORALL constructs \param tup first tuple \param tup dimension of row **/ void initialise_internal_index (A68_TUPLE * tup, int dim) { int k; for (k = 0; k < dim; k++) { A68_TUPLE *ref = &tup[k]; K (ref) = LWB (ref); } } /*! \brief calculate index \param tup first tuple \param tup dimension of row \return same **/ ADDR_T calculate_internal_index (A68_TUPLE * tup, int dim) { ADDR_T iindex = 0; int k; for (k = 0; k < dim; k++) { A68_TUPLE *ref = &tup[k]; iindex += (SPAN (ref) * K (ref) - SHIFT (ref)); } return (iindex); } /*! \brief increment index for FORALL constructs \param tup first tuple \param tup dimension of row \return whether maximum (index + 1) is reached **/ BOOL_T increment_internal_index (A68_TUPLE * tup, int dim) { BOOL_T carry = A68_TRUE; int k; for (k = dim - 1; k >= 0 && carry; k--) { A68_TUPLE *ref = &tup[k]; if (K (ref) < UPB (ref)) { (K (ref))++; carry = A68_FALSE; } else { K (ref) = LWB (ref); } } return (carry); } /*! \brief print index \param tup first tuple \param tup dimension of row **/ void print_internal_index (FILE_T f, A68_TUPLE * tup, int dim) { int k; for (k = 0; k < dim; k++) { A68_TUPLE *ref = &tup[k]; char buf[BUFFER_SIZE]; ASSERT (snprintf (buf, SNPRINTF_SIZE, "%d", K (ref)) >= 0); WRITE (f, buf); if (k < dim - 1) { WRITE (f, ", "); } } } /*! \brief convert C string to A68 [] CHAR \param p position in tree \param str string to convert \param width width of string \return pointer to [] CHAR **/ A68_REF c_string_to_row_char (NODE_T * p, char *str, int width) { A68_REF z, row; A68_ARRAY arr; A68_TUPLE tup; BYTE_T *base; int str_size, k; str_size = (int) strlen (str); z = heap_generator (p, MODE (ROW_CHAR), ALIGNED_SIZE_OF (A68_ARRAY) + ALIGNED_SIZE_OF (A68_TUPLE)); row = heap_generator (p, MODE (ROW_CHAR), width * ALIGNED_SIZE_OF (A68_CHAR)); DIM (&arr) = 1; MOID (&arr) = MODE (CHAR); ELEM_SIZE (&arr) = ALIGNED_SIZE_OF (A68_CHAR); SLICE_OFFSET (&arr) = 0; FIELD_OFFSET (&arr) = 0; ARRAY (&arr) = row; LWB (&tup) = 1; UPB (&tup) = width; SPAN (&tup) = 1; SHIFT (&tup) = LWB (&tup); K (&tup) = 0; PUT_DESCRIPTOR (arr, tup, &z); base = ADDRESS (&row); for (k = 0; k < width; k++) { A68_CHAR *ch = (A68_CHAR *) & (base[k * ALIGNED_SIZE_OF (A68_CHAR)]); STATUS (ch) = INIT_MASK; VALUE (ch) = TO_UCHAR (str[k]); } return (z); } /*! \brief convert C string to A68 string \param p position in tree \param str string to convert \return STRING **/ A68_REF c_to_a_string (NODE_T * p, char *str, int width) { if (str == NO_TEXT) { return (empty_string (p)); } else { if (width == DEFAULT_WIDTH) { return (c_string_to_row_char (p, str, (int) strlen (str))); } else { return (c_string_to_row_char (p, str, (int) width)); } } } /*! \brief size of a string \param p position in tree \param row row, pointer to descriptor \return same **/ int a68_string_size (NODE_T * p, A68_REF row) { (void) p; if (INITIALISED (&row)) { A68_ARRAY *arr; A68_TUPLE *tup; GET_DESCRIPTOR (arr, tup, &row); return (ROW_SIZE (tup)); } else { return (0); } } /*! \brief convert A68 string to C string \param p position in tree \param str string to store result \param row STRING to convert \return str **/ char *a_to_c_string (NODE_T * p, char *str, A68_REF row) { /* Assume "str" to be long enough - caller's responsibility! */ (void) p; if (INITIALISED (&row)) { A68_ARRAY *arr; A68_TUPLE *tup; int size, n = 0; GET_DESCRIPTOR (arr, tup, &row); size = ROW_SIZE (tup); if (size > 0) { int k; BYTE_T *base_address = ADDRESS (&ARRAY (arr)); for (k = LWB (tup); k <= UPB (tup); k++) { int addr = INDEX_1_DIM (arr, tup, k); A68_CHAR *ch = (A68_CHAR *) & (base_address[addr]); CHECK_INIT (p, INITIALISED (ch), MODE (CHAR)); str[n++] = (char) VALUE (ch); } } str[n] = NULL_CHAR; return (str); } else { return (NO_TEXT); } } /*! \brief return an empty row \param p position in tree \param u mode of row \return fat pointer to descriptor **/ A68_REF empty_row (NODE_T * p, MOID_T * u) { A68_REF dsc; A68_ARRAY *arr; A68_TUPLE *tup; MOID_T *v; int dim, k; if (IS (u, FLEX_SYMBOL)) { u = SUB (u); } v = SUB (u); dim = DIM (u); dsc = heap_generator (p, u, ALIGNED_SIZE_OF (A68_ARRAY) + dim * ALIGNED_SIZE_OF (A68_TUPLE)); GET_DESCRIPTOR (arr, tup, &dsc); DIM (arr) = dim; MOID (arr) = SLICE (u); ELEM_SIZE (arr) = moid_size (SLICE (u)); SLICE_OFFSET (arr) = 0; FIELD_OFFSET (arr) = 0; if (IS (v, ROW_SYMBOL) || IS (v, FLEX_SYMBOL)) { /* [] AMODE or FLEX [] AMODE */ ARRAY (arr) = heap_generator (p, v, A68_REF_SIZE); * DEREF (A68_REF,&ARRAY (arr)) = empty_row (p, v); } else { ARRAY (arr) = nil_ref; } STATUS (&ARRAY (arr)) = (STATUS_MASK) (INIT_MASK | IN_HEAP_MASK); for (k = 0; k < dim; k++) { LWB (&tup[k]) = 1; UPB (&tup[k]) = 0; SPAN (&tup[k]) = 1; SHIFT (&tup[k]) = LWB (tup); } return (dsc); } /*! \brief an empty string, FLEX [1 : 0] CHAR \param p position in tree \return fat pointer to descriptor **/ A68_REF empty_string (NODE_T * p) { return (empty_row (p, MODE (STRING))); } /*! \brief make [,, ..] MODE from [, ..] MODE \param p position in tree \param rmod row of mode \param len number of elements \param sp stack pointer \return fat pointer to descriptor **/ A68_REF genie_make_rowrow (NODE_T * p, MOID_T * rmod, int len, ADDR_T sp) { MOID_T *nmod = IS (rmod, FLEX_SYMBOL) ? SUB (rmod) : rmod; MOID_T *emod = SUB (nmod); A68_REF nrow, orow; A68_ARRAY *narr, *oarr; A68_TUPLE *ntup, *otup; int j, k, span, odim = DIM (nmod) - 1; /* Make the new descriptor */ nrow = heap_generator (p, rmod, ALIGNED_SIZE_OF (A68_ARRAY) + DIM (nmod) * ALIGNED_SIZE_OF (A68_TUPLE)); GET_DESCRIPTOR (narr, ntup, &nrow); DIM (narr) = DIM (nmod); MOID (narr) = emod; ELEM_SIZE (narr) = MOID_SIZE (emod); SLICE_OFFSET (narr) = 0; FIELD_OFFSET (narr) = 0; if (len == 0) { /* There is a vacuum on the stack */ for (k = 0; k < odim; k++) { LWB (&ntup[k + 1]) = 1; UPB (&ntup[k + 1]) = 0; SPAN (&ntup[k + 1]) = 1; SHIFT (&ntup[k + 1]) = LWB (&ntup[k + 1]); } LWB (ntup) = 1; UPB (ntup) = 0; SPAN (ntup) = 0; SHIFT (ntup) = 0; ARRAY (narr) = nil_ref; return (nrow); } else if (len > 0) { A68_ARRAY *x = NO_ARRAY; /* Arrays in the stack must have equal bounds */ for (j = 1; j < len; j++) { A68_REF vrow, rrow; A68_TUPLE *vtup, *rtup; rrow = *(A68_REF *) STACK_ADDRESS (sp); vrow = *(A68_REF *) STACK_ADDRESS (sp + j * A68_REF_SIZE); GET_DESCRIPTOR (x, rtup, &rrow); GET_DESCRIPTOR (x, vtup, &vrow); for (k = 0; k < odim; k++, rtup++, vtup++) { if ((UPB (rtup) != UPB (vtup)) || (LWB (rtup) != LWB (vtup))) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_DIFFERENT_BOUNDS); exit_genie (p, A68_RUNTIME_ERROR); } } } /* Fill descriptor of new row with info from (arbitrary) first one */ orow = *(A68_REF *) STACK_ADDRESS (sp); GET_DESCRIPTOR (x, otup, &orow); for (span = 1, k = 0; k < odim; k++) { A68_TUPLE *nt = &ntup[k + 1], *ot = &otup[k]; LWB (nt) = LWB (ot); UPB (nt) = UPB (ot); SPAN (nt) = span; SHIFT (nt) = LWB (nt) * SPAN (nt); span *= ROW_SIZE (nt); } LWB (ntup) = 1; UPB (ntup) = len; SPAN (ntup) = span; SHIFT (ntup) = LWB (ntup) * SPAN (ntup); ARRAY (narr) = heap_generator (p, rmod, len * span * ELEM_SIZE (narr)); for (j = 0; j < len; j++) { /* new[j,, ] := old[, ] */ BOOL_T done; GET_DESCRIPTOR (oarr, otup, (A68_REF *) STACK_ADDRESS (sp + j * A68_REF_SIZE)); initialise_internal_index (otup, odim); initialise_internal_index (&ntup[1], odim); done = A68_FALSE; while (!done) { A68_REF src = ARRAY (oarr), dst = ARRAY (narr); ADDR_T oindex, nindex; oindex = calculate_internal_index (otup, odim); nindex = j * SPAN (ntup) + calculate_internal_index (&ntup[1], odim); OFFSET (&src) += ROW_ELEMENT (oarr, oindex); OFFSET (&dst) += ROW_ELEMENT (narr, nindex); if (HAS_ROWS (emod)) { A68_REF none = genie_clone (p, emod, &nil_ref, &src); MOVE (ADDRESS (&dst), ADDRESS (&none), MOID_SIZE (emod)); } else { MOVE (ADDRESS (&dst), ADDRESS (&src), MOID_SIZE (emod)); } done = increment_internal_index (otup, odim) | increment_internal_index (&ntup[1], odim); } } } return (nrow); } /*! \brief make a row of 'len' objects that are in the stack \param p position in tree \param elem_mode mode of element \param len number of elements in the stack \param sp stack pointer \return fat pointer to descriptor **/ A68_REF genie_make_row (NODE_T * p, MOID_T * elem_mode, int len, ADDR_T sp) { A68_REF new_row, new_arr; A68_ARRAY *arr; A68_TUPLE *tup; int k; new_row = heap_generator (p, MOID (p), ALIGNED_SIZE_OF (A68_ARRAY) + ALIGNED_SIZE_OF (A68_TUPLE)); new_arr = heap_generator (p, MOID (p), len * MOID_SIZE (elem_mode)); GET_DESCRIPTOR (arr, tup, &new_row); DIM (arr) = 1; MOID (arr) = elem_mode; ELEM_SIZE (arr) = MOID_SIZE (elem_mode); SLICE_OFFSET (arr) = 0; FIELD_OFFSET (arr) = 0; ARRAY (arr) = new_arr; LWB (tup) = 1; UPB (tup) = len; SPAN (tup)= 1; SHIFT (tup) = LWB (tup); for (k = 0; k < len * ELEM_SIZE (arr); k += ELEM_SIZE (arr)) { A68_REF dst = new_arr, src; OFFSET (&dst) += k; STATUS (&src) = (STATUS_MASK) (INIT_MASK | IN_STACK_MASK); OFFSET (&src) = sp + k; REF_HANDLE (&src) = &nil_handle; if (HAS_ROWS (elem_mode)) { A68_REF new_one = genie_clone (p, elem_mode, &nil_ref, &src); MOVE (ADDRESS (&dst), ADDRESS (&new_one), MOID_SIZE (elem_mode)); } else { MOVE (ADDRESS (&dst), ADDRESS (&src), MOID_SIZE (elem_mode)); } } return (new_row); } /*! \brief make REF [1 : 1] [] MODE from REF [] MODE \param p position in tree \param dst_mode destination mode \param src_mode source mode \param sp stack pointer \return fat pointer to descriptor **/ A68_REF genie_make_ref_row_of_row (NODE_T * p, MOID_T * dst_mode, MOID_T * src_mode, ADDR_T sp) { A68_REF new_row, name, array; A68_ARRAY *arr; A68_TUPLE *tup; dst_mode = DEFLEX (dst_mode); src_mode = DEFLEX (src_mode); array = *(A68_REF *) STACK_ADDRESS (sp); /* ROWING NIL yields NIL */ if (IS_NIL (array)) { return (nil_ref); } new_row = heap_generator (p, SUB (dst_mode), ALIGNED_SIZE_OF (A68_ARRAY) + ALIGNED_SIZE_OF (A68_TUPLE)); name = heap_generator (p, dst_mode, A68_REF_SIZE); GET_DESCRIPTOR (arr, tup, &new_row); DIM (arr) = 1; MOID (arr) = src_mode; ELEM_SIZE (arr) = MOID_SIZE (src_mode); SLICE_OFFSET (arr) = 0; FIELD_OFFSET (arr) = 0; ARRAY (arr) = array; LWB (tup) = 1; UPB (tup) = 1; SPAN (tup) = 1; SHIFT (tup) = LWB (tup); * DEREF (A68_REF, &name) = new_row; return (name); } /*! \brief make REF [1 : 1, ..] MODE from REF [..] MODE \param p position in tree \param dst_mode destination mode \param src_mode source mode \param sp stack pointer \return fat pointer to descriptor **/ A68_REF genie_make_ref_row_row (NODE_T * p, MOID_T * dst_mode, MOID_T * src_mode, ADDR_T sp) { A68_REF name, new_row, old_row; A68_ARRAY *new_arr, *old_arr; A68_TUPLE *new_tup, *old_tup; int k; dst_mode = DEFLEX (dst_mode); src_mode = DEFLEX (src_mode); name = *(A68_REF *) STACK_ADDRESS (sp); /* ROWING NIL yields NIL */ if (IS_NIL (name)) { return (nil_ref); } old_row = * DEREF (A68_REF, &name); GET_DESCRIPTOR (old_arr, old_tup, &old_row); /* Make new descriptor */ new_row = heap_generator (p, dst_mode, ALIGNED_SIZE_OF (A68_ARRAY) + DIM (SUB (dst_mode)) * ALIGNED_SIZE_OF (A68_TUPLE)); name = heap_generator (p, dst_mode, A68_REF_SIZE); GET_DESCRIPTOR (new_arr, new_tup, &new_row); DIM (new_arr) = DIM (SUB (dst_mode)); MOID (new_arr) = MOID (old_arr); ELEM_SIZE (new_arr) = ELEM_SIZE (old_arr); SLICE_OFFSET (new_arr) = 0; FIELD_OFFSET (new_arr) = 0; ARRAY (new_arr) = ARRAY (old_arr); /* Fill out the descriptor */ LWB (&(new_tup[0])) = 1; UPB (&(new_tup[0])) = 1; SPAN (&(new_tup[0])) = 1; SHIFT (&(new_tup[0])) = LWB (&(new_tup[0])); for (k = 0; k < DIM (SUB (src_mode)); k++) { new_tup[k + 1] = old_tup[k]; } /* Yield the new name */ * DEREF (A68_REF, &name) = new_row; return (name); } /*! \brief coercion to [1 : 1, ] MODE \param p position in tree \return propagator for this action **/ static PROP_T genie_rowing_row_row (NODE_T * p) { A68_REF row; ADDR_T sp = stack_pointer; EXECUTE_UNIT (SUB (p)); STACK_DNS (p, MOID (SUB (p)), frame_pointer); row = genie_make_rowrow (p, MOID (p), 1, sp); stack_pointer = sp; PUSH_REF (p, row); return (GPROP (p)); } /*! \brief coercion to [1 : 1] [] MODE \param p position in tree \return propagator for this action **/ static PROP_T genie_rowing_row_of_row (NODE_T * p) { A68_REF row; ADDR_T sp = stack_pointer; EXECUTE_UNIT (SUB (p)); STACK_DNS (p, MOID (SUB (p)), frame_pointer); row = genie_make_row (p, SLICE (MOID (p)), 1, sp); stack_pointer = sp; PUSH_REF (p, row); return (GPROP (p)); } /*! \brief coercion to REF [1 : 1, ..] MODE \param p position in tree \return propagator for this action **/ static PROP_T genie_rowing_ref_row_row (NODE_T * p) { A68_REF name; ADDR_T sp = stack_pointer; MOID_T *dst = MOID (p), *src = MOID (SUB (p)); EXECUTE_UNIT (SUB (p)); STACK_DNS (p, MOID (SUB (p)), frame_pointer); stack_pointer = sp; name = genie_make_ref_row_row (p, dst, src, sp); PUSH_REF (p, name); return (GPROP (p)); } /*! \brief REF [1 : 1] [] MODE from [] MODE \param p position in tree \return propagator for this action **/ static PROP_T genie_rowing_ref_row_of_row (NODE_T * p) { A68_REF name; ADDR_T sp = stack_pointer; MOID_T *dst = MOID (p), *src = MOID (SUB (p)); EXECUTE_UNIT (SUB (p)); STACK_DNS (p, MOID (SUB (p)), frame_pointer); stack_pointer = sp; name = genie_make_ref_row_of_row (p, dst, src, sp); PUSH_REF (p, name); return (GPROP (p)); } /*! \brief rowing coercion \param p position in tree \return propagator for this action **/ static PROP_T genie_rowing (NODE_T * p) { PROP_T self; if (IS (MOID (p), REF_SYMBOL)) { /* REF ROW, decide whether we want A->[] A or [] A->[,] A */ MOID_T *mode = SUB_MOID (p); if (DIM (DEFLEX (mode)) >= 2) { (void) genie_rowing_ref_row_row (p); UNIT (&self) = genie_rowing_ref_row_row; SOURCE (&self) = p; } else { (void) genie_rowing_ref_row_of_row (p); UNIT (&self) = genie_rowing_ref_row_of_row; SOURCE (&self) = p; } } else { /* ROW, decide whether we want A->[] A or [] A->[,] A */ if (DIM (DEFLEX (MOID (p))) >= 2) { (void) genie_rowing_row_row (p); UNIT (&self) = genie_rowing_row_row; SOURCE (&self) = p; } else { (void) genie_rowing_row_of_row (p); UNIT (&self) = genie_rowing_row_of_row; SOURCE (&self) = p; } } return (self); } /*! \brief clone a compounded value refered to by 'old' \param p position in tree \param m mode of object \param old fat pointer to old object \param template used for bound checks, NIL if irrelevant \return fat pointer to descriptor or structured value **/ A68_REF genie_clone (NODE_T * p, MOID_T *m, A68_REF *tmp, A68_REF *old) { /* This complex routine is needed as arrays are not always contiguous. The routine takes a REF to the value and returns a REF to the clone. */ if (m == MODE (SOUND)) { /* REF SOUND */ A68_REF nsound; A68_SOUND *w; int size; BYTE_T *owd; nsound = heap_generator (p, m, MOID_SIZE (m)); w = DEREF (A68_SOUND, &nsound); size = A68_SOUND_DATA_SIZE (w); COPY ((BYTE_T *) w, ADDRESS (old), MOID_SIZE (MODE (SOUND))); owd = ADDRESS (&(DATA (w))); DATA (w) = heap_generator (p, MODE (SOUND_DATA), size); COPY (ADDRESS (&(DATA (w))), owd, size); return (nsound); } else if (IS (m, STRUCT_SYMBOL)) { /* REF STRUCT */ PACK_T *fds; A68_REF nstruct; nstruct = heap_generator (p, m, MOID_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), MOID_SIZE (fm)); } else { MOVE (ADDRESS (&nf), ADDRESS (&of), MOID_SIZE (fm)); } } return (nstruct); } else if (IS (m, UNION_SYMBOL)) { /* REF UNION */ A68_REF nunion, src, dst, tmpu; A68_UNION *u; MOID_T *um; nunion = heap_generator (p, m, MOID_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), MOID_SIZE (um)); } else if (um != NO_MOID) { MOVE (ADDRESS (&dst), ADDRESS (&src), MOID_SIZE (um)); } return (nunion); } else if (IF_ROW (m)) { /* REF [FLEX] [] */ A68_REF nrow, ntmp, heap; A68_ARRAY *oarr, *narr, *tarr; A68_TUPLE *otup, *ntup, *ttup = NO_TUPLE, *op, *np, *tp; MOID_T *em = SUB (IS (m, FLEX_SYMBOL) ? SUB (m) : m); int k, span; BOOL_T check_bounds; /* Make new array */ GET_DESCRIPTOR (oarr, otup, DEREF (A68_REF, old)); nrow = heap_generator (p, m, ALIGNED_SIZE_OF (A68_ARRAY) + DIM (oarr) * ALIGNED_SIZE_OF (A68_TUPLE)); /* Now fill the new descriptor */ GET_DESCRIPTOR (narr, ntup, &nrow); DIM (narr) = DIM (oarr); MOID (narr) = MOID (oarr); ELEM_SIZE (narr) = ELEM_SIZE (oarr); SLICE_OFFSET (narr) = 0; FIELD_OFFSET (narr) = 0; /* Get size and copy bounds; check in case of a row. This is just song and dance to comply with the RR. */ check_bounds = A68_FALSE; if (IS_NIL (*tmp)) { ntmp = nil_ref; } else { A68_REF *z = DEREF (A68_REF, tmp); if (!IS_NIL (*z)) { GET_DESCRIPTOR (tarr, ttup, z); ntmp = ARRAY (tarr); check_bounds = IS (m, ROW_SYMBOL); } } for (span = 1, k = 0; k < DIM (oarr); k++) { op = &otup[k]; np = &ntup[k]; if (check_bounds) { tp = &ttup[k]; if (UPB (tp) != UPB (op) || LWB (tp) != LWB (op)) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_DIFFERENT_BOUNDS); exit_genie (p, A68_RUNTIME_ERROR); } } LWB (np) = LWB (op); UPB (np) = UPB (op); SPAN (np) = span; SHIFT (np) = LWB (np) * SPAN (np); span *= ROW_SIZE (np); } /* Make a new array with at least a ghost element */ if (span == 0) { ARRAY (narr) = heap_generator (p, em, ELEM_SIZE (narr)); } else { ARRAY (narr) = heap_generator (p, em, span * ELEM_SIZE (narr)); } /* Copy the ghost element if there are no elements */ if (span == 0 && HAS_ROWS (em)) { A68_REF nold, ndst, a68_clone; nold = ARRAY (oarr); OFFSET (&nold) += ROW_ELEMENT (oarr, 0); ndst = ARRAY (narr); OFFSET (&ndst) += ROW_ELEMENT (narr, 0); a68_clone = genie_clone (p, em, &ntmp, &nold); MOVE (ADDRESS (&ndst), ADDRESS (&a68_clone), MOID_SIZE (em)); } else if (span > 0) { /* The n-dimensional copier */ BOOL_T done = A68_FALSE; initialise_internal_index (otup, DIM (oarr)); initialise_internal_index (ntup, DIM (narr)); while (!done) { A68_REF nold = ARRAY (oarr); A68_REF ndst = ARRAY (narr); ADDR_T oindex = calculate_internal_index (otup, DIM (oarr)); ADDR_T nindex = calculate_internal_index (ntup, DIM (narr)); OFFSET (&nold) += ROW_ELEMENT (oarr, oindex); OFFSET (&ndst) += ROW_ELEMENT (narr, nindex); if (HAS_ROWS (em)) { A68_REF a68_clone; a68_clone = genie_clone (p, em, &ntmp, &nold); MOVE (ADDRESS (&ndst), ADDRESS (&a68_clone), MOID_SIZE (em)); } else { MOVE (ADDRESS (&ndst), ADDRESS (&nold), MOID_SIZE (em)); } /* Increase pointers */ done = increment_internal_index (otup, DIM (oarr)) | increment_internal_index (ntup, DIM (narr)); } } heap = heap_generator (p, m, A68_REF_SIZE); * DEREF (A68_REF, &heap) = nrow; return (heap); } return (nil_ref); } /*! \brief store into a row, fi. trimmed destinations \param p position in tree \param m mode of object \param dst REF destination \param old REF old object \return dst **/ A68_REF genie_store (NODE_T * p, MOID_T *m, A68_REF *dst, A68_REF *old) { /* This complex routine is needed as arrays are not always contiguous. The routine takes a REF to the value and returns a REF to the clone. */ if (IF_ROW (m)) { /* REF [FLEX] [] */ A68_ARRAY *old_arr, *new_arr; A68_TUPLE *old_tup, *new_tup, *old_p, *new_p; MOID_T *em = SUB (IS (m, FLEX_SYMBOL) ? SUB (m) : m); int k, span; BOOL_T done = A68_FALSE; GET_DESCRIPTOR (old_arr, old_tup, DEREF (A68_REF, old)); GET_DESCRIPTOR (new_arr, new_tup, DEREF (A68_REF, dst)); /* Get size and check bounds. This is just song and dance to comply with the RR. */ for (span = 1, k = 0; k < DIM (old_arr); k++) { old_p = &old_tup[k]; new_p = &new_tup[k]; if ((UPB (new_p) != UPB (old_p) || LWB (new_p) != LWB (old_p))) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_DIFFERENT_BOUNDS); exit_genie (p, A68_RUNTIME_ERROR); } span *= ROW_SIZE (new_p); } if (span > 0) { initialise_internal_index (old_tup, DIM (old_arr)); initialise_internal_index (new_tup, DIM (new_arr)); while (!done) { A68_REF new_old = ARRAY (old_arr); A68_REF new_dst = ARRAY (new_arr); ADDR_T old_index = calculate_internal_index (old_tup, DIM (old_arr)); ADDR_T new_index = calculate_internal_index (new_tup, DIM (new_arr)); OFFSET (&new_old) += ROW_ELEMENT (old_arr, old_index); OFFSET (&new_dst) += ROW_ELEMENT (new_arr, new_index); MOVE (ADDRESS (&new_dst), ADDRESS (&new_old), MOID_SIZE (em)); done = increment_internal_index (old_tup, DIM (old_arr)) | increment_internal_index (new_tup, DIM (new_arr)); } } return (*dst); } return (nil_ref); } /*! \brief assignment of complex objects in the stack \param p position in tree \param dst REF to destination \param tmp REF to template for bounds checks \param srcm mode of source **/ static void genie_clone_stack (NODE_T *p, MOID_T *srcm, A68_REF *dst, A68_REF *tmp) { /* STRUCT, UNION, [FLEX] [] or SOUND */ A68_REF stack, *src, a68_clone; STATUS (&stack) = (STATUS_MASK) (INIT_MASK | IN_STACK_MASK); OFFSET (&stack) = stack_pointer; REF_HANDLE (&stack) = &nil_handle; src = DEREF (A68_REF, &stack); if (IS (srcm, ROW_SYMBOL) && !IS_NIL (*tmp)) { if (STATUS (src) & SKIP_ROW_MASK) { return; } a68_clone = genie_clone (p, srcm, tmp, &stack); (void) genie_store (p, srcm, dst, &a68_clone); } else { a68_clone = genie_clone (p, srcm, tmp, &stack); MOVE (ADDRESS (dst), ADDRESS (&a68_clone), MOID_SIZE (srcm)); } } /*! \brief push description for diagonal of square matrix \param p position in tree \return a propagator for this action **/ static PROP_T genie_diagonal_function (NODE_T * p) { NODE_T *q = SUB (p); ADDR_T scope = PRIMAL_SCOPE; PROP_T self; A68_ROW row, new_row; int k = 0; BOOL_T name = (BOOL_T) (IS (MOID (p), REF_SYMBOL)); A68_ARRAY *arr, new_arr; A68_TUPLE *tup1, *tup2, new_tup; MOID_T *m; if (IS (q, TERTIARY)) { A68_INT x; EXECUTE_UNIT (q); POP_OBJECT (p, &x, A68_INT); k = VALUE (&x); FORWARD (q); } EXECUTE_UNIT (NEXT (q)); m = (name ? SUB_MOID (NEXT (q)) : MOID (NEXT (q))); if (name) { A68_REF z; POP_REF (p, &z); CHECK_REF (p, z, MOID (SUB (p))); scope = REF_SCOPE (&z); PUSH_REF (p, * DEREF (A68_REF, &z)); } POP_OBJECT (p, &row, A68_ROW); GET_DESCRIPTOR2 (arr, tup1, tup2, &row); if (ROW_SIZE (tup1) != ROW_SIZE (tup2)) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_NO_SQUARE_MATRIX, m); exit_genie (p, A68_RUNTIME_ERROR); } if (ABS (k) >= ROW_SIZE (tup1)) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_INDEX_OUT_OF_BOUNDS); exit_genie (p, A68_RUNTIME_ERROR); } m = (name ? SUB_MOID (p) : MOID (p)); new_row = heap_generator (p, m, ALIGNED_SIZE_OF (A68_ARRAY) + ALIGNED_SIZE_OF (A68_TUPLE)); DIM (&new_arr) = 1; MOID (&new_arr) = m; ELEM_SIZE (&new_arr) = ELEM_SIZE (arr); SLICE_OFFSET (&new_arr) = SLICE_OFFSET (arr); FIELD_OFFSET (&new_arr) = FIELD_OFFSET (arr); ARRAY (&new_arr) = ARRAY (arr); LWB (&new_tup) = 1; UPB (&new_tup) = ROW_SIZE (tup1) - ABS (k); SHIFT (&new_tup) = SHIFT (tup1) + SHIFT (tup2) - k * SPAN (tup2); if (k < 0) { SHIFT (&new_tup) -= (-k) * (SPAN (tup1) + SPAN (tup2)); } SPAN (&new_tup) = SPAN (tup1) + SPAN (tup2); K (&new_tup) = 0; PUT_DESCRIPTOR (new_arr, new_tup, &new_row); if (name) { A68_REF ref_new = heap_generator (p, MOID (p), A68_REF_SIZE); * DEREF (A68_REF, &ref_new) = new_row; REF_SCOPE (&ref_new) = scope; PUSH_REF (p, ref_new); } else { PUSH_OBJECT (p, new_row, A68_ROW); } UNIT (&self) = genie_diagonal_function; SOURCE (&self) = p; return (self); } /*! \brief push description for transpose of matrix \param p position in tree \return a propagator for this action **/ static PROP_T genie_transpose_function (NODE_T * p) { NODE_T *q = SUB (p); ADDR_T scope = PRIMAL_SCOPE; PROP_T self; A68_ROW row, new_row; BOOL_T name = (BOOL_T) (IS (MOID (p), REF_SYMBOL)); A68_ARRAY *arr, new_arr; A68_TUPLE *tup1, *tup2, new_tup1, new_tup2; MOID_T *m; EXECUTE_UNIT (NEXT (q)); m = (name ? SUB_MOID (NEXT (q)) : MOID (NEXT (q))); if (name) { A68_REF z; POP_REF (p, &z); CHECK_REF (p, z, MOID (SUB (p))); scope = REF_SCOPE (&z); PUSH_REF (p, * DEREF (A68_REF, &z)); } POP_OBJECT (p, &row, A68_ROW); GET_DESCRIPTOR2 (arr, tup1, tup2, &row); new_row = heap_generator (p, m, ALIGNED_SIZE_OF (A68_ARRAY) + 2 * ALIGNED_SIZE_OF (A68_TUPLE)); new_arr = *arr; new_tup1 = *tup2; new_tup2 = *tup1; PUT_DESCRIPTOR2 (new_arr, new_tup1, new_tup2, &new_row); if (name) { A68_REF ref_new = heap_generator (p, MOID (p), A68_REF_SIZE); * DEREF (A68_REF, &ref_new) = new_row; REF_SCOPE (&ref_new) = scope; PUSH_REF (p, ref_new); } else { PUSH_OBJECT (p, new_row, A68_ROW); } UNIT (&self) = genie_transpose_function; SOURCE (&self) = p; return (self); } /*! \brief push description for row vector \param p position in tree \return a propagator for this action **/ static PROP_T genie_row_function (NODE_T * p) { NODE_T *q = SUB (p); ADDR_T scope = PRIMAL_SCOPE; PROP_T self; A68_ROW row, new_row; int k = 1; BOOL_T name = (BOOL_T) (IS (MOID (p), REF_SYMBOL)); A68_ARRAY *arr, new_arr; A68_TUPLE tup1, tup2, *tup; MOID_T *m; if (IS (q, TERTIARY)) { A68_INT x; EXECUTE_UNIT (q); POP_OBJECT (p, &x, A68_INT); k = VALUE (&x); FORWARD (q); } EXECUTE_UNIT (NEXT (q)); m = (name ? SUB_MOID (NEXT (q)) : MOID (NEXT (q))); if (name) { A68_REF z; POP_REF (p, &z); CHECK_REF (p, z, MOID (SUB (p))); scope = REF_SCOPE (&z); PUSH_REF (p, * DEREF (A68_REF, &z)); } POP_OBJECT (p, &row, A68_ROW); GET_DESCRIPTOR (arr, tup, &row); if (DIM (arr) != 1) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_NO_VECTOR, m, PRIMARY); exit_genie (p, A68_RUNTIME_ERROR); } m = (name ? SUB_MOID (p) : MOID (p)); new_row = heap_generator (p, m, ALIGNED_SIZE_OF (A68_ARRAY) + ALIGNED_SIZE_OF (A68_TUPLE)); DIM (&new_arr) = 2; MOID (&new_arr) = m; ELEM_SIZE (&new_arr) = ELEM_SIZE (arr); SLICE_OFFSET (&new_arr) = SLICE_OFFSET (arr); FIELD_OFFSET (&new_arr) = FIELD_OFFSET (arr); ARRAY (&new_arr) = ARRAY (arr); LWB (&tup1) = k; UPB (&tup1) = k; SPAN (&tup1) = 1; SHIFT (&tup1) = k * SPAN (&tup1); K (&tup1) = 0; LWB (&tup2) = 1; UPB (&tup2) = ROW_SIZE (tup); SPAN (&tup2) = SPAN (tup); SHIFT (&tup2) = SPAN (tup); K (&tup2) = 0; PUT_DESCRIPTOR2 (new_arr, tup1, tup2, &new_row); if (name) { A68_REF ref_new = heap_generator (p, MOID (p), A68_REF_SIZE); * DEREF (A68_REF, &ref_new) = new_row; REF_SCOPE (&ref_new) = scope; PUSH_REF (p, ref_new); } else { PUSH_OBJECT (p, new_row, A68_ROW); } UNIT (&self) = genie_row_function; SOURCE (&self) = p; return (self); } /*! \brief push description for column vector \param p position in tree \return a propagator for this action **/ static PROP_T genie_column_function (NODE_T * p) { NODE_T *q = SUB (p); ADDR_T scope = PRIMAL_SCOPE; PROP_T self; A68_ROW row, new_row; int k = 1; BOOL_T name = (BOOL_T) (IS (MOID (p), REF_SYMBOL)); A68_ARRAY *arr, new_arr; A68_TUPLE tup1, tup2, *tup; MOID_T *m; if (IS (q, TERTIARY)) { A68_INT x; EXECUTE_UNIT (q); POP_OBJECT (p, &x, A68_INT); k = VALUE (&x); FORWARD (q); } EXECUTE_UNIT (NEXT (q)); m = (name ? SUB_MOID (NEXT (q)) : MOID (NEXT (q))); if (name) { A68_REF z; POP_REF (p, &z); CHECK_REF (p, z, MOID (SUB (p))); scope = REF_SCOPE (&z); PUSH_REF (p, * DEREF (A68_REF, &z)); } POP_OBJECT (p, &row, A68_ROW); GET_DESCRIPTOR (arr, tup, &row); m = (name ? SUB_MOID (p) : MOID (p)); new_row = heap_generator (p, m, ALIGNED_SIZE_OF (A68_ARRAY) + ALIGNED_SIZE_OF (A68_TUPLE)); DIM (&new_arr) = 2; MOID (&new_arr) = m; ELEM_SIZE (&new_arr) = ELEM_SIZE (arr); SLICE_OFFSET (&new_arr) = SLICE_OFFSET (arr); FIELD_OFFSET (&new_arr) = FIELD_OFFSET (arr); ARRAY (&new_arr) = ARRAY (arr); LWB (&tup1) = 1; UPB (&tup1) = ROW_SIZE (tup); SPAN (&tup1) = SPAN (tup); SHIFT (&tup1) = SPAN (tup); K (&tup1) = 0; LWB (&tup2) = k; UPB (&tup2) = k; SPAN (&tup2) = 1; SHIFT (&tup2) = k * SPAN (&tup2); K (&tup2) = 0; PUT_DESCRIPTOR2 (new_arr, tup1, tup2, &new_row); if (name) { A68_REF ref_new = heap_generator (p, MOID (p), A68_REF_SIZE); * DEREF (A68_REF, &ref_new) = new_row; REF_SCOPE (&ref_new) = scope; PUSH_REF (p, ref_new); } else { PUSH_OBJECT (p, new_row, A68_ROW); } UNIT (&self) = genie_column_function; SOURCE (&self) = p; return (self); } /*! \brief strcmp for qsort \param a string \param b string \return a - b **/ int qstrcmp (const void *a, const void *b) { return (strcmp (*(char *const *) a, *(char *const *) b)); } /*! \brief sort row of string \param p position in tree **/ void genie_sort_row_string (NODE_T * p) { A68_REF z; A68_ARRAY *arr; A68_TUPLE *tup; ADDR_T pop_sp; int size; POP_REF (p, &z); pop_sp = stack_pointer; CHECK_REF (p, z, MODE (ROW_STRING)); GET_DESCRIPTOR (arr, tup, &z); size = ROW_SIZE (tup); if (size > 0) { A68_REF row, *base_ref; A68_ARRAY arrn; A68_TUPLE tupn; int j, k; BYTE_T *base = ADDRESS (&ARRAY (arr)); char **ptrs = (char **) malloc ((size_t) (size * (int) sizeof (char *))); if (ptrs == NO_VAR) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_OUT_OF_CORE); exit_genie (p, A68_RUNTIME_ERROR); } /* Copy C-strings into the stack and sort */ for (j = 0, k = LWB (tup); k <= UPB (tup); j++, k++) { int addr = INDEX_1_DIM (arr, tup, k); A68_REF ref = *(A68_REF *) & (base[addr]); int len; CHECK_REF (p, ref, MODE (STRING)); len = A68_ALIGN (a68_string_size (p, ref) + 1); if (stack_pointer + len > expr_stack_limit) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_STACK_OVERFLOW); exit_genie (p, A68_RUNTIME_ERROR); } ptrs[j] = (char *) STACK_TOP; ASSERT (a_to_c_string (p, (char *) STACK_TOP, ref) != NO_TEXT); INCREMENT_STACK_POINTER (p, len); } qsort (ptrs, (size_t) size, sizeof (char *), qstrcmp); /* Construct an array of sorted strings */ z = heap_generator (p, MODE (ROW_STRING), ALIGNED_SIZE_OF (A68_ARRAY) + ALIGNED_SIZE_OF (A68_TUPLE)); row = heap_generator (p, MODE (ROW_STRING), size * MOID_SIZE (MODE (STRING))); DIM (&arrn) = 1; MOID (&arrn) = MODE (STRING); ELEM_SIZE (&arrn) = MOID_SIZE (MODE (STRING)); SLICE_OFFSET (&arrn) = 0; FIELD_OFFSET (&arrn) = 0; ARRAY (&arrn) = row; LWB (&tupn) = 1; UPB (&tupn) = size; SHIFT (&tupn) = LWB (&tupn); SPAN (&tupn) = 1; K (&tupn) = 0; PUT_DESCRIPTOR (arrn, tupn, &z); base_ref = DEREF (A68_REF, &row); for (k = 0; k < size; k++) { base_ref[k] = c_to_a_string (p, ptrs[k], DEFAULT_WIDTH); } free (ptrs); stack_pointer = pop_sp; PUSH_REF (p, z); } else { /* This is how we sort an empty row of strings .. */ stack_pointer = pop_sp; PUSH_REF (p, empty_row (p, MODE (ROW_STRING))); } } /* Generator and garbage collector routines. The generator allocates space in stack or heap and initialises dynamically sized objects. A mark-and-gc garbage collector defragments the heap. When called, it walks the stack frames and marks the heap space that is still active. This marking process is called "colouring" here since we "pour paint" into the heap. The active blocks are then joined, the non-active blocks are forgotten. When colouring the heap, "cookies" are placed in objects as to find circular references. Algol68G introduces several anonymous tags in the symbol tables that save temporary REF or ROW results, so that they do not get prematurely swept. The genie is not smart enough to handle every heap clog, e.g. when copying STOWED objects. This seems not very elegant, but garbage collectors in general cannot solve all core management problems. To avoid many of the "unforeseen" heap clogs, we try to keep heap occupation low by garbage collecting occasionally, before it fills up completely. If this automatic mechanism does not help, one can always invoke the garbage collector by calling "gc heap" from Algol 68 source text. Mark-and-gc is simple but since it walks recursive structures, it could exhaust the C-stack (segment violation). A rough check is in place. */ void colour_object (BYTE_T *, MOID_T *); void gc_heap (NODE_T *, ADDR_T); int garbage_collects, garbage_bytes_freed; int free_handle_count, max_handle_count; A68_HANDLE *free_handles, *busy_handles; double garbage_seconds; #define DEF_NODE(p) (NEXT_NEXT (NODE (TAX (p)))) #define MAX(u, v) ((u) = ((u) > (v) ? (u) : (v))) void genie_generator_stowed (NODE_T *, BYTE_T *, NODE_T **, ADDR_T *); /* Total freed is kept in a LONG INT */ MP_T garbage_total_freed[LONG_MP_DIGITS + 2]; static MP_T garbage_freed[LONG_MP_DIGITS + 2]; /*! \brief PROC VOID gc heap \param p position in tree **/ void genie_gc_heap (NODE_T * p) { gc_heap (p, frame_pointer); } /*! \brief PROC VOID preemptive gc heap \param p position in tree **/ void genie_preemptive_gc_heap (NODE_T * p) { PREEMPTIVE_GC; } /*! \brief INT blocks \param p position in tree **/ void genie_block (NODE_T * p) { PUSH_PRIMITIVE (p, 0, A68_INT); } /*! \brief INT collections \param p position in tree **/ void genie_garbage_collections (NODE_T * p) { PUSH_PRIMITIVE (p, garbage_collects, A68_INT); } /*! \brief LONG INT garbage \param p position in tree **/ void genie_garbage_freed (NODE_T * p) { PUSH (p, garbage_total_freed, moid_size (MODE (LONG_INT))); } /*! \brief REAL collect seconds \param p position in tree **/ void genie_garbage_seconds (NODE_T * p) { /* Note that this timing is a rough cut */ PUSH_PRIMITIVE (p, garbage_seconds, A68_REAL); } /*! \brief size available for an object in the heap \return size available in bytes **/ int heap_available (void) { return (heap_size - heap_pointer); } /*! \brief initialise heap management \param p position in tree **/ void genie_init_heap (NODE_T * p) { A68_HANDLE *z; int k, max; (void) p; if (heap_segment == NO_BYTE) { diagnostic_node (A68_RUNTIME_ERROR, TOP_NODE (&program), ERROR_OUT_OF_CORE); exit_genie (TOP_NODE (&program), A68_RUNTIME_ERROR); } if (handle_segment == NO_BYTE) { diagnostic_node (A68_RUNTIME_ERROR, TOP_NODE (&program), ERROR_OUT_OF_CORE); exit_genie (TOP_NODE (&program), A68_RUNTIME_ERROR); } garbage_seconds = 0; SET_MP_ZERO (garbage_total_freed, LONG_MP_DIGITS); garbage_collects = 0; ABEND (fixed_heap_pointer >= (heap_size - MIN_MEM_SIZE), ERROR_OUT_OF_CORE, NO_TEXT); heap_pointer = fixed_heap_pointer; heap_is_fluid = A68_FALSE; /* Assign handle space */ z = (A68_HANDLE *) handle_segment; free_handles = z; busy_handles = NO_HANDLE; max = (int) handle_pool_size / (int) sizeof (A68_HANDLE); free_handle_count = max; max_handle_count = max; for (k = 0; k < max; k++) { STATUS (&(z[k])) = NULL_MASK; POINTER (&(z[k])) = NO_BYTE; SIZE (&(z[k])) = 0; NEXT (&z[k]) = (k == max - 1 ? NO_HANDLE : &z[k + 1]); PREVIOUS (&z[k]) = (k == 0 ? NO_HANDLE : &z[k - 1]); } } /*! \brief whether mode must be coloured \param m moid to colour \return same **/ static BOOL_T moid_needs_colouring (MOID_T * m) { if (IS (m, REF_SYMBOL)) { return (A68_TRUE); } else if (IS (m, PROC_SYMBOL)) { return (A68_TRUE); } else if (IS (m, FLEX_SYMBOL) || IS (m, ROW_SYMBOL)) { return (A68_TRUE); } else if (IS (m, STRUCT_SYMBOL) || IS (m, UNION_SYMBOL)) { PACK_T *p = PACK (m); for (; p != NO_PACK; FORWARD (p)) { if (moid_needs_colouring (MOID (p))) { return (A68_TRUE); } } return (A68_FALSE); } else { return (A68_FALSE); } } /*! \brief colour all elements of a row \param z fat pointer to descriptor \param m mode of row **/ static void colour_row_elements (A68_REF * z, MOID_T * m) { A68_ARRAY *arr; A68_TUPLE *tup; GET_DESCRIPTOR (arr, tup, z); if (get_row_size (tup, DIM (arr)) == 0) { /* Empty rows have a ghost elements */ BYTE_T *elem = ADDRESS (&ARRAY (arr)); colour_object (&elem[0], SUB (m)); } else { /* The multi-dimensional garbage collector */ BYTE_T *elem = ADDRESS (&ARRAY (arr)); BOOL_T done = A68_FALSE; initialise_internal_index (tup, DIM (arr)); while (!done) { ADDR_T iindex = calculate_internal_index (tup, DIM (arr)); ADDR_T addr = ROW_ELEMENT (arr, iindex); colour_object (&elem[addr], SUB (m)); done = increment_internal_index (tup, DIM (arr)); } } } /*! \brief colour an (active) object \param item pointer to item to colour \param m mode of item **/ void colour_object (BYTE_T * item, MOID_T * m) { if (item == NO_BYTE || m == NO_MOID) { return; } if (!moid_needs_colouring (m)) { return; } /* Deeply recursive objects might exhaust the stack */ LOW_STACK_ALERT (NO_NODE); if (IS (m, REF_SYMBOL)) { /* REF AMODE colour pointer and object to which it refers */ A68_REF *z = (A68_REF *) item; if (INITIALISED (z) && IS_IN_HEAP (z)) { if (STATUS_TEST (REF_HANDLE (z), COOKIE_MASK)) { return; } STATUS_SET (REF_HANDLE (z), (COOKIE_MASK | COLOUR_MASK)); if (!IS_NIL (*z)) { colour_object (ADDRESS (z), SUB (m)); } STATUS_CLEAR (REF_HANDLE (z), COOKIE_MASK); } } else if (IS (m, FLEX_SYMBOL) || IS (m, ROW_SYMBOL) || m == MODE (STRING)) { /* Claim the descriptor and the row itself */ A68_REF *z = (A68_REF *) item; if (INITIALISED (z) && IS_IN_HEAP (z)) { A68_ARRAY *arr; A68_TUPLE *tup; if (STATUS_TEST (REF_HANDLE (z), COOKIE_MASK)) { return; } /* An array is ALWAYS in the heap */ STATUS_SET (REF_HANDLE (z), (COOKIE_MASK | COLOUR_MASK)); GET_DESCRIPTOR (arr, tup, z); if (REF_HANDLE (&(ARRAY (arr))) != NO_HANDLE) { /* Assume its initialisation */ MOID_T *n = DEFLEX (m); STATUS_SET (REF_HANDLE (&(ARRAY (arr))), COLOUR_MASK); if (moid_needs_colouring (SUB (n))) { colour_row_elements (z, n); } } /* STATUS_CLEAR (REF_HANDLE (z), COOKIE_MASK); */ } } else if (IS (m, STRUCT_SYMBOL)) { /* STRUCTures - colour fields */ PACK_T *p = PACK (m); for (; p != NO_PACK; FORWARD (p)) { colour_object (&item[OFFSET (p)], MOID (p)); } } else if (IS (m, UNION_SYMBOL)) { /* UNIONs - a united object may contain a value that needs colouring */ A68_UNION *z = (A68_UNION *) item; if (INITIALISED (z)) { MOID_T *united_moid = (MOID_T *) VALUE (z); colour_object (&item[A68_UNION_SIZE], united_moid); } } else if (IS (m, PROC_SYMBOL)) { /* PROCs - save a locale and the objects it points to */ A68_PROCEDURE *z = (A68_PROCEDURE *) item; if (INITIALISED (z) && LOCALE (z) != NO_HANDLE && !(STATUS_TEST (LOCALE (z), COOKIE_MASK))) { BYTE_T *u = POINTER (LOCALE (z)); PACK_T *s = PACK (MOID (z)); STATUS_SET (LOCALE (z), (COOKIE_MASK | COLOUR_MASK)); for (; s != NO_PACK; FORWARD (s)) { if (VALUE ((A68_BOOL *) & u[0]) == A68_TRUE) { colour_object (&u[ALIGNED_SIZE_OF (A68_BOOL)], MOID (s)); } u = &(u[ALIGNED_SIZE_OF (A68_BOOL) + MOID_SIZE (MOID (s))]); } STATUS_CLEAR (LOCALE (z), COOKIE_MASK); } } else if (m == MODE (SOUND)) { /* Claim the data of a SOUND object, that is in the heap */ A68_SOUND *w = (A68_SOUND *) item; if (INITIALISED (w)) { STATUS_SET (REF_HANDLE (&(DATA (w))), (COOKIE_MASK | COLOUR_MASK)); } } } /*! \brief colour active objects in the heap \param fp running frame pointer **/ static void colour_heap (ADDR_T fp) { while (fp != 0) { NODE_T *p = FRAME_TREE (fp); TABLE_T *q = TABLE (p); if (q != NO_TABLE) { TAG_T *i; for (i = IDENTIFIERS (q); i != NO_TAG; FORWARD (i)) { colour_object (FRAME_LOCAL (fp, OFFSET (i)), MOID (i)); } for (i = ANONYMOUS (q); i != NO_TAG; FORWARD (i)) { if (PRIO (i) == GENERATOR) { colour_object (FRAME_LOCAL (fp, OFFSET (i)), MOID (i)); } } } fp = FRAME_DYNAMIC_LINK (fp); } } /*! \brief join all active blocks in the heap **/ static void defragment_heap (void) { A68_HANDLE *z; /* Free handles */ z = busy_handles; while (z != NO_HANDLE) { if (!(STATUS_TEST (z, COLOUR_MASK)) && !(STATUS_TEST (z, BLOCK_GC_MASK))) { A68_HANDLE *y = NEXT (z); if (PREVIOUS (z) == NO_HANDLE) { busy_handles = NEXT (z); } else { NEXT (PREVIOUS (z)) = NEXT (z); } if (NEXT (z) != NO_HANDLE) { PREVIOUS (NEXT (z)) = PREVIOUS (z); } NEXT (z) = free_handles; PREVIOUS (z) = NO_HANDLE; if (NEXT (z) != NO_HANDLE) { PREVIOUS (NEXT (z)) = z; } free_handles = z; STATUS_CLEAR (z, ALLOCATED_MASK); garbage_bytes_freed += SIZE (z); free_handle_count++; z = y; } else { FORWARD (z); } } /* There can be no uncoloured allocated handle */ for (z = busy_handles; z != NO_HANDLE; FORWARD (z)) { ABEND (!(STATUS_TEST (z, COLOUR_MASK)) && !(STATUS_TEST (z, BLOCK_GC_MASK)), "bad GC consistency", NO_TEXT); } /* Defragment the heap */ heap_pointer = fixed_heap_pointer; for (z = busy_handles; z != NO_HANDLE && NEXT (z) != NO_HANDLE; FORWARD (z)) { ; } for (; z != NO_HANDLE; BACKWARD (z)) { BYTE_T *dst = HEAP_ADDRESS (heap_pointer); if (dst != POINTER (z)) { MOVE (dst, POINTER (z), (unsigned) SIZE (z)); } STATUS_CLEAR (z, (COLOUR_MASK | COOKIE_MASK)); POINTER (z) = dst; heap_pointer += (SIZE (z)); ABEND (heap_pointer % A68_ALIGNMENT != 0, ERROR_ALIGNMENT, NO_TEXT); } } /*! \brief clean up garbage and defragment the heap \param p position in tree \param fp running frame pointer **/ void gc_heap (NODE_T * p, ADDR_T fp) { /* Must start with fp = current frame_pointer */ A68_HANDLE *z; double t0, t1; #if defined HAVE_PARALLEL_CLAUSE if (pthread_equal (FRAME_THREAD_ID (frame_pointer), main_thread_id) ==0) { return; } #endif t0 = seconds (); /* Unfree handles are subject to inspection */ for (z = busy_handles; z != NO_HANDLE; FORWARD (z)) { STATUS_CLEAR (z, (COLOUR_MASK | COOKIE_MASK)); } /* Pour paint into the heap to reveal active objects */ colour_heap (fp); /* Start freeing and compacting */ garbage_bytes_freed = 0; defragment_heap (); /* Stats and logging */ (void) int_to_mp (p, garbage_freed, (int) garbage_bytes_freed, LONG_MP_DIGITS); (void) add_mp (p, garbage_total_freed, garbage_total_freed, garbage_freed, LONG_MP_DIGITS); garbage_collects++; t1 = seconds (); /* C optimiser can make last digit differ, so next condition is needed to determine a positive time difference */ if ((t1 - t0) > ((double) clock_res / 2.0)) { garbage_seconds += (t1 - t0); } else { garbage_seconds += ((double) clock_res / 2.0); } /* Call the event handler */ genie_call_event_routine (p, MODE (PROC_VOID), &on_gc_event, stack_pointer, frame_pointer); } /*! \brief yield a handle that will point to a block in the heap \param p position in tree \param a68m mode of object \return handle that points to object **/ static A68_HANDLE *give_handle (NODE_T * p, MOID_T * a68m) { if (free_handles != NO_HANDLE) { A68_HANDLE *x = free_handles; free_handles = NEXT (x); if (free_handles != NO_HANDLE) { PREVIOUS (free_handles) = NO_HANDLE; } STATUS (x) = ALLOCATED_MASK; POINTER (x) = NO_BYTE; SIZE (x) = 0; MOID (x) = a68m; NEXT (x) = busy_handles; PREVIOUS (x) = NO_HANDLE; if (NEXT (x) != NO_HANDLE) { PREVIOUS (NEXT (x)) = x; } busy_handles = x; free_handle_count--; return (x); } else { /* Do not auto-GC! */ diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_OUT_OF_CORE); exit_genie (p, A68_RUNTIME_ERROR); } return (NO_HANDLE); } /*! \brief give a block of heap for an object of indicated mode \param p position in tree \param mode mode of object \param size size in bytes to allocate \return fat pointer to object in the heap **/ A68_REF heap_generator (NODE_T * p, MOID_T * mode, int size) { /* Align */ ABEND (size < 0, ERROR_INVALID_SIZE, NO_TEXT); size = A68_ALIGN (size); /* Now give it */ if (heap_available () >= size) { A68_HANDLE *x; A68_REF z; STATUS (&z) = (STATUS_MASK) (INIT_MASK | IN_HEAP_MASK); OFFSET (&z) = 0; x = give_handle (p, mode); SIZE (x) = size; POINTER (x) = HEAP_ADDRESS (heap_pointer); FILL (POINTER (x), 0, size); REF_SCOPE (&z) = PRIMAL_SCOPE; REF_HANDLE (&z) = x; ABEND (((long) ADDRESS (&z)) % A68_ALIGNMENT != 0, ERROR_ALIGNMENT, NO_TEXT); heap_pointer += size; return (z); } else { /* Do not auto-GC! */ diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_OUT_OF_CORE); exit_genie (p, A68_RUNTIME_ERROR); return (nil_ref); } } /* Following implements the generator. For dynamically sized objects, first bounds are evaluated (right first, then down). The object is generated keeping track of the bound-count. ... [#1] STRUCT ( [#2] STRUCT ( [#3] A a, b, ... ) , Advance bound-count here, max is #3 [#4] B a, b, ... ) , Advance bound-count here, max is #4 [#5] C a, b, ... ... Bound-count is maximised when generator_stowed is entered recursively. Bound-count is advanced when completing a STRUCTURED_FIELD. */ /*! \brief whether a moid needs work in allocation \param m moid under test **/ static BOOL_T mode_needs_allocation (MOID_T * m) { if (IS (m, UNION_SYMBOL)) { return (A68_FALSE); } else { return (HAS_ROWS (m)); } } /*! \brief prepare bounds \param p position in tree **/ static void genie_compute_bounds (NODE_T * p) { for (; p != NO_NODE; FORWARD (p)) { if (IS (p, BOUNDS_LIST)) { genie_compute_bounds (SUB (p)); } else if (IS (p, BOUND)) { genie_compute_bounds (SUB (p)); } else if (IS (p, UNIT)) { if (NEXT (p) != NO_NODE && (is_one_of (NEXT (p), COLON_SYMBOL, DOTDOT_SYMBOL, STOP))) { EXECUTE_UNIT (p); p = NEXT_NEXT (p); } else { /* Default lower bound */ PUSH_PRIMITIVE (p, 1, A68_INT); } EXECUTE_UNIT (p); } } } /*! \brief prepare bounds for a row \param p position in tree **/ void genie_generator_bounds (NODE_T * p) { LOW_STACK_ALERT (p); for (; p != NO_NODE; FORWARD (p)) { if (IS (p, BOUNDS)) { genie_compute_bounds (SUB (p)); } else if (IS (p, INDICANT) && IS_LITERALLY (p, "STRING")) { return; } else if (IS (p, INDICANT)) { if (TAX (p) != NO_TAG && HAS_ROWS (MOID (TAX (p)))) { /* Continue from definition at MODE A = ... */ genie_generator_bounds (DEF_NODE (p)); } } else if (IS (p, DECLARER) && !mode_needs_allocation (MOID (p))) { return; } else { genie_generator_bounds (SUB (p)); } } } /*! \brief allocate a structure \param p decl in the syntax tree **/ 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) += MOID_SIZE (fmoid); } } } /*! \brief allocate a structure \param p decl in the syntax tree **/ void genie_generator_struct (NODE_T * p, BYTE_T ** faddr, ADDR_T * cur_sp) { for (; p != NO_NODE; FORWARD (p)) { if (IS (p, STRUCTURED_FIELD_LIST)) { genie_generator_struct (SUB (p), faddr, cur_sp); } else if (IS (p, STRUCTURED_FIELD)) { NODE_T *decl = NO_NODE; ADDR_T top_sp = *cur_sp; genie_generator_field (SUB (p), faddr, &decl, cur_sp, &top_sp); *cur_sp = top_sp; } } } /*! \brief allocate a stowed object \param p decl in the syntax tree **/ void genie_generator_stowed (NODE_T * p, BYTE_T * addr, NODE_T ** decl, ADDR_T * cur_sp) { if (p == NO_NODE) { return; } else if (IS (p, INDICANT) && IS_LITERALLY (p, "STRING")) { /* The standard prelude definition is hard coded here */ *((A68_REF *) addr) = empty_string (p); return; } else if (IS (p, INDICANT) && TAX (p) != NO_TAG) { /* Continue from definition at MODE A = . */ genie_generator_stowed (DEF_NODE (p), addr, decl, cur_sp); return; } else if (IS (p, DECLARER) && mode_needs_allocation (MOID (p))) { genie_generator_stowed (SUB (p), addr, decl, cur_sp); return; } else if (IS (p, STRUCT_SYMBOL)) { BYTE_T *faddr = addr; genie_generator_struct (SUB_NEXT (p), &faddr, cur_sp); return; } /* Row c.s. */ if (IS (p, FLEX_SYMBOL)) { FORWARD (p); } 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 = MOID_SIZE (smod), rsiz = 1; BOOL_T alloc_sub, alloc_str; NODE_T *in = SUB_NEXT (p); if (IS (in, INDICANT) && IS_LITERALLY (in, "STRING")) { alloc_str = A68_TRUE; alloc_sub = A68_FALSE; } else { alloc_sub = mode_needs_allocation (smod); alloc_str = A68_FALSE; } desc = heap_generator (p, rmod, dim * ALIGNED_SIZE_OF (A68_TUPLE) + ALIGNED_SIZE_OF (A68_ARRAY)); GET_DESCRIPTOR (arr, tup, &desc); for (k = 0; k < dim; k++) { CHECK_INIT (p, INITIALISED ((A68_INT *) bounds), MODE (INT)); LWB (&tup[k]) = VALUE ((A68_INT *) bounds); bounds += ALIGNED_SIZE_OF (A68_INT); CHECK_INIT (p, INITIALISED ((A68_INT *) bounds), MODE (INT)); UPB (&tup[k]) = VALUE ((A68_INT *) bounds); bounds += ALIGNED_SIZE_OF (A68_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 * ALIGNED_SIZE_OF (A68_INT)); /* Generate a new row. Note that STRING is handled explicitly since it has implicit bounds */ if (rsiz == 0) { /* Generate a ghost element */ ADDR_T top_sp = *cur_sp; BYTE_T *elem; ARRAY (arr) = heap_generator (p, rmod, esiz); elem = ADDRESS (&(ARRAY (arr))); if (alloc_sub) { genie_generator_stowed (NEXT (p), &(elem[0]), NO_VAR, cur_sp); top_sp = *cur_sp; } else if (alloc_str) { * (A68_REF *) elem = empty_string (p); } (*cur_sp) = top_sp; } else { ADDR_T pop_sp = *cur_sp, top_sp = *cur_sp; BYTE_T *elem; ARRAY (arr) = heap_generator (p, rmod, rsiz * esiz); elem = ADDRESS (&(ARRAY (arr))); for (k = 0; k < rsiz; k++) { if (alloc_sub) { (*cur_sp) = pop_sp; genie_generator_stowed (NEXT (p), &(elem[k * esiz]), NO_VAR, cur_sp); top_sp = *cur_sp; } else if (alloc_str) { * (A68_REF *) (&(elem[k * esiz])) = empty_string (p); } } (*cur_sp) = top_sp; } *(A68_REF *) addr = desc; return; } } /*! \brief generate space and push a REF \param p declarer in the syntax tree \param ref_mode REF mode to be generated \param tag associated internal LOC for this generator \param leap where to generate space \param sp stack pointer to locate bounds **/ void genie_generator_internal (NODE_T * p, MOID_T * ref_mode, TAG_T * tag, LEAP_T leap, ADDR_T sp) { MOID_T *mode = SUB (ref_mode); A68_REF name = nil_ref; /* Set up a REF MODE object, either in the stack or in the heap. Note that A68G will not extend stack frames. Thus only 'static' LOC generators are in the stack, and 'dynamic' LOC generators go into the heap. These local REFs in the heap get local scope however, and A68Gs approach differs from the CDC ALGOL 68 approach that put all generators in the heap. */ if (leap == LOC_SYMBOL) { STATUS (&name) = (STATUS_MASK) (INIT_MASK | IN_FRAME_MASK); REF_HANDLE (&name) = &nil_handle; OFFSET (&name) = frame_pointer + FRAME_INFO_SIZE + OFFSET (tag); REF_SCOPE (&name) = frame_pointer; } else if (leap == -LOC_SYMBOL && NON_LOCAL (p) != NO_TABLE) { ADDR_T lev; name = heap_generator (p, mode, MOID_SIZE (mode)); FOLLOW_SL (lev, LEVEL (NON_LOCAL (p))); REF_SCOPE (&name) = lev; } else if (leap == -LOC_SYMBOL) { name = heap_generator (p, mode, MOID_SIZE (mode)); REF_SCOPE (&name) = frame_pointer; } else if (leap == HEAP_SYMBOL || leap == -HEAP_SYMBOL) { name = heap_generator (p, mode, MOID_SIZE (mode)); REF_SCOPE (&name) = PRIMAL_SCOPE; } else if (leap == NEW_SYMBOL || leap == -NEW_SYMBOL) { name = heap_generator (p, mode, MOID_SIZE (mode)); REF_SCOPE (&name) = PRIMAL_SCOPE; } else { ABEND (A68_TRUE, ERROR_INTERNAL_CONSISTENCY, NO_TEXT); } if (HAS_ROWS (mode)) { ADDR_T cur_sp = sp; genie_generator_stowed (p, ADDRESS (&name), NO_VAR, &cur_sp); } PUSH_REF (p, name); } /*! \brief push a name refering to allocated space \param p position in tree \return a propagator for this action **/ static PROP_T genie_generator (NODE_T * p) { PROP_T self; ADDR_T pop_sp = stack_pointer; A68_REF z; if (NEXT_SUB (p) != NO_NODE) { genie_generator_bounds (NEXT_SUB (p)); } genie_generator_internal (NEXT_SUB (p), MOID (p), TAX (p), -ATTRIBUTE (SUB (p)), pop_sp); POP_REF (p, &z); stack_pointer = pop_sp; PUSH_REF (p, z); UNIT (&self) = genie_generator; SOURCE (&self) = p; return (self); } /* This code implements a parallel clause for Algol68G. This parallel clause has been included for educational purposes, and this implementation just emulates a multi-processor machine. It cannot make use of actual multiple processors. POSIX threads are used to have separate registers and stack for each concurrent unit. Algol68G parallel units behave as POSIX threads - they have private stacks. Hence an assignation to an object in another thread, does not change that object in that other thread. Also jumps between threads are forbidden. */ /*! \brief propagator_name \param p propagator procedure \return function name of "p" **/ char *propagator_name (PROP_PROC * p) { if (p == genie_and_function) { return ("genie_and_function"); } if (p == genie_assertion) { return ("genie_assertion"); } if (p == genie_assignation) { return ("genie_assignation"); } if (p == genie_assignation_constant) { return ("genie_assignation_constant"); } if (p == genie_call) { return ("genie_call"); } if (p == genie_cast) { return ("genie_cast"); } if (p == (PROP_PROC *) genie_closed) { return ("genie_closed"); } if (p == genie_coercion) { return ("genie_coercion"); } if (p == genie_collateral) { return ("genie_collateral"); } if (p == genie_column_function) { return ("genie_column_function"); } if (p == (PROP_PROC *) genie_conditional) { return ("genie_conditional"); } if (p == genie_constant) { return ("genie_constant"); } if (p == genie_denotation) { return ("genie_denotation"); } if (p == genie_deproceduring) { return ("genie_deproceduring"); } if (p == genie_dereference_frame_identifier) { return ("genie_dereference_frame_identifier"); } if (p == genie_dereference_selection_name_quick) { return ("genie_dereference_selection_name_quick"); } if (p == genie_dereference_slice_name_quick) { return ("genie_dereference_slice_name_quick"); } if (p == genie_dereferencing) { return ("genie_dereferencing"); } if (p == genie_dereferencing_quick) { return ("genie_dereferencing_quick"); } if (p == genie_diagonal_function) { return ("genie_diagonal_function"); } if (p == genie_dyadic) { return ("genie_dyadic"); } if (p == genie_dyadic_quick) { return ("genie_dyadic_quick"); } if (p == (PROP_PROC *) genie_enclosed) { return ("genie_enclosed"); } if (p == genie_format_text) { return ("genie_format_text"); } if (p == genie_formula) { return ("genie_formula"); } if (p == genie_generator) { return ("genie_generator"); } if (p == genie_identifier) { return ("genie_identifier"); } if (p == genie_identifier_standenv) { return ("genie_identifier_standenv"); } if (p == genie_identifier_standenv_proc) { return ("genie_identifier_standenv_proc"); } if (p == genie_identity_relation) { return ("genie_identity_relation"); } if (p == (PROP_PROC *) genie_int_case) { return ("genie_int_case"); } if (p == genie_field_selection) { return ("genie_field_selection"); } if (p == genie_frame_identifier) { return ("genie_frame_identifier"); } if (p == (PROP_PROC *) genie_loop) { return ("genie_loop"); } if (p == genie_monadic) { return ("genie_monadic"); } if (p == genie_nihil) { return ("genie_nihil"); } if (p == genie_or_function) { return ("genie_or_function"); } #if defined HAVE_PARALLEL_CLAUSE if (p == genie_parallel) { return ("genie_parallel"); } #endif if (p == genie_routine_text) { return ("genie_routine_text"); } if (p == genie_row_function) { return ("genie_row_function"); } if (p == genie_rowing) { return ("genie_rowing"); } if (p == genie_rowing_ref_row_of_row) { return ("genie_rowing_ref_row_of_row"); } if (p == genie_rowing_ref_row_row) { return ("genie_rowing_ref_row_row"); } if (p == genie_rowing_row_of_row) { return ("genie_rowing_row_of_row"); } if (p == genie_rowing_row_row) { return ("genie_rowing_row_row"); } if (p == genie_selection) { return ("genie_selection"); } if (p == genie_selection_name_quick) { return ("genie_selection_name_quick"); } if (p == genie_selection_value_quick) { return ("genie_selection_value_quick"); } if (p == genie_skip) { return ("genie_skip"); } if (p == genie_slice) { return ("genie_slice"); } if (p == genie_slice_name_quick) { return ("genie_slice_name_quick"); } if (p == genie_transpose_function) { return ("genie_transpose_function"); } if (p == genie_unit) { return ("genie_unit"); } if (p == (PROP_PROC *) genie_united_case) { return ("genie_united_case"); } if (p == genie_uniting) { return ("genie_uniting"); } if (p == genie_voiding) { return ("genie_voiding"); } if (p == genie_voiding_assignation) { return ("genie_voiding_assignation"); } if (p == genie_voiding_assignation_constant) { return ("genie_voiding_assignation_constant"); } if (p == genie_widening) { return ("genie_widening"); } if (p == genie_widening_int_to_real) { return ("genie_widening_int_to_real"); } return (NO_TEXT); } #if defined HAVE_PARALLEL_CLAUSE typedef struct A68_STACK_DESCRIPTOR A68_STACK_DESCRIPTOR; typedef struct A68_THREAD_CONTEXT A68_THREAD_CONTEXT; struct A68_STACK_DESCRIPTOR { ADDR_T cur_ptr, ini_ptr; BYTE_T *swap, *start; int bytes; }; struct A68_THREAD_CONTEXT { pthread_t parent, id; A68_STACK_DESCRIPTOR stack, frame; NODE_T *unit; int stack_used; BYTE_T *thread_stack_offset; BOOL_T active; }; /* Set an upper limit for number of threads. Don't copy POSIX_THREAD_THREADS_MAX since it may be ULONG_MAX. */ #define THREAD_LIMIT 256 #if ! defined _POSIX_THREAD_THREADS_MAX #define _POSIX_THREAD_THREADS_MAX (THREAD_LIMIT) #endif #if (_POSIX_THREAD_THREADS_MAX < THREAD_LIMIT) #define THREAD_MAX (_POSIX_THREAD_THREADS_MAX) #else #define THREAD_MAX (THREAD_LIMIT) #endif pthread_t main_thread_id = 0; int running_par_level = 0; static A68_THREAD_CONTEXT context[THREAD_MAX]; static ADDR_T fp0, sp0; static BOOL_T abend_all_threads = A68_FALSE, exit_from_threads = A68_FALSE; static int context_index = 0; static int par_return_code = 0; static jmp_buf *jump_buffer; static NODE_T *jump_label; static pthread_mutex_t unit_sema = PTHREAD_MUTEX_INITIALIZER; static pthread_t parent_thread_id = 0; static void save_stacks (pthread_t); static void restore_stacks (pthread_t); #define SAVE_STACK(stk, st, si) {\ A68_STACK_DESCRIPTOR *s = (stk);\ BYTE_T *start = (st);\ int size = (si);\ if (size > 0) {\ if (!((s != NULL) && (BYTES (s) > 0) && (size <= BYTES (s)))) {\ if (SWAP (s) != NO_BYTE) {\ free (SWAP (s));\ }\ SWAP (s) = (BYTE_T *) malloc ((size_t) size);\ ABEND (SWAP (s) == NULL, ERROR_OUT_OF_CORE, NO_TEXT);\ }\ START (s) = start;\ BYTES (s) = size;\ COPY (SWAP (s), start, size);\ } else {\ START (s) = start;\ BYTES (s) = 0;\ if (SWAP (s) != NO_BYTE) {\ free (SWAP (s));\ }\ SWAP (s) = NO_BYTE;\ }} #define RESTORE_STACK(stk) {\ A68_STACK_DESCRIPTOR *s = (stk);\ if (s != NULL && BYTES (s) > 0) {\ COPY (START (s), SWAP (s), BYTES (s));\ }} #define GET_THREAD_INDEX(z, ptid) {\ int _k_;\ pthread_t _tid_ = (ptid);\ (z) = -1;\ for (_k_ = 0; _k_ < context_index && (z) == -1; _k_++) {\ if (pthread_equal (_tid_, ID (&context[_k_]))) {\ (z) = _k_;\ }\ }\ ABEND ((z) == -1, "thread id not registered", NO_TEXT);\ } #define ERROR_THREAD_FAULT "thread fault" #define LOCK_THREAD {\ ABEND (pthread_mutex_lock (&unit_sema) != 0, ERROR_THREAD_FAULT, NO_TEXT);\ } #define UNLOCK_THREAD {\ ABEND (pthread_mutex_unlock (&unit_sema) != 0, ERROR_THREAD_FAULT, NO_TEXT);\ } /*! \brief does system stack grow up or down? \param lwb BYTE in the stack to calibrate direction \return 1 if stackpointer increases, -1 if stackpointer decreases, 0 in case of error **/ static int stack_direction (BYTE_T * lwb) { BYTE_T upb; if ((int) (&upb - lwb) > 0) { return (1); } else if ((int) (&upb - lwb) < 0) { return (-1); } else { return (0); } } /*! \brief fill in tree what level of parallel clause we are in \param p position in tree \param n level counter **/ void set_par_level (NODE_T * p, int n) { for (; p != NO_NODE; p = NEXT (p)) { if (IS (p, PARALLEL_CLAUSE)) { PAR_LEVEL (p) = n + 1; } else { PAR_LEVEL (p) = n; } set_par_level (SUB (p), PAR_LEVEL (p)); } } /*! \brief whether we are in the main thread \return same **/ BOOL_T is_main_thread (void) { return ((BOOL_T) (main_thread_id == pthread_self ())); } /*! \brief end a thread, beit normally or not **/ void genie_abend_thread (void) { int k; GET_THREAD_INDEX (k, pthread_self ()); ACTIVE (&context[k]) = A68_FALSE; UNLOCK_THREAD; pthread_exit (NULL); } /*! \brief when we end execution in a parallel clause we zap all threads **/ void genie_set_exit_from_threads (int ret) { abend_all_threads = A68_TRUE; exit_from_threads = A68_TRUE; par_return_code = ret; genie_abend_thread (); } /*! \brief when we jump out of a parallel clause we zap all threads \param p position in tree \param jump_stat jump buffer \param label node where label is at **/ void genie_abend_all_threads (NODE_T * p, jmp_buf * jump_stat, NODE_T * label) { (void) p; abend_all_threads = A68_TRUE; exit_from_threads = A68_FALSE; jump_buffer = jump_stat; jump_label = label; if (!is_main_thread ()) { genie_abend_thread (); } } /*! \brief save this thread and try to start another \param p position in tree **/ static void try_change_thread (NODE_T * p) { if (is_main_thread ()) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_PARALLEL_OUTSIDE); exit_genie (p, A68_RUNTIME_ERROR); } else { /* Release the unit_sema so another thread can take it up .. */ save_stacks (pthread_self ()); UNLOCK_THREAD; /* ... and take it up again! */ LOCK_THREAD; restore_stacks (pthread_self ()); } } /*! \brief store the stacks of threads \param t thread number **/ static void save_stacks (pthread_t t) { ADDR_T p, q, u, v; int k; GET_THREAD_INDEX (k, t); /* Store stack pointers */ CUR_PTR (&FRAME (&context[k])) = frame_pointer; CUR_PTR (&STACK (&context[k])) = stack_pointer; /* Swap out evaluation stack */ p = stack_pointer; q = INI_PTR (&STACK (&context[k])); SAVE_STACK (&(STACK (&context[k])), STACK_ADDRESS (q), p - q); /* Swap out frame stack */ p = frame_pointer; q = INI_PTR (&FRAME (&context[k])); u = p + FRAME_SIZE (p); v = q + FRAME_SIZE (q); /* Consider the embedding thread */ SAVE_STACK (&(FRAME (&context[k])), FRAME_ADDRESS (v), u - v); } /*! \brief restore stacks of thread \param t thread number **/ static void restore_stacks (pthread_t t) { if (ERROR_COUNT (&program) > 0 || abend_all_threads) { genie_abend_thread (); } else { int k; GET_THREAD_INDEX (k, t); /* Restore stack pointers */ get_stack_size (); system_stack_offset = THREAD_STACK_OFFSET (&context[k]); frame_pointer = CUR_PTR (&FRAME (&context[k])); stack_pointer = CUR_PTR (&STACK (&context[k])); /* Restore stacks */ RESTORE_STACK (&(STACK (&context[k]))); RESTORE_STACK (&(FRAME (&context[k]))); } } /*! \brief check whether parallel units have terminated \param active checks whether there are still active threads \param parent parent thread number **/ static void check_parallel_units (BOOL_T * active, pthread_t parent) { int k; for (k = 0; k < context_index; k++) { if (parent == PARENT (&context[k])) { (*active) |= ACTIVE (&context[k]); } } } /*! \brief execute one unit from a PAR clause \param arg dummy argument **/ static void *start_unit (void *arg) { pthread_t t; int k; BYTE_T stack_offset; NODE_T *p; (void) arg; LOCK_THREAD; t = pthread_self (); GET_THREAD_INDEX (k, t); THREAD_STACK_OFFSET (&context[k]) = (BYTE_T *) (&stack_offset - stack_direction (&stack_offset) * STACK_USED (&context[k])); restore_stacks (t); p = (NODE_T *) (UNIT (&context[k])); EXECUTE_UNIT_TRACE (p); genie_abend_thread (); return ((void *) NULL); } /*! \brief execute parallel units \param p position in tree \param parent parent thread number **/ static void start_parallel_units (NODE_T * p, pthread_t parent) { for (; p != NO_NODE; FORWARD (p)) { if (IS (p, UNIT)) { pthread_t new_id; pthread_attr_t new_at; size_t ss; BYTE_T stack_offset; A68_THREAD_CONTEXT *u; /* Set up a thread for this unit */ if (context_index >= THREAD_MAX) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_PARALLEL_OVERFLOW); exit_genie (p, A68_RUNTIME_ERROR); } /* Fill out a context for this thread */ u = &(context[context_index]); UNIT (u) = p; STACK_USED (u) = SYSTEM_STACK_USED; THREAD_STACK_OFFSET (u) = NO_BYTE; CUR_PTR (&STACK (u)) = stack_pointer; CUR_PTR (&FRAME (u)) = frame_pointer; INI_PTR (&STACK (u)) = sp0; INI_PTR (&FRAME (u)) = fp0; SWAP (&STACK (u)) = NO_BYTE; SWAP (&FRAME (u)) = NO_BYTE; START (&STACK (u)) = NO_BYTE; START (&FRAME (u)) = NO_BYTE; BYTES (&STACK (u)) = 0; BYTES (&FRAME (u)) = 0; ACTIVE (u) = A68_TRUE; /* Create the thread */ RESET_ERRNO; if (pthread_attr_init (&new_at) != 0) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_THREAD_FAULT); exit_genie (p, A68_RUNTIME_ERROR); } if (pthread_attr_setstacksize (&new_at, (size_t) stack_size) != 0) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_THREAD_FAULT); exit_genie (p, A68_RUNTIME_ERROR); } if (pthread_attr_getstacksize (&new_at, &ss) != 0) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_THREAD_FAULT); exit_genie (p, A68_RUNTIME_ERROR); } ABEND ((size_t) ss != (size_t) stack_size, "cannot set thread stack size", NO_TEXT); if (pthread_create (&new_id, &new_at, start_unit, NULL) != 0) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_PARALLEL_CANNOT_CREATE); exit_genie (p, A68_RUNTIME_ERROR); } PARENT (u) = parent; ID (u) = new_id; context_index++; save_stacks (new_id); } else { start_parallel_units (SUB (p), parent); } } } /*! \brief execute one unit from a PAR clause \param arg dummy argument **/ static void *start_genie_parallel (void *arg) { pthread_t t; int k; BYTE_T stack_offset; NODE_T *p; BOOL_T units_active; (void) arg; LOCK_THREAD; t = pthread_self (); GET_THREAD_INDEX (k, t); THREAD_STACK_OFFSET (&context[k]) = (BYTE_T *) (&stack_offset - stack_direction (&stack_offset) * STACK_USED (&context[k])); restore_stacks (t); p = (NODE_T *) (UNIT (&context[k])); /* This is the thread spawned by the main thread, we spawn parallel units and await their completion */ start_parallel_units (SUB (p), t); do { units_active = A68_FALSE; check_parallel_units (&units_active, pthread_self ()); if (units_active) { try_change_thread (p); } } while (units_active); genie_abend_thread (); return ((void *) NULL); } /*! \brief execute parallel clause \param p position in tree \return propagator for this routine **/ static PROP_T genie_parallel (NODE_T * p) { int j; ADDR_T stack_s = 0, frame_s = 0; BYTE_T *system_stack_offset_s = NO_BYTE; int save_par_level = running_par_level; running_par_level = PAR_LEVEL (p); if (is_main_thread ()) { /* Spawn first thread and await its completion */ pthread_attr_t new_at; size_t ss; BYTE_T stack_offset; A68_THREAD_CONTEXT *u; LOCK_THREAD; abend_all_threads = A68_FALSE; exit_from_threads = A68_FALSE; par_return_code = 0; sp0 = stack_s = stack_pointer; fp0 = frame_s = frame_pointer; system_stack_offset_s = system_stack_offset; context_index = 0; /* Set up a thread for this unit */ u = &(context[context_index]); UNIT (u) = p; STACK_USED (u) = SYSTEM_STACK_USED; THREAD_STACK_OFFSET (u) = NO_BYTE; CUR_PTR (&STACK (u)) = stack_pointer; CUR_PTR (&FRAME (u)) = frame_pointer; INI_PTR (&STACK (u)) = sp0; INI_PTR (&FRAME (u)) = fp0; SWAP (&STACK (u)) = NO_BYTE; SWAP (&FRAME (u)) = NO_BYTE; START (&STACK (u)) = NO_BYTE; START (&FRAME (u)) = NO_BYTE; BYTES (&STACK (u)) = 0; BYTES (&FRAME (u)) = 0; ACTIVE (u) = A68_TRUE; /* Spawn the first thread and join it to await its completion */ RESET_ERRNO; if (pthread_attr_init (&new_at) != 0) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_THREAD_FAULT); running_par_level = save_par_level; exit_genie (p, A68_RUNTIME_ERROR); } if (pthread_attr_setstacksize (&new_at, (size_t) stack_size) != 0) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_THREAD_FAULT); running_par_level = save_par_level; exit_genie (p, A68_RUNTIME_ERROR); } if (pthread_attr_getstacksize (&new_at, &ss) != 0) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_THREAD_FAULT); running_par_level = save_par_level; exit_genie (p, A68_RUNTIME_ERROR); } ABEND ((size_t) ss != (size_t) stack_size, "cannot set thread stack size", NO_TEXT); if (pthread_create (&parent_thread_id, &new_at, start_genie_parallel, NULL) != 0) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_PARALLEL_CANNOT_CREATE); running_par_level = save_par_level; exit_genie (p, A68_RUNTIME_ERROR); } if (errno != 0) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_THREAD_FAULT); running_par_level = save_par_level; exit_genie (p, A68_RUNTIME_ERROR); } PARENT (u) = main_thread_id; ID (u) = parent_thread_id; context_index++; save_stacks (parent_thread_id); UNLOCK_THREAD; if (pthread_join (parent_thread_id, NULL) != 0) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_THREAD_FAULT); running_par_level = save_par_level; exit_genie (p, A68_RUNTIME_ERROR); } /* The first spawned thread has completed, now clean up */ for (j = 0; j < context_index; j++) { if (ACTIVE (&context[j]) && ID (&context[j]) != main_thread_id && ID (&context[j]) != parent_thread_id) { /* If threads are zapped it is possible that some are active at this point! */ if (pthread_join (ID (&context[j]), NULL) != 0) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_THREAD_FAULT); running_par_level = save_par_level; exit_genie (p, A68_RUNTIME_ERROR); } } if (SWAP (&STACK (&context[j])) != NO_BYTE) { free (SWAP (&STACK (&context[j]))); SWAP (&STACK (&context[j])) = NO_BYTE; } if (SWAP (&STACK (&context[j])) != NO_BYTE) { free (SWAP (&STACK (&context[j]))); SWAP (&STACK (&context[j])) = NO_BYTE; } } /* Now every thread should have ended */ running_par_level = save_par_level; context_index = 0; stack_pointer = stack_s; frame_pointer = frame_s; get_stack_size (); system_stack_offset = system_stack_offset_s; /* See if we ended execution in parallel clause */ if (is_main_thread () && exit_from_threads) { exit_genie (p, par_return_code); } if (is_main_thread () && ERROR_COUNT (&program) > 0) { exit_genie (p, A68_RUNTIME_ERROR); } /* See if we jumped out of the parallel clause(s) */ if (is_main_thread () && abend_all_threads) { JUMP_TO (TABLE (TAX (jump_label))) = UNIT (TAX (jump_label)); longjmp (*(jump_buffer), 1); } } else { /* Not in the main thread, spawn parallel units and await completion */ BOOL_T units_active; pthread_t t = pthread_self (); /* Spawn parallel units */ start_parallel_units (SUB (p), t); do { units_active = A68_FALSE; check_parallel_units (&units_active, t); if (units_active) { try_change_thread (p); } } while (units_active); running_par_level = save_par_level; } return (GPROP (p)); } /*! \brief OP LEVEL = (INT) SEMA \param p position in tree **/ void genie_level_sema_int (NODE_T * p) { A68_INT k; A68_REF s; POP_OBJECT (p, &k, A68_INT); s = heap_generator (p, MODE (INT), ALIGNED_SIZE_OF (A68_INT)); * DEREF (A68_INT, &s) = k; PUSH_REF (p, s); } /*! \brief OP LEVEL = (SEMA) INT \param p position in tree **/ void genie_level_int_sema (NODE_T * p) { A68_REF s; POP_REF (p, &s); CHECK_INIT (p, INITIALISED (&s), MODE (SEMA)); PUSH_PRIMITIVE (p, VALUE (DEREF (A68_INT, &s)), A68_INT); } /*! \brief OP UP = (SEMA) VOID \param p position in tree **/ void genie_up_sema (NODE_T * p) { A68_REF s; if (is_main_thread ()) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_PARALLEL_OUTSIDE); exit_genie (p, A68_RUNTIME_ERROR); } POP_REF (p, &s); CHECK_INIT (p, INITIALISED (&s), MODE (SEMA)); VALUE (DEREF (A68_INT, &s))++; } /*! \brief OP DOWN = (SEMA) VOID \param p position in tree **/ void genie_down_sema (NODE_T * p) { A68_REF s; A68_INT *k; BOOL_T cont = A68_TRUE; if (is_main_thread ()) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_PARALLEL_OUTSIDE); exit_genie (p, A68_RUNTIME_ERROR); } POP_REF (p, &s); CHECK_INIT (p, INITIALISED (&s), MODE (SEMA)); while (cont) { k = DEREF (A68_INT, &s); if (VALUE (k) <= 0) { save_stacks (pthread_self ()); while (VALUE (k) <= 0) { if (ERROR_COUNT (&program) > 0 || abend_all_threads) { genie_abend_thread (); } UNLOCK_THREAD; /* Waiting a bit relaxes overhead */ ASSERT (usleep (10) == 0); LOCK_THREAD; /* Garbage may be collected, so recalculate 'k' */ k = DEREF (A68_INT, &s); } restore_stacks (pthread_self ()); cont = A68_TRUE; } else { VALUE (k)--; cont = A68_FALSE; } } } #endif algol68g-2.4.1/source/syntax.c0000644000175000001440000156470311767464642013111 00000000000000/*! \file syntax.c \brief hand-coded Algol 68 scanner and parser */ /* This file is part of Algol68G - an Algol 68 interpreter. Copyright (C) 2001-2012 J. Marcel van der Veer . 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 . */ /* AN EFFECTIVE ALGOL 68 PARSER Algol 68 grammar is defined as a two level (Van Wijngaarden) grammar that incorporates, as syntactical rules, the "semantical" rules in other languages. Examples are correct use of symbols, modes and scope. That is why so much functionality is in the "syntax.c" file. In fact, all this material constitutes an effective "Algol 68 VW parser". This pragmatic approach was chosen since in the early days of Algol 68, many "ab initio" implementations failed. This is a Mailloux-type parser, in the sense that it scans a "phrase" for definitions before it starts parsing, and therefore allows for tags to be used before they are defined, which gives some freedom in top-down programming. In 2011, FLACC documentation became available again. This documentation suggests that the set-up of this parser resembles that of FLACC, which supports the view that this is a Mailloux-type parser. First part in this file is the scanner. The source file is read, is tokenised, and if needed a refinement preprocessor elaborates a stepwise refined program. The result is a linear list of tokens that is input for the parser, that will transform the linear list into a syntax tree. Algol68G tokenises all symbols before the bottom-up parser is invoked. This means that scanning does not use information from the parser. The scanner does of course do some rudimentary parsing. Format texts can have enclosed clauses in them, so we record information in a stack as to know what is being scanned. Also, the refinement preprocessor implements a (trivial) grammar. The scanner supports two stropping regimes: bold and quote. Examples of both: bold stropping: BEGIN INT i = 1, j = 1; print (i + j) END quote stropping: 'BEGIN' 'INT' I = 1, J = 1; PRINT (I + J) 'END' Quote stropping was used frequently in the (excusez-le-mot) punch-card age. Hence, bold stropping is the default. There also existed point stropping, but that has not been implemented here. Next part of the parser is a recursive-descent type to check parenthesis. Also a first set-up is made of symbol tables, needed by the bottom-up parser. Next part is the bottom-up parser, that parses without knowing about modes while parsing and reducing. It can therefore not exchange "[]" with "()" as was blessed by the Revised Report. This is solved by treating CALL and SLICE as equivalent for the moment and letting the mode checker sort it out later. Parsing progresses in various phases to avoid spurious diagnostics from a recovering parser. Every phase "tightens" the grammar more. An error in any phase makes the parser quit when that phase ends. The parser is forgiving in case of superfluous semicolons. So those are the parser phases: (1) Parenthesis are checked to see whether they match. Then, a top-down parser determines the basic-block structure of the program so symbol tables can be set up that the bottom-up parser will consult as you can define things before they are applied. (2) A bottom-up parser resolvea the structure of the program. (3) After the symbol tables have been finalised, a small rearrangement of the tree may be required where JUMPs have no GOTO. This leads to the non-standard situation that JUMPs without GOTO can have the syntactic position of a PRIMARY, SECONDARY or TERTIARY. The bottom-up parser also does not check VICTAL correctness of declarers. This is done separately. Also structure of format texts is checked separately. The parser sets up symbol tables and populates them as far as needed to parse the source. After the bottom-up parser terminates succesfully, the symbol tables are completed. (4) Next, modes are collected and rules for well-formedness and structural equivalence are applied. Then the symbol-table is completed now moids are all known. (5) Next phases are the mode checker and coercion inserter. The syntax tree is traversed to determine and check all modes, and to select operators. Then the tree is traversed again to insert coercions. (6) A static scope checker detects where objects are transported out of scope. At run time, a dynamic scope checker will check that what the static scope checker cannot see. With respect to the mode checker: Algol 68 contexts are SOFT, WEAK, MEEK, FIRM and STRONG. These contexts are increasing in strength: SOFT: Deproceduring WEAK: Dereferencing to REF [] or REF STRUCT MEEK: Deproceduring and dereferencing FIRM: MEEK followed by uniting STRONG: FIRM followed by rowing, widening or voiding Furthermore you will see in this file next switches: (1) FORCE_DEFLEXING allows assignment compatibility between FLEX and non FLEX rows. This can only be the case when there is no danger of altering bounds of a non FLEX row. (2) ALIAS_DEFLEXING prohibits aliasing a FLEX row to a non FLEX row (vice versa is no problem) so that one cannot alter the bounds of a non FLEX row by aliasing it to a FLEX row. This is particularly the case when passing names as parameters to procedures: PROC x = (REF STRING s) VOID: ..., PROC y = (REF [] CHAR c) VOID: ...; x (LOC STRING); # OK # x (LOC [10] CHAR); # Not OK, suppose x changes bounds of s! # y (LOC STRING); # OK # y (LOC [10] CHAR); # OK # (3) SAFE_DEFLEXING sets FLEX row apart from non FLEX row. This holds for names, not for values, so common things are not rejected, for instance STRING x = read string; [] CHAR y = read string (4) NO_DEFLEXING sets FLEX row apart from non FLEX row. Finally, a static scope checker inspects the source. Note that Algol 68 also needs dynamic scope checking. This phase concludes the parser. */ #if defined HAVE_CONFIG_H #include "a68g-config.h" #endif #include "a68g.h" static MOID_T *get_mode_from_declarer (NODE_T *); BOOL_T check_yin_yang (NODE_T *, MOID_T *, BOOL_T, BOOL_T); typedef struct TUPLE_T TUPLE_T; typedef struct SCOPE_T SCOPE_T; struct TUPLE_T { int level; BOOL_T transient; }; struct SCOPE_T { NODE_T *where; TUPLE_T tuple; SCOPE_T *next; }; enum { NOT_TRANSIENT = 0, TRANSIENT }; static void gather_scopes_for_youngest (NODE_T *, SCOPE_T **); static void scope_statement (NODE_T *, SCOPE_T **); static void scope_enclosed_clause (NODE_T *, SCOPE_T **); static void scope_formula (NODE_T *, SCOPE_T **); static void scope_routine_text (NODE_T *, SCOPE_T **); TAG_T *error_tag; static SOID_T *top_soid_list = NO_SOID; static BOOL_T basic_coercions (MOID_T *, MOID_T *, int, int); static BOOL_T is_coercible (MOID_T *, MOID_T *, int, int); static BOOL_T is_nonproc (MOID_T *); static void mode_check_enclosed (NODE_T *, SOID_T *, SOID_T *); static void mode_check_unit (NODE_T *, SOID_T *, SOID_T *); static void mode_check_formula (NODE_T *, SOID_T *, SOID_T *); static void coerce_enclosed (NODE_T *, SOID_T *); static void coerce_operand (NODE_T *, SOID_T *); static void coerce_formula (NODE_T *, SOID_T *); static void coerce_unit (NODE_T *, SOID_T *); #define DEPREF A68_TRUE #define NO_DEPREF A68_FALSE #define IF_MODE_IS_WELL(n) (! ((n) == MODE (ERROR) || (n) == MODE (UNDEFINED))) #define INSERT_COERCIONS(n, p, q) make_strong ((n), (p), MOID (q)) #define STOP_CHAR 127 #define IN_PRELUDE(p) (LINE_NUMBER (p) <= 0) #define EOL(c) ((c) == NEWLINE_CHAR || (c) == NULL_CHAR) static BOOL_T stop_scanner = A68_FALSE, read_error = A68_FALSE, no_preprocessing = A68_FALSE; static char *scan_buf; static int max_scan_buf_length, source_file_size; static int reductions = 0; static jmp_buf bottom_up_crash_exit, top_down_crash_exit; static BOOL_T victal_check_declarer (NODE_T *, int); static NODE_T *reduce_dyadic (NODE_T *, int u); static NODE_T *top_down_loop (NODE_T *); static NODE_T *top_down_skip_unit (NODE_T *); static void append_source_line (char *, LINE_T **, int *, char *); static void elaborate_bold_tags (NODE_T *); static void extract_declarations (NODE_T *); static void extract_identities (NODE_T *); static void extract_indicants (NODE_T *); static void extract_labels (NODE_T *, int); static void extract_operators (NODE_T *); static void extract_priorities (NODE_T *); static void extract_proc_identities (NODE_T *); static void extract_proc_variables (NODE_T *); static void extract_variables (NODE_T *); static void ignore_superfluous_semicolons (NODE_T *); static void recover_from_error (NODE_T *, int, BOOL_T); static void reduce_arguments (NODE_T *); static void reduce_basic_declarations (NODE_T *); static void reduce_bounds (NODE_T *); static void reduce_collateral_clauses (NODE_T *); static void reduce_declaration_lists (NODE_T *); static void reduce_declarers (NODE_T *, int); static void reduce_enclosed_clauses (NODE_T *, int); static void reduce_enquiry_clauses (NODE_T *); static void reduce_erroneous_units (NODE_T *); static void reduce_format_texts (NODE_T *); static void reduce_formulae (NODE_T *); static void reduce_generic_arguments (NODE_T *); static void reduce_primaries (NODE_T *, int); static void reduce_primary_parts (NODE_T *, int); static void reduce_right_to_left_constructs (NODE_T * q); static void reduce_secondaries (NODE_T *); static void reduce_serial_clauses (NODE_T *); static void reduce_branch (NODE_T *, int); static void reduce_tertiaries (NODE_T *); static void reduce_units (NODE_T *); static void reduce (NODE_T *, void (*)(NODE_T *), BOOL_T *, ...); /* Standard environ */ static char *bold_prelude_start[] = { "BEGIN MODE DOUBLE = LONG REAL, QUAD = LONG LONG REAL;", " start: commence:", " BEGIN", NO_TEXT }; static char *bold_postlude[] = { " END;", " stop: abort: halt: SKIP", "END", NO_TEXT }; static char *quote_prelude_start[] = { "'BEGIN' 'MODE' 'DOUBLE' = 'LONG' 'REAL'," " 'QUAD' = 'LONG' 'LONG' 'REAL'," " 'DEVICE' = 'FILE'," " 'TEXT' = 'STRING';" " START: COMMENCE:" " 'BEGIN'", NO_TEXT }; static char *quote_postlude[] = { " 'END';", " STOP: ABORT: HALT: 'SKIP'", "'END'", NO_TEXT }; /*! \brief is_ref_refety_flex \param m mode under test \return same **/ static BOOL_T is_ref_refety_flex (MOID_T * m) { if (IS_REF_FLEX (m)) { return (A68_TRUE); } else if (IS (m, REF_SYMBOL)) { return (is_ref_refety_flex (SUB (m))); } else { return (A68_FALSE); } } /*! \brief count pictures \param p position in tree \param k counter **/ static void count_pictures (NODE_T * p, int *k) { for (; p != NO_NODE; FORWARD (p)) { if (IS (p, PICTURE)) { (*k)++; } count_pictures (SUB (p), k); } } /*! \brief count number of operands in operator parameter list \param p position in tree \return same **/ static int count_operands (NODE_T * p) { if (p != NO_NODE) { if (IS (p, DECLARER)) { return (count_operands (NEXT (p))); } else if (IS (p, COMMA_SYMBOL)) { return (1 + count_operands (NEXT (p))); } else { return (count_operands (NEXT (p)) + count_operands (SUB (p))); } } else { return (0); } } /*! \brief count formal bounds in declarer in tree \param p position in tree \return same **/ static int count_formal_bounds (NODE_T * p) { if (p == NO_NODE) { return (0); } else { if (IS (p, COMMA_SYMBOL)) { return (1); } else { return (count_formal_bounds (NEXT (p)) + count_formal_bounds (SUB (p))); } } } /*! \brief count bounds in declarer in tree \param p position in tree \return same **/ static int count_bounds (NODE_T * p) { if (p == NO_NODE) { return (0); } else { if (IS (p, BOUND)) { return (1 + count_bounds (NEXT (p))); } else { return (count_bounds (NEXT (p)) + count_bounds (SUB (p))); } } } /*! \brief count number of SHORTs or LONGs \param p position in tree \return same **/ static int count_sizety (NODE_T * p) { if (p == NO_NODE) { return (0); } else if (IS (p, LONGETY)) { return (count_sizety (SUB (p)) + count_sizety (NEXT (p))); } else if (IS (p, SHORTETY)) { return (count_sizety (SUB (p)) + count_sizety (NEXT (p))); } else if (IS (p, LONG_SYMBOL)) { return (1); } else if (IS (p, SHORT_SYMBOL)) { return (-1); } else { return (0); } } /*! \brief count moids in a pack \param u pack \return same **/ int count_pack_members (PACK_T * u) { int k = 0; for (; u != NO_PACK; FORWARD (u)) { k++; } return (k); } /*! \brief replace a mode by its equivalent mode \param m mode to replace **/ static void resolve_equivalent (MOID_T ** m) { while ((*m) != NO_MOID && EQUIVALENT ((*m)) != NO_MOID && (*m) != EQUIVALENT (*m)) { (*m) = EQUIVALENT (*m); } } /*! \brief save scanner state, for character look-ahead \param ref_l source line \param ref_s position in source line text \param ch last scanned character **/ static void save_state (LINE_T * ref_l, char *ref_s, char ch) { SCAN_STATE_L (&program) = ref_l; SCAN_STATE_S (&program) = ref_s; SCAN_STATE_C (&program) = ch; } /*! \brief restore scanner state, for character look-ahead \param ref_l source line \param ref_s position in source line text \param ch last scanned character **/ static void restore_state (LINE_T ** ref_l, char **ref_s, char *ch) { *ref_l = SCAN_STATE_L (&program); *ref_s = SCAN_STATE_S (&program); *ch = SCAN_STATE_C (&program); } /**************************************/ /* Scanner, tokenises the source code */ /**************************************/ /*! \brief whether ch is unworthy \param u source line with error \param v character in line \param ch **/ static void unworthy (LINE_T * u, char *v, char ch) { if (IS_PRINT (ch)) { ASSERT (snprintf (edit_line, SNPRINTF_SIZE, "%s", ERROR_UNWORTHY_CHARACTER) >= 0); } else { ASSERT (snprintf (edit_line, SNPRINTF_SIZE, "%s %s", ERROR_UNWORTHY_CHARACTER, ctrl_char (ch)) >= 0); } scan_error (u, v, edit_line); } /*! \brief concatenate lines that terminate in '\' with next line \param top top source line **/ static void concatenate_lines (LINE_T * top) { LINE_T *q; /* Work from bottom backwards */ for (q = top; q != NO_LINE && NEXT (q) != NO_LINE; q = NEXT (q)) { ; } for (; q != NO_LINE; BACKWARD (q)) { char *z = STRING (q); int len = (int) strlen (z); if (len >= 2 && z[len - 2] == BACKSLASH_CHAR && z[len - 1] == NEWLINE_CHAR && NEXT (q) != NO_LINE && STRING (NEXT (q)) != NO_TEXT) { z[len - 2] = NULL_CHAR; len += (int) strlen (STRING (NEXT (q))); z = (char *) get_fixed_heap_space ((size_t) (len + 1)); bufcpy (z, STRING (q), len + 1); bufcat (z, STRING (NEXT (q)), len + 1); STRING (NEXT (q))[0] = NULL_CHAR; STRING (q) = z; } } } /*! \brief whether u is bold tag v, independent of stropping regime \param z source line \param u symbol under test \param v bold symbol \return whether u is v **/ static BOOL_T is_bold (char *u, char *v) { unsigned len = (unsigned) strlen (v); if (OPTION_STROPPING (&program) == QUOTE_STROPPING) { if (u[0] == '\'') { return ((BOOL_T) (strncmp (++u, v, len) == 0 && u[len] == '\'')); } else { return (A68_FALSE); } } else { return ((BOOL_T) (strncmp (u, v, len) == 0 && !IS_UPPER (u[len]))); } } /*! \brief skip string \param top current source line \param ch current character in source line \return whether string is properly terminated **/ static BOOL_T skip_string (LINE_T ** top, char **ch) { LINE_T *u = *top; char *v = *ch; v++; while (u != NO_LINE) { while (v[0] != NULL_CHAR) { if (v[0] == QUOTE_CHAR && v[1] != QUOTE_CHAR) { *top = u; *ch = &v[1]; return (A68_TRUE); } else if (v[0] == QUOTE_CHAR && v[1] == QUOTE_CHAR) { v += 2; } else { v++; } } FORWARD (u); if (u != NO_LINE) { v = &(STRING (u)[0]); } else { v = NO_TEXT; } } return (A68_FALSE); } /*! \brief skip comment \param top current source line \param ch current character in source line \param delim expected terminating delimiter \return whether comment is properly terminated **/ static BOOL_T skip_comment (LINE_T ** top, char **ch, int delim) { LINE_T *u = *top; char *v = *ch; v++; while (u != NO_LINE) { while (v[0] != NULL_CHAR) { if (is_bold (v, "COMMENT") && delim == BOLD_COMMENT_SYMBOL) { *top = u; *ch = &v[1]; return (A68_TRUE); } else if (is_bold (v, "CO") && delim == STYLE_I_COMMENT_SYMBOL) { *top = u; *ch = &v[1]; return (A68_TRUE); } else if (v[0] == '#' && delim == STYLE_II_COMMENT_SYMBOL) { *top = u; *ch = &v[1]; return (A68_TRUE); } else { v++; } } FORWARD (u); if (u != NO_LINE) { v = &(STRING (u)[0]); } else { v = NO_TEXT; } } return (A68_FALSE); } /*! \brief skip rest of pragmat \param top current source line \param ch current character in source line \param delim expected terminating delimiter \param whitespace whether other pragmat items are allowed \return whether pragmat is properly terminated **/ static BOOL_T skip_pragmat (LINE_T ** top, char **ch, int delim, BOOL_T whitespace) { LINE_T *u = *top; char *v = *ch; while (u != NO_LINE) { while (v[0] != NULL_CHAR) { if (is_bold (v, "PRAGMAT") && delim == BOLD_PRAGMAT_SYMBOL) { *top = u; *ch = &v[1]; return (A68_TRUE); } else if (is_bold (v, "PR") && delim == STYLE_I_PRAGMAT_SYMBOL) { *top = u; *ch = &v[1]; return (A68_TRUE); } else { if (whitespace && !IS_SPACE (v[0]) && v[0] != NEWLINE_CHAR) { scan_error (u, v, ERROR_PRAGMENT); } else if (IS_UPPER (v[0])) { /* Skip a bold word as you may trigger on REPR, for instance .. */ while (IS_UPPER (v[0])) { v++; } } else { v++; } } } FORWARD (u); if (u != NO_LINE) { v = &(STRING (u)[0]); } else { v = NO_TEXT; } } return (A68_FALSE); } /*! \brief return pointer to next token within pragmat \param top current source line \param ch current character in source line \return pointer to next item, NO_TEXT if none remains **/ static char *get_pragmat_item (LINE_T ** top, char **ch) { LINE_T *u = *top; char *v = *ch; while (u != NO_LINE) { while (v[0] != NULL_CHAR) { if (!IS_SPACE (v[0]) && v[0] != NEWLINE_CHAR) { *top = u; *ch = v; return (v); } else { v++; } } FORWARD (u); if (u != NO_LINE) { v = &(STRING (u)[0]); } else { v = NO_TEXT; } } return (NO_TEXT); } /*! \brief case insensitive strncmp for at most the number of chars in 'v' \param u string 1, must not be NO_TEXT \param v string 2, must not be NO_TEXT \return alphabetic difference between 1 and 2 **/ static int streq (char *u, char *v) { int diff; for (diff = 0; diff == 0 && u[0] != NULL_CHAR && v[0] != NULL_CHAR; u++, v++) { diff = ((int) TO_LOWER (u[0])) - ((int) TO_LOWER (v[0])); } return (diff); } /*! \brief scan for next pragmat and yield first pragmat item \param top current source line \param ch current character in source line \param delim expected terminating delimiter \return pointer to next item or NO_TEXT if none remain **/ static char *next_preprocessor_item (LINE_T ** top, char **ch, int *delim) { LINE_T *u = *top; char *v = *ch; *delim = 0; while (u != NO_LINE) { while (v[0] != NULL_CHAR) { LINE_T *start_l = u; char *start_c = v; /* STRINGs must be skipped */ if (v[0] == QUOTE_CHAR) { SCAN_ERROR (!skip_string (&u, &v), start_l, start_c, ERROR_UNTERMINATED_STRING); } /* COMMENTS must be skipped */ else if (is_bold (v, "COMMENT")) { SCAN_ERROR (!skip_comment (&u, &v, BOLD_COMMENT_SYMBOL), start_l, start_c, ERROR_UNTERMINATED_COMMENT); } else if (is_bold (v, "CO")) { SCAN_ERROR (!skip_comment (&u, &v, STYLE_I_COMMENT_SYMBOL), start_l, start_c, ERROR_UNTERMINATED_COMMENT); } else if (v[0] == '#') { SCAN_ERROR (!skip_comment (&u, &v, STYLE_II_COMMENT_SYMBOL), start_l, start_c, ERROR_UNTERMINATED_COMMENT); } else if (is_bold (v, "PRAGMAT") || is_bold (v, "PR")) { /* We caught a PRAGMAT */ char *item; if (is_bold (v, "PRAGMAT")) { *delim = BOLD_PRAGMAT_SYMBOL; v = &v[strlen ("PRAGMAT")]; } else if (is_bold (v, "PR")) { *delim = STYLE_I_PRAGMAT_SYMBOL; v = &v[strlen ("PR")]; } item = get_pragmat_item (&u, &v); SCAN_ERROR (item == NO_TEXT, start_l, start_c, ERROR_UNTERMINATED_PRAGMAT); /* Item "preprocessor" restarts preprocessing if it is off */ if (no_preprocessing && streq (item, "PREPROCESSOR") == 0) { no_preprocessing = A68_FALSE; SCAN_ERROR (!skip_pragmat (&u, &v, *delim, A68_TRUE), start_l, start_c, ERROR_UNTERMINATED_PRAGMAT); } /* If preprocessing is switched off, we idle to closing bracket */ else if (no_preprocessing) { SCAN_ERROR (!skip_pragmat (&u, &v, *delim, A68_FALSE), start_l, start_c, ERROR_UNTERMINATED_PRAGMAT); } /* Item "nopreprocessor" stops preprocessing if it is on */ if (streq (item, "NOPREPROCESSOR") == 0) { no_preprocessing = A68_TRUE; SCAN_ERROR (!skip_pragmat (&u, &v, *delim, A68_TRUE), start_l, start_c, ERROR_UNTERMINATED_PRAGMAT); } /* Item "INCLUDE" includes a file */ else if (streq (item, "INCLUDE") == 0) { *top = u; *ch = v; return (item); } /* Item "READ" includes a file */ else if (streq (item, "READ") == 0) { *top = u; *ch = v; return (item); } /* Unrecognised item - probably options handled later by the tokeniser */ else { SCAN_ERROR (!skip_pragmat (&u, &v, *delim, A68_FALSE), start_l, start_c, ERROR_UNTERMINATED_PRAGMAT); } } else if (IS_UPPER (v[0])) { /* Skip a bold word as you may trigger on REPR, for instance .. */ while (IS_UPPER (v[0])) { v++; } } else { v++; } } FORWARD (u); if (u != NO_LINE) { v = &(STRING (u)[0]); } else { v = NO_TEXT; } } *top = u; *ch = v; return (NO_TEXT); } /*! \brief include files \param top top source line **/ static void include_files (LINE_T * top) { /* include_files syntax: PR read "filename" PR PR include "filename" PR The file gets inserted before the line containing the pragmat. In this way correct line numbers are preserved which helps diagnostics. A file that has been included will not be included a second time - it will be ignored. */ BOOL_T make_pass = A68_TRUE; while (make_pass) { LINE_T *s, *t, *u = top; char *v = &(STRING (u)[0]); make_pass = A68_FALSE; RESET_ERRNO; while (u != NO_LINE) { int pr_lim; char *item = next_preprocessor_item (&u, &v, &pr_lim); LINE_T *start_l = u; char *start_c = v; /* Search for PR include "filename" PR */ if (item != NO_TEXT && (streq (item, "INCLUDE") == 0 || streq (item, "READ") == 0)) { FILE_T fd; int n, linum, fsize, k, bytes_read, fnwid; char *fbuf, delim; char fnb[BUFFER_SIZE], *fn; /* Skip to filename */ if (streq (item, "INCLUDE") == 0) { v = &v[strlen ("INCLUDE")]; } else { v = &v[strlen ("READ")]; } while (IS_SPACE (v[0])) { v++; } /* Scan quoted filename */ SCAN_ERROR ((v[0] != QUOTE_CHAR && v[0] != '\''), start_l, start_c, ERROR_INCORRECT_FILENAME); delim = (v++)[0]; n = 0; fnb[0] = NULL_CHAR; /* Scan Algol 68 string (note: "" denotes a ", while in C it concatenates).*/ do { SCAN_ERROR (EOL (v[0]), start_l, start_c, ERROR_INCORRECT_FILENAME); SCAN_ERROR (n == BUFFER_SIZE - 1, start_l, start_c, ERROR_INCORRECT_FILENAME); if (v[0] == delim) { while (v[0] == delim && v[1] == delim) { SCAN_ERROR (n == BUFFER_SIZE - 1, start_l, start_c, ERROR_INCORRECT_FILENAME); fnb[n++] = delim; fnb[n] = NULL_CHAR; v += 2; } } else if (IS_PRINT (v[0])) { fnb[n++] = *(v++); fnb[n] = NULL_CHAR; } else { SCAN_ERROR (A68_TRUE, start_l, start_c, ERROR_INCORRECT_FILENAME); } } while (v[0] != delim); /* Insist that the pragmat is closed properly */ v = &v[1]; SCAN_ERROR (!skip_pragmat (&u, &v, pr_lim, A68_TRUE), start_l, start_c, ERROR_UNTERMINATED_PRAGMAT); /* Filename valid? */ SCAN_ERROR (n == 0, start_l, start_c, ERROR_INCORRECT_FILENAME); fnwid = (int) strlen (FILE_PATH (&program)) + (int) strlen (fnb) + 1; fn = (char *) get_fixed_heap_space ((size_t) fnwid); bufcpy (fn, FILE_PATH (&program), fnwid); bufcat (fn, fnb, fnwid); /* Recursive include? Then *ignore* the file */ for (t = top; t != NO_LINE; t = NEXT (t)) { if (strcmp (FILENAME (t), fn) == 0) { goto search_next_pragmat; /* Eeek! */ } } /* Access the file */ RESET_ERRNO; fd = open (fn, O_RDONLY | O_BINARY); SCAN_ERROR (fd == -1, start_l, start_c, ERROR_SOURCE_FILE_OPEN); /* Access the file */ RESET_ERRNO; fsize = (int) lseek (fd, 0, SEEK_END); ASSERT (fsize >= 0); SCAN_ERROR (errno != 0, start_l, start_c, ERROR_FILE_READ); fbuf = (char *) get_temp_heap_space ((unsigned) (8 + fsize)); RESET_ERRNO; ASSERT (lseek (fd, 0, SEEK_SET) >= 0); SCAN_ERROR (errno != 0, start_l, start_c, ERROR_FILE_READ); RESET_ERRNO; bytes_read = (int) io_read (fd, fbuf, (size_t) fsize); SCAN_ERROR (errno != 0 || bytes_read != fsize, start_l, start_c, ERROR_FILE_READ); /* Buffer still usable? */ if (fsize > max_scan_buf_length) { max_scan_buf_length = fsize; scan_buf = (char *) get_temp_heap_space ((unsigned) (8 + max_scan_buf_length)); } /* Link all lines into the list */ linum = 1; s = u; t = PREVIOUS (u); k = 0; if (fsize == 0) { /* If file is empty, insert single empty line */ scan_buf[0] = NEWLINE_CHAR; scan_buf[1] = NULL_CHAR; append_source_line (scan_buf, &t, &linum, fn); } else while (k < fsize) { n = 0; scan_buf[0] = NULL_CHAR; while (k < fsize && fbuf[k] != NEWLINE_CHAR) { SCAN_ERROR ((IS_CNTRL (fbuf[k]) && !IS_SPACE (fbuf[k])) || fbuf[k] == STOP_CHAR, start_l, start_c, ERROR_FILE_INCLUDE_CTRL); scan_buf[n++] = fbuf[k++]; scan_buf[n] = NULL_CHAR; } scan_buf[n++] = NEWLINE_CHAR; scan_buf[n] = NULL_CHAR; if (k < fsize) { k++; } append_source_line (scan_buf, &t, &linum, fn); } /* Conclude and go find another include directive, if any */ NEXT (t) = s; PREVIOUS (s) = t; concatenate_lines (top); ASSERT (close (fd) == 0); make_pass = A68_TRUE; } search_next_pragmat:/* skip */ ; } } } /*! \brief append a source line to the internal source file \param str text line to be appended \param ref_l previous source line \param line_num previous source line number \param filename name of file being read **/ static void append_source_line (char *str, LINE_T ** ref_l, int *line_num, char *filename) { LINE_T *z = new_source_line (); /* Allow shell command in first line, f.i. "#!/usr/share/bin/a68g" */ if (*line_num == 1) { if (strlen (str) >= 2 && strncmp (str, "#!", 2) == 0) { ABEND (strstr (str, "run-script") != NO_TEXT, ERROR_SHELL_SCRIPT, NO_TEXT); (*line_num)++; return; } } /* Link line into the chain */ STRING (z) = new_fixed_string (str); FILENAME (z) = filename; NUMBER (z) = (*line_num)++; PRINT_STATUS (z) = NOT_PRINTED; LIST (z) = A68_TRUE; DIAGNOSTICS (z) = NO_DIAGNOSTIC; NEXT (z) = NO_LINE; PREVIOUS (z) = *ref_l; if (TOP_LINE (&program) == NO_LINE) { TOP_LINE (&program) = z; } if (*ref_l != NO_LINE) { NEXT (*ref_l) = z; } *ref_l = z; } /*! \brief size of source file \return size of file **/ static int get_source_size (void) { FILE_T f = FILE_SOURCE_FD (&program); /* This is why WIN32 must open as "read binary" */ return ((int) lseek (f, 0, SEEK_END)); } /*! \brief append environment source lines \param str line to append \param ref_l source line after which to append \param line_num number of source line 'ref_l' \param name either "prelude" or "postlude" **/ static void append_environ (char *str[], LINE_T ** ref_l, int *line_num, char *name) { int k; for (k = 0; str[k] != NO_TEXT; k ++) { int zero_line_num = 0; (*line_num)++; append_source_line (str[k], ref_l, &zero_line_num, name); } /* char *text = new_string (str, NO_TEXT); while (text != NO_TEXT && text[0] != NULL_CHAR) { char *car = text; char *cdr = a68g_strchr (text, '!'); int zero_line_num = 0; cdr[0] = NULL_CHAR; text = &cdr[1]; (*line_num)++; ASSERT (snprintf (edit_line, SNPRINTF_SIZE, "%s\n", car) >= 0); append_source_line (edit_line, ref_l, &zero_line_num, name); } */ } /*! \brief read script file and make internal copy \return whether reading is satisfactory **/ static BOOL_T read_script_file (void) { LINE_T * ref_l = NO_LINE; int k, n, num; unsigned len; BOOL_T file_end = A68_FALSE; char filename[BUFFER_SIZE], linenum[BUFFER_SIZE]; char ch, * fn, * line; char * buffer = (char *) get_temp_heap_space ((unsigned) (8 + source_file_size)); FILE_T source = FILE_SOURCE_FD (&program); ABEND (source == -1, "source file not open", NO_TEXT); buffer[0] = NULL_CHAR; n = 0; len = (unsigned) (8 + source_file_size); buffer = (char *) get_temp_heap_space (len); ASSERT (lseek (source, 0, SEEK_SET) >= 0); while (!file_end) { /* Read the original file name */ filename[0] = NULL_CHAR; k = 0; if (io_read (source, &ch, 1) == 0) { file_end = A68_TRUE; continue; } while (ch != NEWLINE_CHAR) { filename[k++] = ch; ASSERT (io_read (source, &ch, 1) == 1); } filename[k] = NULL_CHAR; fn = TEXT (add_token (&top_token, filename)); /* Read the original file number */ linenum[0] = NULL_CHAR; k = 0; ASSERT (io_read (source, &ch, 1) == 1); while (ch != NEWLINE_CHAR) { linenum[k++] = ch; ASSERT (io_read (source, &ch, 1) == 1); } linenum[k] = NULL_CHAR; num = (int) strtol (linenum, NO_VAR, 10); ABEND (errno == ERANGE, "strange line number", NO_TEXT); /* COPY original line into buffer */ ASSERT (io_read (source, &ch, 1) == 1); line = &buffer[n]; while (ch != NEWLINE_CHAR) { buffer[n++] = ch; ASSERT (io_read (source, &ch, 1) == 1); ABEND ((unsigned) n >= len, "buffer overflow", NO_TEXT); } buffer[n++] = NEWLINE_CHAR; buffer[n] = NULL_CHAR; append_source_line (line, &ref_l, &num, fn); } return (A68_TRUE); } /*! \brief read source file and make internal copy \return whether reading is satisfactory **/ static BOOL_T read_source_file (void) { LINE_T *ref_l = NO_LINE; int line_num = 0, k, bytes_read; ssize_t l; FILE_T f = FILE_SOURCE_FD (&program); char **prelude_start, **postlude, *buffer; /* Prelude */ if (OPTION_STROPPING (&program) == UPPER_STROPPING) { prelude_start = bold_prelude_start; postlude = bold_postlude; } else if (OPTION_STROPPING (&program) == QUOTE_STROPPING) { prelude_start = quote_prelude_start; postlude = quote_postlude; } else { prelude_start = postlude = NO_VAR; } append_environ (prelude_start, &ref_l, &line_num, "prelude"); /* Read the file into a single buffer, so we save on system calls */ line_num = 1; buffer = (char *) get_temp_heap_space ((unsigned) (8 + source_file_size)); RESET_ERRNO; ASSERT (lseek (f, 0, SEEK_SET) >= 0); ABEND (errno != 0, "error while reading source file", NO_TEXT); RESET_ERRNO; bytes_read = (int) io_read (f, buffer, (size_t) source_file_size); ABEND (errno != 0 || bytes_read != source_file_size, "error while reading source file", NO_TEXT); /* Link all lines into the list */ k = 0; while (k < source_file_size) { l = 0; scan_buf[0] = NULL_CHAR; while (k < source_file_size && buffer[k] != NEWLINE_CHAR) { if (k < source_file_size - 1 && buffer[k] == CR_CHAR && buffer[k + 1] == NEWLINE_CHAR) { k++; } else { scan_buf[l++] = buffer[k++]; scan_buf[l] = NULL_CHAR; } } scan_buf[l++] = NEWLINE_CHAR; scan_buf[l] = NULL_CHAR; if (k < source_file_size) { k++; } append_source_line (scan_buf, &ref_l, &line_num, FILE_SOURCE_NAME (&program)); SCAN_ERROR (l != (ssize_t) strlen (scan_buf), NO_LINE, NO_TEXT, ERROR_FILE_SOURCE_CTRL); } /* Postlude */ append_environ (postlude, &ref_l, &line_num, "postlude"); /* Concatenate lines */ concatenate_lines (TOP_LINE (&program)); /* Include files */ include_files (TOP_LINE (&program)); return (A68_TRUE); } /*! \brief next_char get next character from internal copy of source file \param ref_l source line we're scanning \param ref_s character (in source line) we're scanning \param allow_typo whether typographical display features are allowed \return next char on input **/ static char next_char (LINE_T ** ref_l, char **ref_s, BOOL_T allow_typo) { char ch; #if defined NO_TYPO allow_typo = A68_FALSE; #endif LOW_STACK_ALERT (NO_NODE); /* Source empty? */ if (*ref_l == NO_LINE) { return (STOP_CHAR); } else { LIST (*ref_l) = (BOOL_T) (OPTION_NODEMASK (&program) & SOURCE_MASK ? A68_TRUE : A68_FALSE); /* Take new line? */ if ((*ref_s)[0] == NEWLINE_CHAR || (*ref_s)[0] == NULL_CHAR) { *ref_l = NEXT (*ref_l); if (*ref_l == NO_LINE) { return (STOP_CHAR); } *ref_s = STRING (*ref_l); } else { (*ref_s)++; } /* Deliver next char */ ch = (*ref_s)[0]; if (allow_typo && (IS_SPACE (ch) || ch == FORMFEED_CHAR)) { ch = next_char (ref_l, ref_s, allow_typo); } return (ch); } } /*! \brief find first character that can start a valid symbol \param ref_l source line we're scanning \param ref_s character (in source line) we're scanning **/ static void get_good_char (char *ref_c, LINE_T ** ref_l, char **ref_s) { while (*ref_c != STOP_CHAR && (IS_SPACE (*ref_c) || (*ref_c == NULL_CHAR))) { if (*ref_l != NO_LINE) { LIST (*ref_l) = (BOOL_T) (OPTION_NODEMASK (&program) & SOURCE_MASK ? A68_TRUE : A68_FALSE); } *ref_c = next_char (ref_l, ref_s, A68_FALSE); } } /*! \brief handle a pragment (pragmat or comment) \param type type of pragment (#, CO, COMMENT, PR, PRAGMAT) \param ref_l source line we're scanning \param ref_s character (in source line) we're scanning \return pragment text as a string for binding in the tree **/ static char *pragment (int type, LINE_T ** ref_l, char **ref_c) { #define INIT_BUFFER {chars_in_buf = 0; scan_buf[chars_in_buf] = NULL_CHAR;} #define ADD_ONE_CHAR(ch) {scan_buf[chars_in_buf ++] = ch; scan_buf[chars_in_buf] = NULL_CHAR;} char c = **ref_c, *term_s = NO_TEXT, *start_c = *ref_c; char *z; LINE_T *start_l = *ref_l; int term_s_length, chars_in_buf; BOOL_T stop, pragmat = A68_FALSE; /* Set terminator */ if (OPTION_STROPPING (&program) == UPPER_STROPPING) { if (type == STYLE_I_COMMENT_SYMBOL) { term_s = "CO"; } else if (type == STYLE_II_COMMENT_SYMBOL) { term_s = "#"; } else if (type == BOLD_COMMENT_SYMBOL) { term_s = "COMMENT"; } else if (type == STYLE_I_PRAGMAT_SYMBOL) { term_s = "PR"; pragmat = A68_TRUE; } else if (type == BOLD_PRAGMAT_SYMBOL) { term_s = "PRAGMAT"; pragmat = A68_TRUE; } } else if (OPTION_STROPPING (&program) == QUOTE_STROPPING) { if (type == STYLE_I_COMMENT_SYMBOL) { term_s = "'CO'"; } else if (type == STYLE_II_COMMENT_SYMBOL) { term_s = "#"; } else if (type == BOLD_COMMENT_SYMBOL) { term_s = "'COMMENT'"; } else if (type == STYLE_I_PRAGMAT_SYMBOL) { term_s = "'PR'"; pragmat = A68_TRUE; } else if (type == BOLD_PRAGMAT_SYMBOL) { term_s = "'PRAGMAT'"; pragmat = A68_TRUE; } } term_s_length = (int) strlen (term_s); /* Scan for terminator */ INIT_BUFFER; stop = A68_FALSE; while (stop == A68_FALSE) { SCAN_ERROR (c == STOP_CHAR, start_l, start_c, ERROR_UNTERMINATED_PRAGMENT); /* A ".." or '..' delimited string in a PRAGMAT */ if (pragmat && (c == QUOTE_CHAR || (c == '\'' && OPTION_STROPPING (&program) == UPPER_STROPPING))) { char delim = c; BOOL_T eos = A68_FALSE; ADD_ONE_CHAR (c); c = next_char (ref_l, ref_c, A68_FALSE); while (!eos) { SCAN_ERROR (EOL (c), start_l, start_c, ERROR_LONG_STRING); if (c == delim) { ADD_ONE_CHAR (delim); save_state (*ref_l, *ref_c, c); c = next_char (ref_l, ref_c, A68_FALSE); if (c == delim) { c = next_char (ref_l, ref_c, A68_FALSE); } else { restore_state (ref_l, ref_c, &c); eos = A68_TRUE; } } else if (IS_PRINT (c)) { ADD_ONE_CHAR (c); c = next_char (ref_l, ref_c, A68_FALSE); } else { unworthy (start_l, start_c, c); } } } else if (EOL (c)) { ADD_ONE_CHAR (NEWLINE_CHAR); } else if (IS_PRINT (c) || IS_SPACE (c)) { ADD_ONE_CHAR (c); } if (chars_in_buf >= term_s_length) { /* Check whether we encountered the terminator */ stop = (BOOL_T) (strcmp (term_s, &(scan_buf[chars_in_buf - term_s_length])) == 0); } c = next_char (ref_l, ref_c, A68_FALSE); } scan_buf[chars_in_buf - term_s_length] = NULL_CHAR; z = new_string (term_s, scan_buf, term_s, NO_TEXT); if (type == STYLE_I_PRAGMAT_SYMBOL || type == BOLD_PRAGMAT_SYMBOL) { isolate_options (scan_buf, start_l); } return (z); #undef ADD_ONE_CHAR #undef INIT_BUFFER } /*! \brief attribute for format item \param ch format item in character form \return same **/ static int get_format_item (char ch) { switch (TO_LOWER (ch)) { case 'a': { return (FORMAT_ITEM_A); } case 'b': { return (FORMAT_ITEM_B); } case 'c': { return (FORMAT_ITEM_C); } case 'd': { return (FORMAT_ITEM_D); } case 'e': { return (FORMAT_ITEM_E); } case 'f': { return (FORMAT_ITEM_F); } case 'g': { return (FORMAT_ITEM_G); } case 'h': { return (FORMAT_ITEM_H); } case 'i': { return (FORMAT_ITEM_I); } case 'j': { return (FORMAT_ITEM_J); } case 'k': { return (FORMAT_ITEM_K); } case 'l': case '/': { return (FORMAT_ITEM_L); } case 'm': { return (FORMAT_ITEM_M); } case 'n': { return (FORMAT_ITEM_N); } case 'o': { return (FORMAT_ITEM_O); } case 'p': { return (FORMAT_ITEM_P); } case 'q': { return (FORMAT_ITEM_Q); } case 'r': { return (FORMAT_ITEM_R); } case 's': { return (FORMAT_ITEM_S); } case 't': { return (FORMAT_ITEM_T); } case 'u': { return (FORMAT_ITEM_U); } case 'v': { return (FORMAT_ITEM_V); } case 'w': { return (FORMAT_ITEM_W); } case 'x': { return (FORMAT_ITEM_X); } case 'y': { return (FORMAT_ITEM_Y); } case 'z': { return (FORMAT_ITEM_Z); } case '+': { return (FORMAT_ITEM_PLUS); } case '-': { return (FORMAT_ITEM_MINUS); } case POINT_CHAR: { return (FORMAT_ITEM_POINT); } case '%': { return (FORMAT_ITEM_ESCAPE); } default: { return (0); } } } /* Macros */ #define SCAN_DIGITS(c)\ while (IS_DIGIT (c)) {\ (sym++)[0] = (c);\ (c) = next_char (ref_l, ref_s, A68_TRUE);\ } #define SCAN_EXPONENT_PART(c)\ (sym++)[0] = EXPONENT_CHAR;\ (c) = next_char (ref_l, ref_s, A68_TRUE);\ if ((c) == '+' || (c) == '-') {\ (sym++)[0] = (c);\ (c) = next_char (ref_l, ref_s, A68_TRUE);\ }\ SCAN_ERROR (!IS_DIGIT (c), *start_l, *start_c, ERROR_EXPONENT_DIGIT);\ SCAN_DIGITS (c) /*! \brief whether input shows exponent character \param m module that reads source \param ref_l source line we're scanning \param ref_s character (in source line) we're scanning \param ch last scanned char \return same **/ static BOOL_T is_exp_char (LINE_T ** ref_l, char **ref_s, char *ch) { BOOL_T ret = A68_FALSE; char exp_syms[3]; if (OPTION_STROPPING (&program) == UPPER_STROPPING) { exp_syms[0] = EXPONENT_CHAR; exp_syms[1] = (char) TO_UPPER (EXPONENT_CHAR); exp_syms[2] = NULL_CHAR; } else { exp_syms[0] = (char) TO_UPPER (EXPONENT_CHAR); exp_syms[1] = BACKSLASH_CHAR; exp_syms[2] = NULL_CHAR; } save_state (*ref_l, *ref_s, *ch); if (strchr (exp_syms, *ch) != NO_TEXT) { *ch = next_char (ref_l, ref_s, A68_TRUE); ret = (BOOL_T) (strchr ("+-0123456789", *ch) != NO_TEXT); } restore_state (ref_l, ref_s, ch); return (ret); } /*! \brief whether input shows radix character \param m module that reads source \param ref_l source line we're scanning \param ref_s character (in source line) we're scanning \return same **/ static BOOL_T is_radix_char (LINE_T ** ref_l, char **ref_s, char *ch) { BOOL_T ret = A68_FALSE; save_state (*ref_l, *ref_s, *ch); if (OPTION_STROPPING (&program) == QUOTE_STROPPING) { if (*ch == TO_UPPER (RADIX_CHAR)) { *ch = next_char (ref_l, ref_s, A68_TRUE); ret = (BOOL_T) (strchr ("0123456789ABCDEF", *ch) != NO_TEXT); } } else { if (*ch == RADIX_CHAR) { *ch = next_char (ref_l, ref_s, A68_TRUE); ret = (BOOL_T) (strchr ("0123456789abcdef", *ch) != NO_TEXT); } } restore_state (ref_l, ref_s, ch); return (ret); } /*! \brief whether input shows decimal point \param m module that reads source \param ref_l source line we're scanning \param ref_s character (in source line) we're scanning \return same **/ static BOOL_T is_decimal_point (LINE_T ** ref_l, char **ref_s, char *ch) { BOOL_T ret = A68_FALSE; save_state (*ref_l, *ref_s, *ch); if (*ch == POINT_CHAR) { char exp_syms[3]; if (OPTION_STROPPING (&program) == UPPER_STROPPING) { exp_syms[0] = EXPONENT_CHAR; exp_syms[1] = (char) TO_UPPER (EXPONENT_CHAR); exp_syms[2] = NULL_CHAR; } else { exp_syms[0] = (char) TO_UPPER (EXPONENT_CHAR); exp_syms[1] = BACKSLASH_CHAR; exp_syms[2] = NULL_CHAR; } *ch = next_char (ref_l, ref_s, A68_TRUE); if (strchr (exp_syms, *ch) != NO_TEXT) { *ch = next_char (ref_l, ref_s, A68_TRUE); ret = (BOOL_T) (strchr ("+-0123456789", *ch) != NO_TEXT); } else { ret = (BOOL_T) (strchr ("0123456789", *ch) != NO_TEXT); } } restore_state (ref_l, ref_s, ch); return (ret); } /*! \brief get next token from internal copy of source file. \param in_format are we scanning a format text \param ref_l source line we're scanning \param ref_s character (in source line) we're scanning \param start_l line where token starts \param start_c character where token starts \param att attribute designated to token **/ static void get_next_token (BOOL_T in_format, LINE_T ** ref_l, char **ref_s, LINE_T ** start_l, char **start_c, int *att) { char c = **ref_s, *sym = scan_buf; sym[0] = NULL_CHAR; get_good_char (&c, ref_l, ref_s); *start_l = *ref_l; *start_c = *ref_s; if (c == STOP_CHAR) { /* We are at EOF */ (sym++)[0] = STOP_CHAR; sym[0] = NULL_CHAR; return; } /***************/ /* In a format */ /***************/ if (in_format) { char *format_items; if (OPTION_STROPPING (&program) == UPPER_STROPPING) { format_items = "/%\\+-.abcdefghijklmnopqrstuvwxyz"; } else {/* if (OPTION_STROPPING (&program) == QUOTE_STROPPING) */ format_items = "/%\\+-.ABCDEFGHIJKLMNOPQRSTUVWXYZ"; } if (a68g_strchr (format_items, c) != NO_TEXT) { /* General format items */ (sym++)[0] = c; sym[0] = NULL_CHAR; *att = get_format_item (c); (void) next_char (ref_l, ref_s, A68_FALSE); return; } if (IS_DIGIT (c)) { /* INT denotation for static replicator */ SCAN_DIGITS (c); sym[0] = NULL_CHAR; *att = STATIC_REPLICATOR; return; } } /*******************/ /* Not in a format */ /*******************/ if (IS_UPPER (c)) { if (OPTION_STROPPING (&program) == UPPER_STROPPING) { /* Upper case word - bold tag */ while (IS_UPPER (c) || c == '_') { (sym++)[0] = c; c = next_char (ref_l, ref_s, A68_FALSE); } sym[0] = NULL_CHAR; *att = BOLD_TAG; } else if (OPTION_STROPPING (&program) == QUOTE_STROPPING) { while (IS_UPPER (c) || IS_DIGIT (c) || c == '_') { (sym++)[0] = c; c = next_char (ref_l, ref_s, A68_TRUE); } sym[0] = NULL_CHAR; *att = IDENTIFIER; } } else if (c == '\'') { /* Quote, uppercase word, quote - bold tag */ int k = 0; c = next_char (ref_l, ref_s, A68_FALSE); while (IS_UPPER (c) || IS_DIGIT (c) || c == '_') { (sym++)[0] = c; k++; c = next_char (ref_l, ref_s, A68_TRUE); } SCAN_ERROR (k == 0, *start_l, *start_c, ERROR_QUOTED_BOLD_TAG); sym[0] = NULL_CHAR; *att = BOLD_TAG; /* Skip terminating quote, or complain if it is not there */ SCAN_ERROR (c != '\'', *start_l, *start_c, ERROR_QUOTED_BOLD_TAG); c = next_char (ref_l, ref_s, A68_FALSE); } else if (IS_LOWER (c)) { /* Lower case word - identifier */ while (IS_LOWER (c) || IS_DIGIT (c) || c == '_') { (sym++)[0] = c; c = next_char (ref_l, ref_s, A68_TRUE); } sym[0] = NULL_CHAR; *att = IDENTIFIER; } else if (c == POINT_CHAR) { /* Begins with a point symbol - point, dotdot, L REAL denotation */ if (is_decimal_point (ref_l, ref_s, &c)) { (sym++)[0] = '0'; (sym++)[0] = POINT_CHAR; c = next_char (ref_l, ref_s, A68_TRUE); SCAN_DIGITS (c); if (is_exp_char (ref_l, ref_s, &c)) { SCAN_EXPONENT_PART (c); } sym[0] = NULL_CHAR; *att = REAL_DENOTATION; } else { c = next_char (ref_l, ref_s, A68_TRUE); if (c == POINT_CHAR) { (sym++)[0] = POINT_CHAR; (sym++)[0] = POINT_CHAR; sym[0] = NULL_CHAR; *att = DOTDOT_SYMBOL; c = next_char (ref_l, ref_s, A68_FALSE); } else { (sym++)[0] = POINT_CHAR; sym[0] = NULL_CHAR; *att = POINT_SYMBOL; } } } else if (IS_DIGIT (c)) { /* Something that begins with a digit - L INT denotation, L REAL denotation */ SCAN_DIGITS (c); if (is_decimal_point (ref_l, ref_s, &c)) { c = next_char (ref_l, ref_s, A68_TRUE); if (is_exp_char (ref_l, ref_s, &c)) { (sym++)[0] = POINT_CHAR; (sym++)[0] = '0'; SCAN_EXPONENT_PART (c); *att = REAL_DENOTATION; } else { (sym++)[0] = POINT_CHAR; SCAN_DIGITS (c); if (is_exp_char (ref_l, ref_s, &c)) { SCAN_EXPONENT_PART (c); } *att = REAL_DENOTATION; } } else if (is_exp_char (ref_l, ref_s, &c)) { SCAN_EXPONENT_PART (c); *att = REAL_DENOTATION; } else if (is_radix_char (ref_l, ref_s, &c)) { (sym++)[0] = c; c = next_char (ref_l, ref_s, A68_TRUE); if (OPTION_STROPPING (&program) == UPPER_STROPPING) { while (IS_DIGIT (c) || strchr ("abcdef", c) != NO_TEXT) { (sym++)[0] = c; c = next_char (ref_l, ref_s, A68_TRUE); } } else { while (IS_DIGIT (c) || strchr ("ABCDEF", c) != NO_TEXT) { (sym++)[0] = c; c = next_char (ref_l, ref_s, A68_TRUE); } } *att = BITS_DENOTATION; } else { *att = INT_DENOTATION; } sym[0] = NULL_CHAR; } else if (c == QUOTE_CHAR) { /* STRING denotation */ BOOL_T stop = A68_FALSE; while (!stop) { c = next_char (ref_l, ref_s, A68_FALSE); while (c != QUOTE_CHAR && c != STOP_CHAR) { SCAN_ERROR (EOL (c), *start_l, *start_c, ERROR_LONG_STRING); (sym++)[0] = c; c = next_char (ref_l, ref_s, A68_FALSE); } SCAN_ERROR (*ref_l == NO_LINE, *start_l, *start_c, ERROR_UNTERMINATED_STRING); c = next_char (ref_l, ref_s, A68_FALSE); if (c == QUOTE_CHAR) { (sym++)[0] = QUOTE_CHAR; } else { stop = A68_TRUE; } } sym[0] = NULL_CHAR; *att = (in_format ? LITERAL : ROW_CHAR_DENOTATION); } else if (a68g_strchr ("#$()[]{},;@", c) != NO_TEXT) { /* Single character symbols */ (sym++)[0] = c; (void) next_char (ref_l, ref_s, A68_FALSE); sym[0] = NULL_CHAR; *att = 0; } else if (c == '|') { /* Bar */ (sym++)[0] = c; c = next_char (ref_l, ref_s, A68_FALSE); if (c == ':') { (sym++)[0] = c; (void) next_char (ref_l, ref_s, A68_FALSE); } sym[0] = NULL_CHAR; *att = 0; } else if (c == '!' && OPTION_STROPPING (&program) == QUOTE_STROPPING) { /* Bar, will be replaced with modern variant. For this reason ! is not a MONAD with quote-stropping */ (sym++)[0] = '|'; c = next_char (ref_l, ref_s, A68_FALSE); if (c == ':') { (sym++)[0] = c; (void) next_char (ref_l, ref_s, A68_FALSE); } sym[0] = NULL_CHAR; *att = 0; } else if (c == ':') { /* Colon, semicolon, IS, ISNT */ (sym++)[0] = c; c = next_char (ref_l, ref_s, A68_FALSE); if (c == '=') { (sym++)[0] = c; if ((c = next_char (ref_l, ref_s, A68_FALSE)) == ':') { (sym++)[0] = c; c = next_char (ref_l, ref_s, A68_FALSE); } } else if (c == '/') { (sym++)[0] = c; if ((c = next_char (ref_l, ref_s, A68_FALSE)) == '=') { (sym++)[0] = c; if ((c = next_char (ref_l, ref_s, A68_FALSE)) == ':') { (sym++)[0] = c; c = next_char (ref_l, ref_s, A68_FALSE); } } } else if (c == ':') { (sym++)[0] = c; if ((c = next_char (ref_l, ref_s, A68_FALSE)) == '=') { (sym++)[0] = c; } } sym[0] = NULL_CHAR; *att = 0; } else if (c == '=') { /* Operator starting with "=" */ char *scanned = sym; (sym++)[0] = c; c = next_char (ref_l, ref_s, A68_FALSE); if (a68g_strchr (NOMADS, c) != NO_TEXT) { (sym++)[0] = c; c = next_char (ref_l, ref_s, A68_FALSE); } if (c == '=') { (sym++)[0] = c; if (next_char (ref_l, ref_s, A68_FALSE) == ':') { (sym++)[0] = ':'; c = next_char (ref_l, ref_s, A68_FALSE); if (strlen (sym) < 4 && c == '=') { (sym++)[0] = '='; (void) next_char (ref_l, ref_s, A68_FALSE); } } } else if (c == ':') { (sym++)[0] = c; sym[0] = NULL_CHAR; if (next_char (ref_l, ref_s, A68_FALSE) == '=') { (sym++)[0] = '='; (void) next_char (ref_l, ref_s, A68_FALSE); } else { SCAN_ERROR (!(strcmp (scanned, "=:") == 0 || strcmp (scanned, "==:") == 0), *start_l, *start_c, ERROR_INVALID_OPERATOR_TAG); } } sym[0] = NULL_CHAR; if (strcmp (scanned, "=") == 0) { *att = EQUALS_SYMBOL; } else { *att = OPERATOR; } } else if (a68g_strchr (MONADS, c) != NO_TEXT || a68g_strchr (NOMADS, c) != NO_TEXT) { /* Operator */ char *scanned = sym; (sym++)[0] = c; c = next_char (ref_l, ref_s, A68_FALSE); if (a68g_strchr (NOMADS, c) != NO_TEXT) { (sym++)[0] = c; c = next_char (ref_l, ref_s, A68_FALSE); } if (c == '=') { (sym++)[0] = c; if (next_char (ref_l, ref_s, A68_FALSE) == ':') { (sym++)[0] = ':'; c = next_char (ref_l, ref_s, A68_FALSE); if (strlen (scanned) < 4 && c == '=') { (sym++)[0] = '='; (void) next_char (ref_l, ref_s, A68_FALSE); } } } else if (c == ':') { (sym++)[0] = c; sym[0] = NULL_CHAR; if (next_char (ref_l, ref_s, A68_FALSE) == '=') { (sym++)[0] = '='; sym[0] = NULL_CHAR; (void) next_char (ref_l, ref_s, A68_FALSE); } else { SCAN_ERROR (strcmp (&(scanned[1]), "=:") != 0, *start_l, *start_c, ERROR_INVALID_OPERATOR_TAG); } } sym[0] = NULL_CHAR; *att = OPERATOR; } else { /* Afuuus ... strange characters! */ unworthy (*start_l, *start_c, (int) c); } } /*! \brief whether att opens an embedded clause \param att attribute under test \return whether att opens an embedded clause **/ static BOOL_T open_nested_clause (int att) { switch (att) { case OPEN_SYMBOL: case BEGIN_SYMBOL: case PAR_SYMBOL: case IF_SYMBOL: case CASE_SYMBOL: case FOR_SYMBOL: case FROM_SYMBOL: case BY_SYMBOL: case TO_SYMBOL: case DOWNTO_SYMBOL: case WHILE_SYMBOL: case DO_SYMBOL: case SUB_SYMBOL: case ACCO_SYMBOL: { return (A68_TRUE); } } return (A68_FALSE); } /*! \brief whether att closes an embedded clause \param att attribute under test \return whether att closes an embedded clause **/ static BOOL_T close_nested_clause (int att) { switch (att) { case CLOSE_SYMBOL: case END_SYMBOL: case FI_SYMBOL: case ESAC_SYMBOL: case OD_SYMBOL: case BUS_SYMBOL: case OCCA_SYMBOL: { return (A68_TRUE); } } return (A68_FALSE); } /*! \brief cast a string to lower case \param p string to cast **/ static void make_lower_case (char *p) { for (; p != NO_TEXT && p[0] != NULL_CHAR; p++) { p[0] = (char) TO_LOWER (p[0]); } } /*! \brief construct a linear list of tokens \param root node where to insert new symbol \param level current recursive descent depth \param in_format whether we scan a format \param l current source line \param s current character in source line \param start_l source line where symbol starts \param start_c character where symbol starts **/ static void tokenise_source (NODE_T ** root, int level, BOOL_T in_format, LINE_T ** l, char **s, LINE_T ** start_l, char **start_c) { char *lpr = NO_TEXT; int lprt = 0; while (l != NO_VAR && !stop_scanner) { int att = 0; get_next_token (in_format, l, s, start_l, start_c, &att); if (scan_buf[0] == STOP_CHAR) { stop_scanner = A68_TRUE; } else if (strlen (scan_buf) > 0 || att == ROW_CHAR_DENOTATION || att == LITERAL) { KEYWORD_T *kw = find_keyword (top_keyword, scan_buf); char *c = NO_TEXT; BOOL_T make_node = A68_TRUE; char *trailing = NO_TEXT; if (!(kw != NO_KEYWORD && att != ROW_CHAR_DENOTATION)) { if (att == IDENTIFIER) { make_lower_case (scan_buf); } if (att != ROW_CHAR_DENOTATION && att != LITERAL) { int len = (int) strlen (scan_buf); while (len >= 1 && scan_buf[len - 1] == '_') { trailing = "_"; scan_buf[len - 1] = NULL_CHAR; len--; } } c = TEXT (add_token (&top_token, scan_buf)); } else { if (IS (kw, TO_SYMBOL)) { /* Merge GO and TO to GOTO */ if (*root != NO_NODE && IS (*root, GO_SYMBOL)) { ATTRIBUTE (*root) = GOTO_SYMBOL; NSYMBOL (*root) = TEXT (find_keyword (top_keyword, "GOTO")); make_node = A68_FALSE; } else { att = ATTRIBUTE (kw); c = TEXT (kw); } } else { if (att == 0 || att == BOLD_TAG) { att = ATTRIBUTE (kw); } c = TEXT (kw); /* Handle pragments */ if (att == STYLE_II_COMMENT_SYMBOL || att == STYLE_I_COMMENT_SYMBOL || att == BOLD_COMMENT_SYMBOL) { char *nlpr = pragment (ATTRIBUTE (kw), l, s); if (lpr == NO_TEXT || (int) strlen (lpr) == 0) { lpr = nlpr; } else { lpr = new_string (lpr, "\n\n", nlpr, NO_TEXT); } lprt = att; make_node = A68_FALSE; } else if (att == STYLE_I_PRAGMAT_SYMBOL || att == BOLD_PRAGMAT_SYMBOL) { char *nlpr = pragment (ATTRIBUTE (kw), l, s); if (lpr == NO_TEXT || (int) strlen (lpr) == 0) { lpr = nlpr; } else { lpr = new_string (lpr, "\n\n", nlpr, NO_TEXT); } lprt = att; if (!stop_scanner) { (void) set_options (OPTION_LIST (&program), A68_FALSE); make_node = A68_FALSE; } } } } /* Add token to the tree */ if (make_node) { NODE_T *q = new_node (); INFO (q) = new_node_info (); switch (att) { case ASSIGN_SYMBOL: case END_SYMBOL: case ESAC_SYMBOL: case OD_SYMBOL: case OF_SYMBOL: case FI_SYMBOL: case CLOSE_SYMBOL: case BUS_SYMBOL: case COLON_SYMBOL: case COMMA_SYMBOL: case DOTDOT_SYMBOL: case SEMI_SYMBOL: { GINFO (q) = NO_GINFO; break; } default: { GINFO (q) = new_genie_info (); break; } } STATUS (q) = OPTION_NODEMASK (&program); LINE (INFO (q)) = *start_l; CHAR_IN_LINE (INFO (q)) = *start_c; PRIO (INFO (q)) = 0; PROCEDURE_LEVEL (INFO (q)) = 0; ATTRIBUTE (q) = att; NSYMBOL (q) = c; PREVIOUS (q) = *root; SUB (q) = NEXT (q) = NO_NODE; TABLE (q) = NO_TABLE; MOID (q) = NO_MOID; TAX (q) = NO_TAG; if (lpr != NO_TEXT) { NPRAGMENT (q) = lpr; NPRAGMENT_TYPE (q) = lprt; lpr = NO_TEXT; lprt = 0; } if (*root != NO_NODE) { NEXT (*root) = q; } if (TOP_NODE (&program) == NO_NODE) { TOP_NODE (&program) = q; } *root = q; if (trailing != NO_TEXT) { diagnostic_node (A68_WARNING | A68_FORCE_DIAGNOSTICS, q, WARNING_TRAILING, trailing, att); } } /* Redirection in tokenising formats. The scanner is a recursive-descent type as to know when it scans a format text and when not. */ if (in_format && att == FORMAT_DELIMITER_SYMBOL) { return; } else if (!in_format && att == FORMAT_DELIMITER_SYMBOL) { tokenise_source (root, level + 1, A68_TRUE, l, s, start_l, start_c); } else if (in_format && open_nested_clause (att)) { NODE_T *z = PREVIOUS (*root); if (z != NO_NODE && is_one_of (z, FORMAT_ITEM_N, FORMAT_ITEM_G, FORMAT_ITEM_H, FORMAT_ITEM_F)) { tokenise_source (root, level, A68_FALSE, l, s, start_l, start_c); } else if (att == OPEN_SYMBOL) { ATTRIBUTE (*root) = FORMAT_OPEN_SYMBOL; } else if (OPTION_BRACKETS (&program) && att == SUB_SYMBOL) { ATTRIBUTE (*root) = FORMAT_OPEN_SYMBOL; } else if (OPTION_BRACKETS (&program) && att == ACCO_SYMBOL) { ATTRIBUTE (*root) = FORMAT_OPEN_SYMBOL; } } else if (!in_format && level > 0 && open_nested_clause (att)) { tokenise_source (root, level + 1, A68_FALSE, l, s, start_l, start_c); } else if (!in_format && level > 0 && close_nested_clause (att)) { return; } else if (in_format && att == CLOSE_SYMBOL) { ATTRIBUTE (*root) = FORMAT_CLOSE_SYMBOL; } else if (OPTION_BRACKETS (&program) && in_format && att == BUS_SYMBOL) { ATTRIBUTE (*root) = FORMAT_CLOSE_SYMBOL; } else if (OPTION_BRACKETS (&program) && in_format && att == OCCA_SYMBOL) { ATTRIBUTE (*root) = FORMAT_CLOSE_SYMBOL; } } } } /*! \brief tokenise source file, build initial syntax tree \return whether tokenising ended satisfactorily **/ BOOL_T lexical_analyser (void) { LINE_T *l, *start_l = NO_LINE; char *s = NO_TEXT, *start_c = NO_TEXT; NODE_T *root = NO_NODE; scan_buf = NO_TEXT; max_scan_buf_length = source_file_size = get_source_size (); /* Errors in file? */ if (max_scan_buf_length == 0) { return (A68_FALSE); } if (OPTION_RUN_SCRIPT (&program)) { scan_buf = (char *) get_temp_heap_space ((unsigned) (8 + max_scan_buf_length)); if (!read_script_file ()) { return (A68_FALSE); } } else { max_scan_buf_length += KILOBYTE; /* for the environ, more than enough */ scan_buf = (char *) get_temp_heap_space ((unsigned) max_scan_buf_length); /* Errors in file? */ if (!read_source_file ()) { return (A68_FALSE); } } /* Start tokenising */ read_error = A68_FALSE; stop_scanner = A68_FALSE; if ((l = TOP_LINE (&program)) != NO_LINE) { s = STRING (l); } tokenise_source (&root, 0, A68_FALSE, &l, &s, &start_l, &start_c); return (A68_TRUE); } /************************************************/ /* A small refinement preprocessor for Algol68G */ /************************************************/ /*! \brief whether refinement terminator \param p position in syntax tree \return same **/ static BOOL_T is_refinement_terminator (NODE_T * p) { if (IS (p, POINT_SYMBOL)) { if (IN_PRELUDE (NEXT (p))) { return (A68_TRUE); } else { return (whether (p, POINT_SYMBOL, IDENTIFIER, COLON_SYMBOL, STOP)); } } else { return (A68_FALSE); } } /*! \brief get refinement definitions in the internal source \param z module that reads source **/ void get_refinements (void) { NODE_T *p = TOP_NODE (&program); TOP_REFINEMENT (&program) = NO_REFINEMENT; /* First look where the prelude ends */ while (p != NO_NODE && IN_PRELUDE (p)) { FORWARD (p); } /* Determine whether the program contains refinements at all */ while (p != NO_NODE && !IN_PRELUDE (p) && !is_refinement_terminator (p)) { FORWARD (p); } if (p == NO_NODE || IN_PRELUDE (p)) { return; } /* Apparently this is code with refinements */ FORWARD (p); if (p == NO_NODE || IN_PRELUDE (p)) { /* Ok, we accept a program with no refinements as well */ return; } while (p != NO_NODE && !IN_PRELUDE (p) && whether (p, IDENTIFIER, COLON_SYMBOL, STOP)) { REFINEMENT_T *new_one = (REFINEMENT_T *) get_fixed_heap_space ((size_t) ALIGNED_SIZE_OF (REFINEMENT_T)), *x; BOOL_T exists; NEXT (new_one) = NO_REFINEMENT; NAME (new_one) = NSYMBOL (p); APPLICATIONS (new_one) = 0; LINE_DEFINED (new_one) = LINE (INFO (p)); LINE_APPLIED (new_one) = NO_LINE; NODE_DEFINED (new_one) = p; BEGIN (new_one) = END (new_one) = NO_NODE; p = NEXT_NEXT (p); if (p == NO_NODE) { diagnostic_node (A68_SYNTAX_ERROR, NO_NODE, ERROR_REFINEMENT_EMPTY); return; } else { BEGIN (new_one) = p; } while (p != NO_NODE && ATTRIBUTE (p) != POINT_SYMBOL) { END (new_one) = p; FORWARD (p); } if (p == NO_NODE) { diagnostic_node (A68_SYNTAX_ERROR, NO_NODE, ERROR_SYNTAX_EXPECTED, POINT_SYMBOL); return; } else { FORWARD (p); } /* Do we already have one by this name */ x = TOP_REFINEMENT (&program); exists = A68_FALSE; while (x != NO_REFINEMENT && !exists) { if (NAME (x) == NAME (new_one)) { diagnostic_node (A68_SYNTAX_ERROR, NODE_DEFINED (new_one), ERROR_REFINEMENT_DEFINED); exists = A68_TRUE; } FORWARD (x); } /* Straight insertion in chain */ if (!exists) { NEXT (new_one) = TOP_REFINEMENT (&program); TOP_REFINEMENT (&program) = new_one; } } if (p != NO_NODE && !IN_PRELUDE (p)) { diagnostic_node (A68_SYNTAX_ERROR, p, ERROR_REFINEMENT_INVALID); } } /*! \brief put refinement applications in the internal source \param z module that reads source **/ void put_refinements (void) { REFINEMENT_T *x; NODE_T *p, *point; /* If there are no refinements, there's little to do */ if (TOP_REFINEMENT (&program) == NO_REFINEMENT) { return; } /* Initialisation */ x = TOP_REFINEMENT (&program); while (x != NO_REFINEMENT) { APPLICATIONS (x) = 0; FORWARD (x); } /* Before we introduce infinite loops, find where closing-prelude starts */ p = TOP_NODE (&program); while (p != NO_NODE && IN_PRELUDE (p)) { FORWARD (p); } while (p != NO_NODE && !IN_PRELUDE (p)) { FORWARD (p); } ABEND (p == NO_NODE, ERROR_INTERNAL_CONSISTENCY, NO_TEXT); point = p; /* We need to substitute until the first point */ p = TOP_NODE (&program); while (p != NO_NODE && ATTRIBUTE (p) != POINT_SYMBOL) { if (IS (p, IDENTIFIER)) { /* See if we can find its definition */ REFINEMENT_T *y = NO_REFINEMENT; x = TOP_REFINEMENT (&program); while (x != NO_REFINEMENT && y == NO_REFINEMENT) { if (NAME (x) == NSYMBOL (p)) { y = x; } else { FORWARD (x); } } if (y != NO_REFINEMENT) { /* We found its definition */ APPLICATIONS (y)++; if (APPLICATIONS (y) > 1) { diagnostic_node (A68_SYNTAX_ERROR, NODE_DEFINED (y), ERROR_REFINEMENT_APPLIED); FORWARD (p); } else { /* Tie the definition in the tree */ LINE_APPLIED (y) = LINE (INFO (p)); if (PREVIOUS (p) != NO_NODE) { NEXT (PREVIOUS (p)) = BEGIN (y); } if (BEGIN (y) != NO_NODE) { PREVIOUS (BEGIN (y)) = PREVIOUS (p); } if (NEXT (p) != NO_NODE) { PREVIOUS (NEXT (p)) = END (y); } if (END (y) != NO_NODE) { NEXT (END (y)) = NEXT (p); } p = BEGIN (y); /* So we can substitute the refinements within */ } } else { FORWARD (p); } } else { FORWARD (p); } } /* After the point we ignore it all until the prelude */ if (p != NO_NODE && IS (p, POINT_SYMBOL)) { if (PREVIOUS (p) != NO_NODE) { NEXT (PREVIOUS (p)) = point; } if (PREVIOUS (point) != NO_NODE) { PREVIOUS (point) = PREVIOUS (p); } } else { diagnostic_node (A68_SYNTAX_ERROR, p, ERROR_SYNTAX_EXPECTED, POINT_SYMBOL); } /* Has the programmer done it well? */ if (ERROR_COUNT (&program) == 0) { x = TOP_REFINEMENT (&program); while (x != NO_REFINEMENT) { if (APPLICATIONS (x) == 0) { diagnostic_node (A68_SYNTAX_ERROR, NODE_DEFINED (x), ERROR_REFINEMENT_NOT_APPLIED); } FORWARD (x); } } } /*****************************************************/ /* Top-down parser, elaborates the control structure */ /*****************************************************/ /*! \brief insert alt equals symbol \param p node after which to insert \param att attribute for new node **/ static void insert_alt_equals (NODE_T * p) { NODE_T *q = new_node (); *q = *p; INFO (q) = new_node_info (); *INFO (q) = *INFO (p); GINFO (q) = new_genie_info (); *GINFO (q) = *GINFO (p); ATTRIBUTE (q) = ALT_EQUALS_SYMBOL; NSYMBOL (q) = TEXT (add_token (&top_token, "=")); NEXT (p) = q; PREVIOUS (q) = p; if (NEXT (q) != NO_NODE) { PREVIOUS (NEXT (q)) = q; } } /*! \brief substitute brackets \param p position in tree **/ void substitute_brackets (NODE_T * p) { for (; p != NO_NODE; FORWARD (p)) { substitute_brackets (SUB (p)); switch (ATTRIBUTE (p)) { case ACCO_SYMBOL: { ATTRIBUTE (p) = OPEN_SYMBOL; break; } case OCCA_SYMBOL: { ATTRIBUTE (p) = CLOSE_SYMBOL; break; } case SUB_SYMBOL: { ATTRIBUTE (p) = OPEN_SYMBOL; break; } case BUS_SYMBOL: { ATTRIBUTE (p) = CLOSE_SYMBOL; break; } } } } /*! \brief whether token terminates a unit \param p position in tree \return TRUE or FALSE whether token terminates a unit **/ static BOOL_T is_unit_terminator (NODE_T * p) { switch (ATTRIBUTE (p)) { case BUS_SYMBOL: case CLOSE_SYMBOL: case END_SYMBOL: case SEMI_SYMBOL: case EXIT_SYMBOL: case COMMA_SYMBOL: case THEN_BAR_SYMBOL: case ELSE_BAR_SYMBOL: case THEN_SYMBOL: case ELIF_SYMBOL: case ELSE_SYMBOL: case FI_SYMBOL: case IN_SYMBOL: case OUT_SYMBOL: case OUSE_SYMBOL: case ESAC_SYMBOL: case EDOC_SYMBOL: case OCCA_SYMBOL: { return (A68_TRUE); } } return (A68_FALSE); } /*! \brief whether token is a unit-terminator in a loop clause \param p position in tree \return whether token is a unit-terminator in a loop clause **/ static BOOL_T is_loop_keyword (NODE_T * p) { switch (ATTRIBUTE (p)) { case FOR_SYMBOL: case FROM_SYMBOL: case BY_SYMBOL: case TO_SYMBOL: case DOWNTO_SYMBOL: case WHILE_SYMBOL: case DO_SYMBOL: { return (A68_TRUE); } } return (A68_FALSE); } /*! \brief whether token cannot follow semicolon or EXIT \param p position in tree \return whether token cannot follow semicolon or EXIT **/ static BOOL_T is_semicolon_less (NODE_T * p) { switch (ATTRIBUTE (p)) { case BUS_SYMBOL: case CLOSE_SYMBOL: case END_SYMBOL: case SEMI_SYMBOL: case EXIT_SYMBOL: case THEN_BAR_SYMBOL: case ELSE_BAR_SYMBOL: case THEN_SYMBOL: case ELIF_SYMBOL: case ELSE_SYMBOL: case FI_SYMBOL: case IN_SYMBOL: case OUT_SYMBOL: case OUSE_SYMBOL: case ESAC_SYMBOL: case EDOC_SYMBOL: case OCCA_SYMBOL: case OD_SYMBOL: case UNTIL_SYMBOL: { return (A68_TRUE); } default: { return (A68_FALSE); } } } /*! \brief get good attribute \param p position in tree \return same **/ static int get_good_attribute (NODE_T * p) { switch (ATTRIBUTE (p)) { case UNIT: case TERTIARY: case SECONDARY: case PRIMARY: { return (get_good_attribute (SUB (p))); } default: { return (ATTRIBUTE (p)); } } } /*! \brief preferably don't put intelligible diagnostic here \param p position in tree \return same **/ static BOOL_T dont_mark_here (NODE_T * p) { switch (ATTRIBUTE (p)) { case ACCO_SYMBOL: case ALT_DO_SYMBOL: case ALT_EQUALS_SYMBOL: case ANDF_SYMBOL: case ASSERT_SYMBOL: case ASSIGN_SYMBOL: case ASSIGN_TO_SYMBOL: case AT_SYMBOL: case BEGIN_SYMBOL: case BITS_SYMBOL: case BOLD_COMMENT_SYMBOL: case BOLD_PRAGMAT_SYMBOL: case BOOL_SYMBOL: case BUS_SYMBOL: case BY_SYMBOL: case BYTES_SYMBOL: case CASE_SYMBOL: case CHANNEL_SYMBOL: case CHAR_SYMBOL: case CLOSE_SYMBOL: case CODE_SYMBOL: case COLON_SYMBOL: case COLUMN_SYMBOL: case COMMA_SYMBOL: case COMPLEX_SYMBOL: case COMPL_SYMBOL: case DIAGONAL_SYMBOL: case DO_SYMBOL: case DOTDOT_SYMBOL: case DOWNTO_SYMBOL: case EDOC_SYMBOL: case ELIF_SYMBOL: case ELSE_BAR_SYMBOL: case ELSE_SYMBOL: case EMPTY_SYMBOL: case END_SYMBOL: case ENVIRON_SYMBOL: case EQUALS_SYMBOL: case ESAC_SYMBOL: case EXIT_SYMBOL: case FALSE_SYMBOL: case FILE_SYMBOL: case FI_SYMBOL: case FLEX_SYMBOL: case FORMAT_DELIMITER_SYMBOL: case FORMAT_SYMBOL: case FOR_SYMBOL: case FROM_SYMBOL: case GO_SYMBOL: case GOTO_SYMBOL: case HEAP_SYMBOL: case IF_SYMBOL: case IN_SYMBOL: case INT_SYMBOL: case ISNT_SYMBOL: case IS_SYMBOL: case LOC_SYMBOL: case LONG_SYMBOL: case MAIN_SYMBOL: case MODE_SYMBOL: case NIL_SYMBOL: case OCCA_SYMBOL: case OD_SYMBOL: case OF_SYMBOL: case OPEN_SYMBOL: case OP_SYMBOL: case ORF_SYMBOL: case OUSE_SYMBOL: case OUT_SYMBOL: case PAR_SYMBOL: case PIPE_SYMBOL: case POINT_SYMBOL: case PRIO_SYMBOL: case PROC_SYMBOL: case REAL_SYMBOL: case REF_SYMBOL: case ROWS_SYMBOL: case ROW_SYMBOL: case SEMA_SYMBOL: case SEMI_SYMBOL: case SHORT_SYMBOL: case SKIP_SYMBOL: case SOUND_SYMBOL: case STRING_SYMBOL: case STRUCT_SYMBOL: case STYLE_I_COMMENT_SYMBOL: case STYLE_II_COMMENT_SYMBOL: case STYLE_I_PRAGMAT_SYMBOL: case SUB_SYMBOL: case THEN_BAR_SYMBOL: case THEN_SYMBOL: case TO_SYMBOL: case TRANSPOSE_SYMBOL: case TRUE_SYMBOL: case UNION_SYMBOL: case UNTIL_SYMBOL: case VOID_SYMBOL: case WHILE_SYMBOL: /* and than */ case SERIAL_CLAUSE: case ENQUIRY_CLAUSE: case INITIALISER_SERIES: case DECLARATION_LIST: { return (A68_TRUE); } } return (A68_FALSE); } /*! \brief intelligible diagnostic from syntax tree branch \param p position in tree \param q where to put error message \return same **/ char *phrase_to_text (NODE_T * p, NODE_T ** w) { #define MAX_TERMINALS 8 int count = 0, line = -1; static char buffer[BUFFER_SIZE]; for (buffer[0] = NULL_CHAR; p != NO_NODE && count < MAX_TERMINALS; FORWARD (p)) { if (LINE_NUMBER (p) > 0) { int gatt = get_good_attribute (p); char *z = non_terminal_string (input_line, gatt); /* Where to put the error message? Bob Uzgalis noted that actual content of a diagnostic is not as important as accurately indicating *were* the problem is! */ if (w != NO_VAR) { if (count == 0 || (*w) == NO_NODE) { *w = p; } else if (dont_mark_here (*w)) { *w = p; } } /* Add initiation */ if (count == 0) { if (w != NO_VAR) { bufcat (buffer, "construct beginning with", BUFFER_SIZE); } } else if (count == 1) { bufcat (buffer, " followed by", BUFFER_SIZE); } else if (count == 2) { bufcat (buffer, " and then", BUFFER_SIZE); } else if (count >= 3) { bufcat (buffer, ",", BUFFER_SIZE); } /* Attribute or symbol */ if (z != NO_TEXT && SUB (p) != NO_NODE) { if (gatt == IDENTIFIER || gatt == OPERATOR || gatt == DENOTATION) { ASSERT (snprintf (edit_line, SNPRINTF_SIZE, " \"%s\"", NSYMBOL (p)) >= 0); bufcat (buffer, edit_line, BUFFER_SIZE); } else { if (strchr ("aeio", z[0]) != NO_TEXT) { bufcat (buffer, " an", BUFFER_SIZE); } else { bufcat (buffer, " a", BUFFER_SIZE); } ASSERT (snprintf (edit_line, SNPRINTF_SIZE, " %s", z) >= 0); bufcat (buffer, edit_line, BUFFER_SIZE); } } else if (z != NO_TEXT && SUB (p) == NO_NODE) { ASSERT (snprintf (edit_line, SNPRINTF_SIZE, " \"%s\"", NSYMBOL (p)) >= 0); bufcat (buffer, edit_line, BUFFER_SIZE); } else if (NSYMBOL (p) != NO_TEXT) { ASSERT (snprintf (edit_line, SNPRINTF_SIZE, " \"%s\"", NSYMBOL (p)) >= 0); bufcat (buffer, edit_line, BUFFER_SIZE); } /* Add "starting in line nn" */ if (z != NO_TEXT && line != LINE_NUMBER (p)) { line = LINE_NUMBER (p); if (gatt == SERIAL_CLAUSE || gatt == ENQUIRY_CLAUSE || gatt == INITIALISER_SERIES) { bufcat (buffer, " starting", BUFFER_SIZE); } ASSERT (snprintf (edit_line, SNPRINTF_SIZE, " in line %d", line) >= 0); bufcat (buffer, edit_line, BUFFER_SIZE); } count++; } } if (p != NO_NODE && count == MAX_TERMINALS) { bufcat (buffer, " etcetera", BUFFER_SIZE); } return (buffer); } /*! \brief intelligible diagnostic from syntax tree branch \param p position in tree \param q where to put error message \return same **/ char *phrase_to_text_2 (NODE_T * p, NODE_T ** w) { #define MAX_TERMINALS 8 int count = 0; static char buffer[BUFFER_SIZE]; for (buffer[0] = NULL_CHAR; p != NO_NODE && count < MAX_TERMINALS; FORWARD (p)) { if (LINE_NUMBER (p) > 0) { char *z = non_terminal_string (input_line, ATTRIBUTE (p)); /* Where to put the error message? Bob Uzgalis noted that actual content of a diagnostic is not as important as accurately indicating *were* the problem is! */ if (w != NO_VAR) { if (count == 0 || (*w) == NO_NODE) { *w = p; } else if (dont_mark_here (*w)) { *w = p; } } /* Add initiation */ if (count >= 1) { bufcat (buffer, ",", BUFFER_SIZE); } /* Attribute or symbol */ if (z != NO_TEXT) { ASSERT (snprintf (edit_line, SNPRINTF_SIZE, " %s", z) >= 0); bufcat (buffer, edit_line, BUFFER_SIZE); } else if (NSYMBOL (p) != NO_TEXT) { ASSERT (snprintf (edit_line, SNPRINTF_SIZE, " \"%s\"", NSYMBOL (p)) >= 0); bufcat (buffer, edit_line, BUFFER_SIZE); } count++; } } if (p != NO_NODE && count == MAX_TERMINALS) { bufcat (buffer, " etcetera", BUFFER_SIZE); } return (buffer); } /* This is a parenthesis checker. After this checker, we know that at least brackets are matched. This stabilises later parser phases. Top-down parsing is done to place error diagnostics near offending lines. */ static char bracket_check_error_text[BUFFER_SIZE]; /*! \brief intelligible diagnostics for the bracket checker \param txt buffer to which to append text \param n count mismatch (~= 0) \param bra opening bracket \param ket expected closing bracket \return same **/ static void bracket_check_error (char *txt, int n, char *bra, char *ket) { if (n != 0) { char b[BUFFER_SIZE]; ASSERT (snprintf (b, SNPRINTF_SIZE, "\"%s\" without matching \"%s\"", (n > 0 ? bra : ket), (n > 0 ? ket : bra)) >= 0); if (strlen (txt) > 0) { bufcat (txt, " and ", BUFFER_SIZE); } bufcat (txt, b, BUFFER_SIZE); } } /*! \brief diagnose brackets in local branch of the tree \param p position in tree \return error message **/ static char *bracket_check_diagnose (NODE_T * p) { int begins = 0, opens = 0, format_delims = 0, format_opens = 0, subs = 0, ifs = 0, cases = 0, dos = 0, accos = 0; for (; p != NO_NODE; FORWARD (p)) { switch (ATTRIBUTE (p)) { case BEGIN_SYMBOL: { begins++; break; } case END_SYMBOL: { begins--; break; } case OPEN_SYMBOL: { opens++; break; } case CLOSE_SYMBOL: { opens--; break; } case ACCO_SYMBOL: { accos++; break; } case OCCA_SYMBOL: { accos--; break; } case FORMAT_DELIMITER_SYMBOL: { if (format_delims == 0) { format_delims = 1; } else { format_delims = 0; } break; } case FORMAT_OPEN_SYMBOL: { format_opens++; break; } case FORMAT_CLOSE_SYMBOL: { format_opens--; break; } case SUB_SYMBOL: { subs++; break; } case BUS_SYMBOL: { subs--; break; } case IF_SYMBOL: { ifs++; break; } case FI_SYMBOL: { ifs--; break; } case CASE_SYMBOL: { cases++; break; } case ESAC_SYMBOL: { cases--; break; } case DO_SYMBOL: { dos++; break; } case OD_SYMBOL: { dos--; break; } } } bracket_check_error_text[0] = NULL_CHAR; bracket_check_error (bracket_check_error_text, begins, "BEGIN", "END"); bracket_check_error (bracket_check_error_text, opens, "(", ")"); bracket_check_error (bracket_check_error_text, format_opens, "(", ")"); bracket_check_error (bracket_check_error_text, format_delims, "$", "$"); bracket_check_error (bracket_check_error_text, accos, "{", "}"); bracket_check_error (bracket_check_error_text, subs, "[", "]"); bracket_check_error (bracket_check_error_text, ifs, "IF", "FI"); bracket_check_error (bracket_check_error_text, cases, "CASE", "ESAC"); bracket_check_error (bracket_check_error_text, dos, "DO", "OD"); return (bracket_check_error_text); } /*! \brief driver for locally diagnosing non-matching tokens \param top \param p position in tree \return token from where to continue **/ static NODE_T *bracket_check_parse (NODE_T * top, NODE_T * p) { BOOL_T ignore_token; for (; p != NO_NODE; FORWARD (p)) { int ket = STOP; NODE_T *q = NO_NODE; ignore_token = A68_FALSE; switch (ATTRIBUTE (p)) { case BEGIN_SYMBOL: { ket = END_SYMBOL; q = bracket_check_parse (top, NEXT (p)); break; } case OPEN_SYMBOL: { ket = CLOSE_SYMBOL; q = bracket_check_parse (top, NEXT (p)); break; } case ACCO_SYMBOL: { ket = OCCA_SYMBOL; q = bracket_check_parse (top, NEXT (p)); break; } case FORMAT_OPEN_SYMBOL: { ket = FORMAT_CLOSE_SYMBOL; q = bracket_check_parse (top, NEXT (p)); break; } case SUB_SYMBOL: { ket = BUS_SYMBOL; q = bracket_check_parse (top, NEXT (p)); break; } case IF_SYMBOL: { ket = FI_SYMBOL; q = bracket_check_parse (top, NEXT (p)); break; } case CASE_SYMBOL: { ket = ESAC_SYMBOL; q = bracket_check_parse (top, NEXT (p)); break; } case DO_SYMBOL: { ket = OD_SYMBOL; q = bracket_check_parse (top, NEXT (p)); break; } case END_SYMBOL: case OCCA_SYMBOL: case CLOSE_SYMBOL: case FORMAT_CLOSE_SYMBOL: case BUS_SYMBOL: case FI_SYMBOL: case ESAC_SYMBOL: case OD_SYMBOL: { return (p); } default: { ignore_token = A68_TRUE; } } if (ignore_token) { ; } else if (q != NO_NODE && IS (q, ket)) { p = q; } else if (q == NO_NODE) { char *diag = bracket_check_diagnose (top); diagnostic_node (A68_SYNTAX_ERROR, p, ERROR_PARENTHESIS, (strlen (diag) > 0 ? diag : INFO_MISSING_KEYWORDS)); longjmp (top_down_crash_exit, 1); } else { char *diag = bracket_check_diagnose (top); diagnostic_node (A68_SYNTAX_ERROR, p, ERROR_PARENTHESIS_2, ATTRIBUTE (q), LINE (INFO (q)), ket, (strlen (diag) > 0 ? diag : INFO_MISSING_KEYWORDS)); longjmp (top_down_crash_exit, 1); } } return (NO_NODE); } /*! \brief driver for globally diagnosing non-matching tokens \param top top node in syntax tree **/ void check_parenthesis (NODE_T * top) { if (!setjmp (top_down_crash_exit)) { if (bracket_check_parse (top, top) != NO_NODE) { diagnostic_node (A68_SYNTAX_ERROR, top, ERROR_PARENTHESIS, INFO_MISSING_KEYWORDS); } } } /* Next is a top-down parser that branches out the basic blocks. After this we can assign symbol tables to basic blocks. */ /*! \brief give diagnose from top-down parser \param start embedding clause starts here \param posit error issued at this point \param clause type of clause being processed \param expected token expected **/ static void top_down_diagnose (NODE_T * start, NODE_T * posit, int clause, int expected) { NODE_T *issue = (posit != NO_NODE ? posit : start); if (expected != 0) { diagnostic_node (A68_SYNTAX_ERROR, issue, ERROR_EXPECTED_NEAR, expected, clause, NSYMBOL (start), LINE (INFO (start))); } else { diagnostic_node (A68_SYNTAX_ERROR, issue, ERROR_UNBALANCED_KEYWORD, clause, NSYMBOL (start), LINE (INFO (start))); } } /*! \brief check for premature exhaustion of tokens \param p position in tree \param q **/ static void tokens_exhausted (NODE_T * p, NODE_T * q) { if (p == NO_NODE) { diagnostic_node (A68_SYNTAX_ERROR, q, ERROR_KEYWORD); longjmp (top_down_crash_exit, 1); } } /* This part specifically branches out loop clauses */ /*! \brief whether in cast or formula with loop clause \param p position in tree \return number of symbols to skip **/ static int is_loop_cast_formula (NODE_T * p) { /* Accept declarers that can appear in such casts but not much more */ if (IS (p, VOID_SYMBOL)) { return (1); } else if (IS (p, INT_SYMBOL)) { return (1); } else if (IS (p, REF_SYMBOL)) { return (1); } else if (is_one_of (p, OPERATOR, BOLD_TAG, STOP)) { return (1); } else if (whether (p, UNION_SYMBOL, OPEN_SYMBOL, STOP)) { return (2); } else if (is_one_of (p, OPEN_SYMBOL, SUB_SYMBOL, STOP)) { int k; for (k = 0; p != NO_NODE && (is_one_of (p, OPEN_SYMBOL, SUB_SYMBOL, STOP)); FORWARD (p), k++) { ; } return (p != NO_NODE && (whether (p, UNION_SYMBOL, OPEN_SYMBOL, STOP) ? k : 0)); } return (0); } /*! \brief skip a unit in a loop clause (FROM u BY u TO u) \param p position in tree \return token from where to proceed or NO_NODE **/ static NODE_T *top_down_skip_loop_unit (NODE_T * p) { /* Unit may start with, or consist of, a loop */ if (is_loop_keyword (p)) { p = top_down_loop (p); } /* Skip rest of unit */ while (p != NO_NODE) { int k = is_loop_cast_formula (p); if (k != 0) { /* operator-cast series .. */ while (p != NO_NODE && k != 0) { while (k != 0) { FORWARD (p); k--; } k = is_loop_cast_formula (p); } /* ... may be followed by a loop clause */ if (is_loop_keyword (p)) { p = top_down_loop (p); } } else if (is_loop_keyword (p) || IS (p, OD_SYMBOL)) { /* new loop or end-of-loop */ return (p); } else if (IS (p, COLON_SYMBOL)) { FORWARD (p); /* skip routine header: loop clause */ if (p != NO_NODE && is_loop_keyword (p)) { p = top_down_loop (p); } } else if (is_one_of (p, SEMI_SYMBOL, COMMA_SYMBOL, STOP) || IS (p, EXIT_SYMBOL)) { /* Statement separators */ return (p); } else { FORWARD (p); } } return (NO_NODE); } /*! \brief skip a loop clause \param p position in tree \return token from where to proceed or NO_NODE **/ static NODE_T *top_down_skip_loop_series (NODE_T * p) { BOOL_T siga; do { p = top_down_skip_loop_unit (p); siga = (BOOL_T) (p != NO_NODE && (is_one_of (p, SEMI_SYMBOL, EXIT_SYMBOL, COMMA_SYMBOL, COLON_SYMBOL, STOP))); if (siga) { FORWARD (p); } } while (!(p == NO_NODE || !siga)); return (p); } /*! \brief make branch of loop parts \param p position in tree \return token from where to proceed or NO_NODE **/ NODE_T *top_down_loop (NODE_T * p) { NODE_T *start = p, *q = p, *save; if (IS (q, FOR_SYMBOL)) { tokens_exhausted (FORWARD (q), start); if (IS (q, IDENTIFIER)) { ATTRIBUTE (q) = DEFINING_IDENTIFIER; } else { top_down_diagnose (start, q, LOOP_CLAUSE, IDENTIFIER); longjmp (top_down_crash_exit, 1); } tokens_exhausted (FORWARD (q), start); if (is_one_of (q, FROM_SYMBOL, BY_SYMBOL, TO_SYMBOL, DOWNTO_SYMBOL, WHILE_SYMBOL, STOP)) { ; } else if (IS (q, DO_SYMBOL)) { ATTRIBUTE (q) = ALT_DO_SYMBOL; } else { top_down_diagnose (start, q, LOOP_CLAUSE, STOP); longjmp (top_down_crash_exit, 1); } } if (IS (q, FROM_SYMBOL)) { start = q; q = top_down_skip_loop_unit (NEXT (q)); tokens_exhausted (q, start); if (is_one_of (q, BY_SYMBOL, TO_SYMBOL, DOWNTO_SYMBOL, WHILE_SYMBOL, STOP)) { ; } else if (IS (q, DO_SYMBOL)) { ATTRIBUTE (q) = ALT_DO_SYMBOL; } else { top_down_diagnose (start, q, LOOP_CLAUSE, STOP); longjmp (top_down_crash_exit, 1); } make_sub (start, PREVIOUS (q), FROM_SYMBOL); } if (IS (q, BY_SYMBOL)) { start = q; q = top_down_skip_loop_series (NEXT (q)); tokens_exhausted (q, start); if (is_one_of (q, TO_SYMBOL, DOWNTO_SYMBOL, WHILE_SYMBOL, STOP)) { ; } else if (IS (q, DO_SYMBOL)) { ATTRIBUTE (q) = ALT_DO_SYMBOL; } else { top_down_diagnose (start, q, LOOP_CLAUSE, STOP); longjmp (top_down_crash_exit, 1); } make_sub (start, PREVIOUS (q), BY_SYMBOL); } if (is_one_of (q, TO_SYMBOL, DOWNTO_SYMBOL, STOP)) { start = q; q = top_down_skip_loop_series (NEXT (q)); tokens_exhausted (q, start); if (IS (q, WHILE_SYMBOL)) { ; } else if (IS (q, DO_SYMBOL)) { ATTRIBUTE (q) = ALT_DO_SYMBOL; } else { top_down_diagnose (start, q, LOOP_CLAUSE, STOP); longjmp (top_down_crash_exit, 1); } make_sub (start, PREVIOUS (q), TO_SYMBOL); } if (IS (q, WHILE_SYMBOL)) { start = q; q = top_down_skip_loop_series (NEXT (q)); tokens_exhausted (q, start); if (IS (q, DO_SYMBOL)) { ATTRIBUTE (q) = ALT_DO_SYMBOL; } else { top_down_diagnose (start, q, LOOP_CLAUSE, DO_SYMBOL); longjmp (top_down_crash_exit, 1); } make_sub (start, PREVIOUS (q), WHILE_SYMBOL); } if (is_one_of (q, DO_SYMBOL, ALT_DO_SYMBOL, STOP)) { int k = ATTRIBUTE (q); start = q; q = top_down_skip_loop_series (NEXT (q)); tokens_exhausted (q, start); if (ISNT (q, OD_SYMBOL)) { top_down_diagnose (start, q, LOOP_CLAUSE, OD_SYMBOL); longjmp (top_down_crash_exit, 1); } make_sub (start, q, k); } save = NEXT (start); make_sub (p, start, LOOP_CLAUSE); return (save); } /*! \brief driver for making branches of loop parts \param p position in tree **/ static void top_down_loops (NODE_T * p) { NODE_T *q = p; for (; q != NO_NODE; FORWARD (q)) { if (SUB (q) != NO_NODE) { top_down_loops (SUB (q)); } } q = p; while (q != NO_NODE) { if (is_loop_keyword (q) != STOP) { q = top_down_loop (q); } else { FORWARD (q); } } } /*! \brief driver for making branches of until parts \param p position in tree **/ static void top_down_untils (NODE_T * p) { NODE_T *q = p; for (; q != NO_NODE; FORWARD (q)) { if (SUB (q) != NO_NODE) { top_down_untils (SUB (q)); } } q = p; while (q != NO_NODE) { if (IS (q, UNTIL_SYMBOL)) { NODE_T *u = q; while (NEXT (u) != NO_NODE) { FORWARD (u); } make_sub (q, PREVIOUS (u), UNTIL_SYMBOL); return; } else { FORWARD (q); } } } /* Branch anything except parts of a loop */ /*! \brief skip serial/enquiry clause (unit series) \param p position in tree \return token from where to proceed or NO_NODE **/ static NODE_T *top_down_series (NODE_T * p) { BOOL_T siga = A68_TRUE; while (siga) { siga = A68_FALSE; p = top_down_skip_unit (p); if (p != NO_NODE) { if (is_one_of (p, SEMI_SYMBOL, EXIT_SYMBOL, COMMA_SYMBOL, STOP)) { siga = A68_TRUE; FORWARD (p); } } } return (p); } /*! \brief make branch of BEGIN .. END \param begin_p \return token from where to proceed or NO_NODE **/ static NODE_T *top_down_begin (NODE_T * begin_p) { NODE_T *end_p = top_down_series (NEXT (begin_p)); if (end_p == NO_NODE || ISNT (end_p, END_SYMBOL)) { top_down_diagnose (begin_p, end_p, ENCLOSED_CLAUSE, END_SYMBOL); longjmp (top_down_crash_exit, 1); return (NO_NODE); } else { make_sub (begin_p, end_p, BEGIN_SYMBOL); return (NEXT (begin_p)); } } /*! \brief make branch of CODE .. EDOC \param code_p \return token from where to proceed or NO_NODE **/ static NODE_T *top_down_code (NODE_T * code_p) { NODE_T *edoc_p = top_down_series (NEXT (code_p)); if (edoc_p == NO_NODE || ISNT (edoc_p, EDOC_SYMBOL)) { diagnostic_node (A68_SYNTAX_ERROR, code_p, ERROR_KEYWORD); longjmp (top_down_crash_exit, 1); return (NO_NODE); } else { make_sub (code_p, edoc_p, CODE_SYMBOL); return (NEXT (code_p)); } } /*! \brief make branch of ( .. ) \param open_p \return token from where to proceed or NO_NODE **/ static NODE_T *top_down_open (NODE_T * open_p) { NODE_T *then_bar_p = top_down_series (NEXT (open_p)), *elif_bar_p; if (then_bar_p != NO_NODE && IS (then_bar_p, CLOSE_SYMBOL)) { make_sub (open_p, then_bar_p, OPEN_SYMBOL); return (NEXT (open_p)); } if (then_bar_p == NO_NODE || ISNT (then_bar_p, THEN_BAR_SYMBOL)) { top_down_diagnose (open_p, then_bar_p, ENCLOSED_CLAUSE, STOP); longjmp (top_down_crash_exit, 1); } make_sub (open_p, PREVIOUS (then_bar_p), OPEN_SYMBOL); elif_bar_p = top_down_series (NEXT (then_bar_p)); if (elif_bar_p != NO_NODE && IS (elif_bar_p, CLOSE_SYMBOL)) { make_sub (then_bar_p, PREVIOUS (elif_bar_p), THEN_BAR_SYMBOL); make_sub (open_p, elif_bar_p, OPEN_SYMBOL); return (NEXT (open_p)); } if (elif_bar_p != NO_NODE && IS (elif_bar_p, THEN_BAR_SYMBOL)) { NODE_T *close_p = top_down_series (NEXT (elif_bar_p)); if (close_p == NO_NODE || ISNT (close_p, CLOSE_SYMBOL)) { top_down_diagnose (open_p, elif_bar_p, ENCLOSED_CLAUSE, CLOSE_SYMBOL); longjmp (top_down_crash_exit, 1); } make_sub (then_bar_p, PREVIOUS (elif_bar_p), THEN_BAR_SYMBOL); make_sub (elif_bar_p, PREVIOUS (close_p), THEN_BAR_SYMBOL); make_sub (open_p, close_p, OPEN_SYMBOL); return (NEXT (open_p)); } if (elif_bar_p != NO_NODE && IS (elif_bar_p, ELSE_BAR_SYMBOL)) { NODE_T *close_p = top_down_open (elif_bar_p); make_sub (then_bar_p, PREVIOUS (elif_bar_p), THEN_BAR_SYMBOL); make_sub (open_p, elif_bar_p, OPEN_SYMBOL); return (close_p); } else { top_down_diagnose (open_p, elif_bar_p, ENCLOSED_CLAUSE, CLOSE_SYMBOL); longjmp (top_down_crash_exit, 1); return (NO_NODE); } } /*! \brief make branch of [ .. ] \param sub_p \return token from where to proceed or NO_NODE **/ static NODE_T *top_down_sub (NODE_T * sub_p) { NODE_T *bus_p = top_down_series (NEXT (sub_p)); if (bus_p != NO_NODE && IS (bus_p, BUS_SYMBOL)) { make_sub (sub_p, bus_p, SUB_SYMBOL); return (NEXT (sub_p)); } else { top_down_diagnose (sub_p, bus_p, 0, BUS_SYMBOL); longjmp (top_down_crash_exit, 1); return (NO_NODE); } } /*! \brief make branch of { .. } \param acco_p \return token from where to proceed or NO_NODE **/ static NODE_T *top_down_acco (NODE_T * acco_p) { NODE_T *occa_p = top_down_series (NEXT (acco_p)); if (occa_p != NO_NODE && IS (occa_p, OCCA_SYMBOL)) { make_sub (acco_p, occa_p, ACCO_SYMBOL); return (NEXT (acco_p)); } else { top_down_diagnose (acco_p, occa_p, ENCLOSED_CLAUSE, OCCA_SYMBOL); longjmp (top_down_crash_exit, 1); return (NO_NODE); } } /*! \brief make branch of IF .. THEN .. ELSE .. FI \param if_p \return token from where to proceed or NO_NODE **/ static NODE_T *top_down_if (NODE_T * if_p) { NODE_T *then_p = top_down_series (NEXT (if_p)), *elif_p; if (then_p == NO_NODE || ISNT (then_p, THEN_SYMBOL)) { top_down_diagnose (if_p, then_p, CONDITIONAL_CLAUSE, THEN_SYMBOL); longjmp (top_down_crash_exit, 1); } make_sub (if_p, PREVIOUS (then_p), IF_SYMBOL); elif_p = top_down_series (NEXT (then_p)); if (elif_p != NO_NODE && IS (elif_p, FI_SYMBOL)) { make_sub (then_p, PREVIOUS (elif_p), THEN_SYMBOL); make_sub (if_p, elif_p, IF_SYMBOL); return (NEXT (if_p)); } if (elif_p != NO_NODE && IS (elif_p, ELSE_SYMBOL)) { NODE_T *fi_p = top_down_series (NEXT (elif_p)); if (fi_p == NO_NODE || ISNT (fi_p, FI_SYMBOL)) { top_down_diagnose (if_p, fi_p, CONDITIONAL_CLAUSE, FI_SYMBOL); longjmp (top_down_crash_exit, 1); } else { make_sub (then_p, PREVIOUS (elif_p), THEN_SYMBOL); make_sub (elif_p, PREVIOUS (fi_p), ELSE_SYMBOL); make_sub (if_p, fi_p, IF_SYMBOL); return (NEXT (if_p)); } } if (elif_p != NO_NODE && IS (elif_p, ELIF_SYMBOL)) { NODE_T *fi_p = top_down_if (elif_p); make_sub (then_p, PREVIOUS (elif_p), THEN_SYMBOL); make_sub (if_p, elif_p, IF_SYMBOL); return (fi_p); } else { top_down_diagnose (if_p, elif_p, CONDITIONAL_CLAUSE, FI_SYMBOL); longjmp (top_down_crash_exit, 1); return (NO_NODE); } } /*! \brief make branch of CASE .. IN .. OUT .. ESAC \param case_p \return token from where to proceed or NO_NODE **/ static NODE_T *top_down_case (NODE_T * case_p) { NODE_T *in_p = top_down_series (NEXT (case_p)), *ouse_p; if (in_p == NO_NODE || ISNT (in_p, IN_SYMBOL)) { top_down_diagnose (case_p, in_p, ENCLOSED_CLAUSE, IN_SYMBOL); longjmp (top_down_crash_exit, 1); } make_sub (case_p, PREVIOUS (in_p), CASE_SYMBOL); ouse_p = top_down_series (NEXT (in_p)); if (ouse_p != NO_NODE && IS (ouse_p, ESAC_SYMBOL)) { make_sub (in_p, PREVIOUS (ouse_p), IN_SYMBOL); make_sub (case_p, ouse_p, CASE_SYMBOL); return (NEXT (case_p)); } if (ouse_p != NO_NODE && IS (ouse_p, OUT_SYMBOL)) { NODE_T *esac_p = top_down_series (NEXT (ouse_p)); if (esac_p == NO_NODE || ISNT (esac_p, ESAC_SYMBOL)) { top_down_diagnose (case_p, esac_p, ENCLOSED_CLAUSE, ESAC_SYMBOL); longjmp (top_down_crash_exit, 1); } else { make_sub (in_p, PREVIOUS (ouse_p), IN_SYMBOL); make_sub (ouse_p, PREVIOUS (esac_p), OUT_SYMBOL); make_sub (case_p, esac_p, CASE_SYMBOL); return (NEXT (case_p)); } } if (ouse_p != NO_NODE && IS (ouse_p, OUSE_SYMBOL)) { NODE_T *esac_p = top_down_case (ouse_p); make_sub (in_p, PREVIOUS (ouse_p), IN_SYMBOL); make_sub (case_p, ouse_p, CASE_SYMBOL); return (esac_p); } else { top_down_diagnose (case_p, ouse_p, ENCLOSED_CLAUSE, ESAC_SYMBOL); longjmp (top_down_crash_exit, 1); return (NO_NODE); } } /*! \brief skip a unit \param p position in tree \return token from where to proceed or NO_NODE **/ NODE_T *top_down_skip_unit (NODE_T * p) { while (p != NO_NODE && !is_unit_terminator (p)) { if (IS (p, BEGIN_SYMBOL)) { p = top_down_begin (p); } else if (IS (p, SUB_SYMBOL)) { p = top_down_sub (p); } else if (IS (p, OPEN_SYMBOL)) { p = top_down_open (p); } else if (IS (p, IF_SYMBOL)) { p = top_down_if (p); } else if (IS (p, CASE_SYMBOL)) { p = top_down_case (p); } else if (IS (p, CODE_SYMBOL)) { p = top_down_code (p); } else if (IS (p, ACCO_SYMBOL)) { p = top_down_acco (p); } else { FORWARD (p); } } return (p); } static NODE_T *top_down_skip_format (NODE_T *); /*! \brief make branch of ( .. ) in a format \param open_p \return token from where to proceed or NO_NODE **/ static NODE_T *top_down_format_open (NODE_T * open_p) { NODE_T *close_p = top_down_skip_format (NEXT (open_p)); if (close_p != NO_NODE && IS (close_p, FORMAT_CLOSE_SYMBOL)) { make_sub (open_p, close_p, FORMAT_OPEN_SYMBOL); return (NEXT (open_p)); } else { top_down_diagnose (open_p, close_p, 0, FORMAT_CLOSE_SYMBOL); longjmp (top_down_crash_exit, 1); return (NO_NODE); } } /*! \brief skip a format text \param p position in tree \return token from where to proceed or NO_NODE **/ static NODE_T *top_down_skip_format (NODE_T * p) { while (p != NO_NODE) { if (IS (p, FORMAT_OPEN_SYMBOL)) { p = top_down_format_open (p); } else if (is_one_of (p, FORMAT_CLOSE_SYMBOL, FORMAT_DELIMITER_SYMBOL, STOP)) { return (p); } else { FORWARD (p); } } return (NO_NODE); } /*! \brief make branch of $ .. $ \param p position in tree **/ static void top_down_formats (NODE_T * p) { NODE_T *q; for (q = p; q != NO_NODE; FORWARD (q)) { if (SUB (q) != NO_NODE) { top_down_formats (SUB (q)); } } for (q = p; q != NO_NODE; FORWARD (q)) { if (IS (q, FORMAT_DELIMITER_SYMBOL)) { NODE_T *f = NEXT (q); while (f != NO_NODE && ISNT (f, FORMAT_DELIMITER_SYMBOL)) { if (IS (f, FORMAT_OPEN_SYMBOL)) { f = top_down_format_open (f); } else { f = NEXT (f); } } if (f == NO_NODE) { top_down_diagnose (p, f, FORMAT_TEXT, FORMAT_DELIMITER_SYMBOL); longjmp (top_down_crash_exit, 1); } else { make_sub (q, f, FORMAT_DELIMITER_SYMBOL); } } } } /*! \brief make branches of phrases for the bottom-up parser \param p position in tree **/ void top_down_parser (NODE_T * p) { if (p != NO_NODE) { if (!setjmp (top_down_crash_exit)) { (void) top_down_series (p); top_down_loops (p); top_down_untils (p); top_down_formats (p); } } } /********************************************/ /* Bottom-up parser, reduces all constructs */ /********************************************/ /*! \brief detect redefined keyword \param p position in tree */ static void detect_redefined_keyword (NODE_T * p, int construct) { if (p != NO_NODE && whether (p, KEYWORD, EQUALS_SYMBOL, STOP)) { diagnostic_node (A68_SYNTAX_ERROR, p, ERROR_REDEFINED_KEYWORD, NSYMBOL (p), construct); } } /*! \brief whether a series is serial or collateral \param p position in tree \return whether a series is serial or collateral **/ static int serial_or_collateral (NODE_T * p) { NODE_T *q; int semis = 0, commas = 0, exits = 0; for (q = p; q != NO_NODE; FORWARD (q)) { if (IS (q, COMMA_SYMBOL)) { commas++; } else if (IS (q, SEMI_SYMBOL)) { semis++; } else if (IS (q, EXIT_SYMBOL)) { exits++; } } if (semis == 0 && exits == 0 && commas > 0) { return (COLLATERAL_CLAUSE); } else if ((semis > 0 || exits > 0) && commas == 0) { return (SERIAL_CLAUSE); } else if (semis == 0 && exits == 0 && commas == 0) { return (SERIAL_CLAUSE); } else { /* Heuristic guess to give intelligible error message */ return ((semis + exits) >= (commas ? SERIAL_CLAUSE : COLLATERAL_CLAUSE)); } } /*! \brief whether formal bounds \param p position in tree \return whether formal bounds **/ static BOOL_T is_formal_bounds (NODE_T * p) { if (p == NO_NODE) { return (A68_TRUE); } else { switch (ATTRIBUTE (p)) { case OPEN_SYMBOL: case CLOSE_SYMBOL: case SUB_SYMBOL: case BUS_SYMBOL: case COMMA_SYMBOL: case COLON_SYMBOL: case DOTDOT_SYMBOL: case INT_DENOTATION: case IDENTIFIER: case OPERATOR: { return ((BOOL_T) (is_formal_bounds (SUB (p)) && is_formal_bounds (NEXT (p)))); } default: { return (A68_FALSE); } } } } /*! \brief insert a node with attribute "a" after "p" \param p position in tree \param a attribute **/ static void pad_node (NODE_T * p, int a) { /* This is used to fill information that Algol 68 does not require to be present. Filling in gives one format for such construct; this helps later passes. */ NODE_T *z = new_node (); *z = *p; if (GINFO (p) != NO_GINFO) { GINFO (z) = new_genie_info (); } PREVIOUS (z) = p; SUB (z) = NO_NODE; ATTRIBUTE (z) = a; MOID (z) = NO_MOID; if (NEXT (z) != NO_NODE) { PREVIOUS (NEXT (z)) = z; } NEXT (p) = z; } /*! \brief diagnose extensions \param p position in tree **/ static void a68_extension (NODE_T * p) { if (OPTION_PORTCHECK (&program)) { diagnostic_node (A68_WARNING | A68_FORCE_DIAGNOSTICS, p, WARNING_EXTENSION); } else { diagnostic_node (A68_WARNING, p, WARNING_EXTENSION); } } /*! \brief diagnose for clauses not yielding a value \param p position in tree **/ static void empty_clause (NODE_T * p) { diagnostic_node (A68_SYNTAX_ERROR, p, ERROR_CLAUSE_WITHOUT_VALUE); } #if ! defined HAVE_PARALLEL_CLAUSE /*! \brief diagnose for parallel clause \param p position in tree **/ static void par_clause (NODE_T * p) { diagnostic_node (A68_SYNTAX_ERROR, p, ERROR_NO_PARALLEL_CLAUSE); } #endif /*! \brief diagnose for missing symbol \param p position in tree **/ static void strange_tokens (NODE_T * p) { NODE_T *q = ((p != NO_NODE && NEXT (p) != NO_NODE) ? NEXT (p) : p); diagnostic_node (A68_SYNTAX_ERROR, q, ERROR_SYNTAX_STRANGE_TOKENS); } /*! \brief diagnose for strange separator \param p position in tree **/ static void strange_separator (NODE_T * p) { NODE_T *q = ((p != NO_NODE && NEXT (p) != NO_NODE) ? NEXT (p) : p); diagnostic_node (A68_SYNTAX_ERROR, q, ERROR_SYNTAX_STRANGE_SEPARATOR); } /* Here is a set of routines that gather definitions from phrases. This way we can apply tags before defining them. These routines do not look very elegant as they have to scan through all kind of symbols to find a pattern that they recognise. */ /*! \brief skip anything until a comma, semicolon or EXIT is found \param p position in tree \return node from where to proceed **/ static NODE_T *skip_unit (NODE_T * p) { for (; p != NO_NODE; FORWARD (p)) { if (IS (p, COMMA_SYMBOL)) { return (p); } else if (IS (p, SEMI_SYMBOL)) { return (p); } else if (IS (p, EXIT_SYMBOL)) { return (p); } } return (NO_NODE); } /*! \brief attribute of entry in symbol table \param table current symbol table \param name token name \return attribute of entry in symbol table, or 0 if not found **/ static int find_tag_definition (TABLE_T * table, char *name) { if (table != NO_TABLE) { int ret = 0; TAG_T *s; BOOL_T found; found = A68_FALSE; for (s = INDICANTS (table); s != NO_TAG && !found; FORWARD (s)) { if (NSYMBOL (NODE (s)) == name) { ret += INDICANT; found = A68_TRUE; } } found = A68_FALSE; for (s = OPERATORS (table); s != NO_TAG && !found; FORWARD (s)) { if (NSYMBOL (NODE (s)) == name) { ret += OPERATOR; found = A68_TRUE; } } if (ret == 0) { return (find_tag_definition (PREVIOUS (table), name)); } else { return (ret); } } else { return (0); } } /*! \brief fill in whether bold tag is operator or indicant \param p position in tree **/ static void elaborate_bold_tags (NODE_T * p) { NODE_T *q; for (q = p; q != NO_NODE; FORWARD (q)) { if (IS (q, BOLD_TAG)) { switch (find_tag_definition (TABLE (q), NSYMBOL (q))) { case 0: { diagnostic_node (A68_SYNTAX_ERROR, q, ERROR_UNDECLARED_TAG); break; } case INDICANT: { ATTRIBUTE (q) = INDICANT; break; } case OPERATOR: { ATTRIBUTE (q) = OPERATOR; break; } } } } } /*! \brief skip declarer, or argument pack and declarer \param p position in tree \return node before token that is not part of pack or declarer **/ static NODE_T *skip_pack_declarer (NODE_T * p) { /* Skip () REF [] REF FLEX [] [] .. */ while (p != NO_NODE && (is_one_of (p, SUB_SYMBOL, OPEN_SYMBOL, REF_SYMBOL, FLEX_SYMBOL, SHORT_SYMBOL, LONG_SYMBOL, STOP))) { FORWARD (p); } /* Skip STRUCT (), UNION () or PROC [()] */ if (p != NO_NODE && (is_one_of (p, STRUCT_SYMBOL, UNION_SYMBOL, STOP))) { return (NEXT (p)); } else if (p != NO_NODE && IS (p, PROC_SYMBOL)) { return (skip_pack_declarer (NEXT (p))); } else { return (p); } } /*! \brief search MODE A = .., B = .. and store indicants \param p position in tree **/ static void extract_indicants (NODE_T * p) { NODE_T *q = p; while (q != NO_NODE) { if (IS (q, MODE_SYMBOL)) { BOOL_T siga = A68_TRUE; do { FORWARD (q); detect_redefined_keyword (q, MODE_DECLARATION); if (whether (q, BOLD_TAG, EQUALS_SYMBOL, STOP)) { /* Store in the symbol table, but also in the moid list. Position of definition (q) connects to this lexical level! */ ASSERT (add_tag (TABLE (p), INDICANT, q, NO_MOID, STOP) != NO_TAG); ASSERT (add_mode (&TOP_MOID (&program), INDICANT, 0, q, NO_MOID, NO_PACK) != NO_MOID); ATTRIBUTE (q) = DEFINING_INDICANT; FORWARD (q); ATTRIBUTE (q) = ALT_EQUALS_SYMBOL; q = skip_pack_declarer (NEXT (q)); FORWARD (q); } else { siga = A68_FALSE; } } while (siga && q != NO_NODE && IS (q, COMMA_SYMBOL)); } else { FORWARD (q); } } } #define GET_PRIORITY(q, k)\ RESET_ERRNO;\ (k) = atoi (NSYMBOL (q));\ if (errno != 0) {\ diagnostic_node (A68_SYNTAX_ERROR, (q), ERROR_INVALID_PRIORITY);\ (k) = MAX_PRIORITY;\ } else if ((k) < 1 || (k) > MAX_PRIORITY) {\ diagnostic_node (A68_SYNTAX_ERROR, (q), ERROR_INVALID_PRIORITY);\ (k) = MAX_PRIORITY;\ } /*! \brief search PRIO X = .., Y = .. and store priorities \param p position in tree **/ static void extract_priorities (NODE_T * p) { NODE_T *q = p; while (q != NO_NODE) { if (IS (q, PRIO_SYMBOL)) { BOOL_T siga = A68_TRUE; do { FORWARD (q); detect_redefined_keyword (q, PRIORITY_DECLARATION); /* An operator tag like ++ or && gives strange errors so we catch it here */ if (whether (q, OPERATOR, OPERATOR, STOP)) { int k; NODE_T *y = q; diagnostic_node (A68_SYNTAX_ERROR, q, ERROR_INVALID_OPERATOR_TAG); ATTRIBUTE (q) = DEFINING_OPERATOR; /* Remove one superfluous operator, and hope it was only one. */ NEXT (q) = NEXT_NEXT (q); PREVIOUS (NEXT (q)) = q; FORWARD (q); ATTRIBUTE (q) = ALT_EQUALS_SYMBOL; FORWARD (q); GET_PRIORITY (q, k); ATTRIBUTE (q) = PRIORITY; ASSERT (add_tag (TABLE (p), PRIO_SYMBOL, y, NO_MOID, k) != NO_TAG); FORWARD (q); } else if (whether (q, OPERATOR, EQUALS_SYMBOL, INT_DENOTATION, STOP) || whether (q, EQUALS_SYMBOL, EQUALS_SYMBOL, INT_DENOTATION, STOP)) { int k; NODE_T *y = q; ATTRIBUTE (q) = DEFINING_OPERATOR; FORWARD (q); ATTRIBUTE (q) = ALT_EQUALS_SYMBOL; FORWARD (q); GET_PRIORITY (q, k); ATTRIBUTE (q) = PRIORITY; ASSERT (add_tag (TABLE (p), PRIO_SYMBOL, y, NO_MOID, k) != NO_TAG); FORWARD (q); } else if (whether (q, BOLD_TAG, IDENTIFIER, STOP)) { siga = A68_FALSE; } else if (whether (q, BOLD_TAG, EQUALS_SYMBOL, INT_DENOTATION, STOP)) { int k; NODE_T *y = q; ATTRIBUTE (q) = DEFINING_OPERATOR; FORWARD (q); ATTRIBUTE (q) = ALT_EQUALS_SYMBOL; FORWARD (q); GET_PRIORITY (q, k); ATTRIBUTE (q) = PRIORITY; ASSERT (add_tag (TABLE (p), PRIO_SYMBOL, y, NO_MOID, k) != NO_TAG); FORWARD (q); } else if (whether (q, BOLD_TAG, INT_DENOTATION, STOP) || whether (q, OPERATOR, INT_DENOTATION, STOP) || whether (q, EQUALS_SYMBOL, INT_DENOTATION, STOP)) { /* The scanner cannot separate operator and "=" sign so we do this here */ int len = (int) strlen (NSYMBOL (q)); if (len > 1 && NSYMBOL (q)[len - 1] == '=') { int k; NODE_T *y = q; char *sym = (char *) get_temp_heap_space ((size_t) (len + 1)); bufcpy (sym, NSYMBOL (q), len + 1); sym[len - 1] = NULL_CHAR; NSYMBOL (q) = TEXT (add_token (&top_token, sym)); if (len > 2 && NSYMBOL (q)[len - 2] == ':' && NSYMBOL (q)[len - 3] != '=') { diagnostic_node (A68_SYNTAX_ERROR, q, ERROR_OPERATOR_INVALID_END); } ATTRIBUTE (q) = DEFINING_OPERATOR; insert_alt_equals (q); q = NEXT_NEXT (q); GET_PRIORITY (q, k); ATTRIBUTE (q) = PRIORITY; ASSERT (add_tag (TABLE (p), PRIO_SYMBOL, y, NO_MOID, k) != NO_TAG); FORWARD (q); } else { siga = A68_FALSE; } } else { siga = A68_FALSE; } } while (siga && q != NO_NODE && IS (q, COMMA_SYMBOL)); } else { FORWARD (q); } } } /*! \brief search OP [( .. ) ..] X = .., Y = .. and store operators \param p position in tree **/ static void extract_operators (NODE_T * p) { NODE_T *q = p; while (q != NO_NODE) { if (ISNT (q, OP_SYMBOL)) { FORWARD (q); } else { BOOL_T siga = A68_TRUE; /* Skip operator plan */ if (NEXT (q) != NO_NODE && IS (NEXT (q), OPEN_SYMBOL)) { q = skip_pack_declarer (NEXT (q)); } /* Sample operators */ if (q != NO_NODE) { do { FORWARD (q); detect_redefined_keyword (q, OPERATOR_DECLARATION); /* Unacceptable operator tags like ++ or && could give strange errors */ if (whether (q, OPERATOR, OPERATOR, STOP)) { diagnostic_node (A68_SYNTAX_ERROR, q, ERROR_INVALID_OPERATOR_TAG); ATTRIBUTE (q) = DEFINING_OPERATOR; ASSERT (add_tag (TABLE (p), OP_SYMBOL, q, NO_MOID, STOP) != NO_TAG); NEXT (q) = NEXT_NEXT (q); /* Remove one superfluous operator, and hope it was only one */ PREVIOUS (NEXT (q)) = q; FORWARD (q); ATTRIBUTE (q) = ALT_EQUALS_SYMBOL; q = skip_unit (q); } else if (whether (q, OPERATOR, EQUALS_SYMBOL, STOP) || whether (q, EQUALS_SYMBOL, EQUALS_SYMBOL, STOP)) { ATTRIBUTE (q) = DEFINING_OPERATOR; ASSERT (add_tag (TABLE (p), OP_SYMBOL, q, NO_MOID, STOP) != NO_TAG); FORWARD (q); ATTRIBUTE (q) = ALT_EQUALS_SYMBOL; q = skip_unit (q); } else if (whether (q, BOLD_TAG, IDENTIFIER, STOP)) { siga = A68_FALSE; } else if (whether (q, BOLD_TAG, EQUALS_SYMBOL, STOP)) { ATTRIBUTE (q) = DEFINING_OPERATOR; ASSERT (add_tag (TABLE (p), OP_SYMBOL, q, NO_MOID, STOP) != NO_TAG); FORWARD (q); ATTRIBUTE (q) = ALT_EQUALS_SYMBOL; q = skip_unit (q); } else if (q != NO_NODE && (is_one_of (q, OPERATOR, BOLD_TAG, EQUALS_SYMBOL, STOP))) { /* The scanner cannot separate operator and "=" sign so we do this here */ int len = (int) strlen (NSYMBOL (q)); if (len > 1 && NSYMBOL (q)[len - 1] == '=') { char *sym = (char *) get_temp_heap_space ((size_t) (len + 1)); bufcpy (sym, NSYMBOL (q), len + 1); sym[len - 1] = NULL_CHAR; NSYMBOL (q) = TEXT (add_token (&top_token, sym)); if (len > 2 && NSYMBOL (q)[len - 2] == ':' && NSYMBOL (q)[len - 3] != '=') { diagnostic_node (A68_SYNTAX_ERROR, q, ERROR_OPERATOR_INVALID_END); } ATTRIBUTE (q) = DEFINING_OPERATOR; insert_alt_equals (q); ASSERT (add_tag (TABLE (p), OP_SYMBOL, q, NO_MOID, STOP) != NO_TAG); FORWARD (q); q = skip_unit (q); } else { siga = A68_FALSE; } } else { siga = A68_FALSE; } } while (siga && q != NO_NODE && IS (q, COMMA_SYMBOL)); } } } } /*! \brief search and store labels \param p position in tree \param expect information the parser may have on what is expected **/ static void extract_labels (NODE_T * p, int expect) { NODE_T *q; /* Only handle candidate phrases as not to search indexers! */ if (expect == SERIAL_CLAUSE || expect == ENQUIRY_CLAUSE || expect == SOME_CLAUSE) { for (q = p; q != NO_NODE; FORWARD (q)) { if (whether (q, IDENTIFIER, COLON_SYMBOL, STOP)) { TAG_T *z = add_tag (TABLE (p), LABEL, q, NO_MOID, LOCAL_LABEL); ATTRIBUTE (q) = DEFINING_IDENTIFIER; UNIT (z) = NO_NODE; } } } } /*! \brief search MOID x = .., y = .. and store identifiers \param p position in tree **/ static void extract_identities (NODE_T * p) { NODE_T *q = p; while (q != NO_NODE) { if (whether (q, DECLARER, IDENTIFIER, EQUALS_SYMBOL, STOP)) { BOOL_T siga = A68_TRUE; do { if (whether ((FORWARD (q)), IDENTIFIER, EQUALS_SYMBOL, STOP)) { ASSERT (add_tag (TABLE (p), IDENTIFIER, q, NO_MOID, NORMAL_IDENTIFIER) != NO_TAG); ATTRIBUTE (q) = DEFINING_IDENTIFIER; FORWARD (q); ATTRIBUTE (q) = ALT_EQUALS_SYMBOL; q = skip_unit (q); } else if (whether (q, IDENTIFIER, ASSIGN_SYMBOL, STOP)) { /* Handle common error in ALGOL 68 programs */ diagnostic_node (A68_SYNTAX_ERROR, q, ERROR_SYNTAX_MIXED_DECLARATION); ASSERT (add_tag (TABLE (p), IDENTIFIER, q, NO_MOID, NORMAL_IDENTIFIER) != NO_TAG); ATTRIBUTE (q) = DEFINING_IDENTIFIER; ATTRIBUTE (FORWARD (q)) = ALT_EQUALS_SYMBOL; q = skip_unit (q); } else { siga = A68_FALSE; } } while (siga && q != NO_NODE && IS (q, COMMA_SYMBOL)); } else { FORWARD (q); } } } /*! \brief search MOID x [:= ..], y [:= ..] and store identifiers \param p position in tree **/ static void extract_variables (NODE_T * p) { NODE_T *q = p; while (q != NO_NODE) { if (whether (q, DECLARER, IDENTIFIER, STOP)) { BOOL_T siga = A68_TRUE; do { FORWARD (q); if (whether (q, IDENTIFIER, STOP)) { if (whether (q, IDENTIFIER, EQUALS_SYMBOL, STOP)) { /* Handle common error in ALGOL 68 programs */ diagnostic_node (A68_SYNTAX_ERROR, q, ERROR_SYNTAX_MIXED_DECLARATION); ATTRIBUTE (NEXT (q)) = ASSIGN_SYMBOL; } ASSERT (add_tag (TABLE (p), IDENTIFIER, q, NO_MOID, NORMAL_IDENTIFIER) != NO_TAG); ATTRIBUTE (q) = DEFINING_IDENTIFIER; q = skip_unit (q); } else { siga = A68_FALSE; } } while (siga && q != NO_NODE && IS (q, COMMA_SYMBOL)); } else { FORWARD (q); } } } /*! \brief search PROC x = .., y = .. and stores identifiers \param p position in tree **/ static void extract_proc_identities (NODE_T * p) { NODE_T *q = p; while (q != NO_NODE) { if (whether (q, PROC_SYMBOL, IDENTIFIER, EQUALS_SYMBOL, STOP)) { BOOL_T siga = A68_TRUE; do { FORWARD (q); if (whether (q, IDENTIFIER, EQUALS_SYMBOL, STOP)) { TAG_T *t = add_tag (TABLE (p), IDENTIFIER, q, NO_MOID, NORMAL_IDENTIFIER); IN_PROC (t) = A68_TRUE; ATTRIBUTE (q) = DEFINING_IDENTIFIER; ATTRIBUTE (FORWARD (q)) = ALT_EQUALS_SYMBOL; q = skip_unit (q); } else if (whether (q, IDENTIFIER, ASSIGN_SYMBOL, STOP)) { /* Handle common error in ALGOL 68 programs */ diagnostic_node (A68_SYNTAX_ERROR, q, ERROR_SYNTAX_MIXED_DECLARATION); ASSERT (add_tag (TABLE (p), IDENTIFIER, q, NO_MOID, NORMAL_IDENTIFIER) != NO_TAG); ATTRIBUTE (q) = DEFINING_IDENTIFIER; ATTRIBUTE (FORWARD (q)) = ALT_EQUALS_SYMBOL; q = skip_unit (q); } else { siga = A68_FALSE; } } while (siga && q != NO_NODE && IS (q, COMMA_SYMBOL)); } else { FORWARD (q); } } } /*! \brief search PROC x [:= ..], y [:= ..]; store identifiers \param p position in tree **/ static void extract_proc_variables (NODE_T * p) { NODE_T *q = p; while (q != NO_NODE) { if (whether (q, PROC_SYMBOL, IDENTIFIER, STOP)) { BOOL_T siga = A68_TRUE; do { FORWARD (q); if (whether (q, IDENTIFIER, ASSIGN_SYMBOL, STOP)) { ASSERT (add_tag (TABLE (p), IDENTIFIER, q, NO_MOID, NORMAL_IDENTIFIER) != NO_TAG); ATTRIBUTE (q) = DEFINING_IDENTIFIER; q = skip_unit (FORWARD (q)); } else if (whether (q, IDENTIFIER, EQUALS_SYMBOL, STOP)) { /* Handle common error in ALGOL 68 programs */ diagnostic_node (A68_SYNTAX_ERROR, q, ERROR_SYNTAX_MIXED_DECLARATION); ASSERT (add_tag (TABLE (p), IDENTIFIER, q, NO_MOID, NORMAL_IDENTIFIER) != NO_TAG); ATTRIBUTE (q) = DEFINING_IDENTIFIER; ATTRIBUTE (FORWARD (q)) = ASSIGN_SYMBOL; q = skip_unit (q); } else { siga = A68_FALSE; } } while (siga && q != NO_NODE && IS (q, COMMA_SYMBOL)); } else { FORWARD (q); } } } /*! \brief schedule gathering of definitions in a phrase \param p position in tree **/ static void extract_declarations (NODE_T * p) { NODE_T *q; /* Get definitions so we know what is defined in this range */ extract_identities (p); extract_variables (p); extract_proc_identities (p); extract_proc_variables (p); /* By now we know whether "=" is an operator or not */ for (q = p; q != NO_NODE; FORWARD (q)) { if (IS (q, EQUALS_SYMBOL)) { ATTRIBUTE (q) = OPERATOR; } else if (IS (q, ALT_EQUALS_SYMBOL)) { ATTRIBUTE (q) = EQUALS_SYMBOL; } } /* Get qualifiers */ for (q = p; q != NO_NODE; FORWARD (q)) { if (whether (q, LOC_SYMBOL, DECLARER, DEFINING_IDENTIFIER, STOP)) { make_sub (q, q, QUALIFIER); } if (whether (q, HEAP_SYMBOL, DECLARER, DEFINING_IDENTIFIER, STOP)) { make_sub (q, q, QUALIFIER); } if (whether (q, NEW_SYMBOL, DECLARER, DEFINING_IDENTIFIER, STOP)) { make_sub (q, q, QUALIFIER); } if (whether (q, LOC_SYMBOL, PROC_SYMBOL, DEFINING_IDENTIFIER, STOP)) { make_sub (q, q, QUALIFIER); } if (whether (q, HEAP_SYMBOL, PROC_SYMBOL, DEFINING_IDENTIFIER, STOP)) { make_sub (q, q, QUALIFIER); } if (whether (q, NEW_SYMBOL, PROC_SYMBOL, DEFINING_IDENTIFIER, STOP)) { make_sub (q, q, QUALIFIER); } } /* Give priorities to operators */ for (q = p; q != NO_NODE; FORWARD (q)) { if (IS (q, OPERATOR)) { if (find_tag_global (TABLE (q), OP_SYMBOL, NSYMBOL (q))) { TAG_T *s = find_tag_global (TABLE (q), PRIO_SYMBOL, NSYMBOL (q)); if (s != NO_TAG) { PRIO (INFO (q)) = PRIO (s); } else { PRIO (INFO (q)) = 0; } } else { diagnostic_node (A68_SYNTAX_ERROR, q, ERROR_UNDECLARED_TAG); PRIO (INFO (q)) = 1; } } } } /*! \brief if match then reduce a sentence, the core BU parser routine \param p token where to start matching \param a if not NO_NOTE, procedure to execute upon match \param z if not NO_TICK, to be set to TRUE upon match **/ static void reduce (NODE_T * p, void (*a) (NODE_T *), BOOL_T * z, ...) { va_list list; int result, arg; NODE_T *head = p, *tail = NO_NODE; va_start (list, z); result = va_arg (list, int); while ((arg = va_arg (list, int)) != STOP) { BOOL_T keep_matching; if (p == NO_NODE) { keep_matching = A68_FALSE; } else if (arg == WILDCARD) { /* WILDCARD matches any Algol68G non terminal, but no keyword */ keep_matching = (BOOL_T) (non_terminal_string (edit_line, ATTRIBUTE (p)) != NO_TEXT); } else { if (arg >= 0) { keep_matching = (BOOL_T) (arg == ATTRIBUTE (p)); } else { keep_matching = (BOOL_T) (arg != ATTRIBUTE (p)); } } if (keep_matching) { tail = p; FORWARD (p); } else { va_end (list); return; } } /* Print parser reductions */ if (head != NO_NODE && OPTION_REDUCTIONS (&program) && LINE_NUMBER (head) > 0) { NODE_T *q; int count = 0; reductions++; WIS (head); ASSERT (snprintf (output_line, SNPRINTF_SIZE, "\nReduction %d: %s<-", reductions, non_terminal_string (edit_line, result)) >= 0); WRITE (STDOUT_FILENO, output_line); for (q = head; q != NO_NODE && tail != NO_NODE && q != NEXT (tail); FORWARD (q), count++) { int gatt = ATTRIBUTE (q); char *str = non_terminal_string (input_line, gatt); if (count > 0) { WRITE (STDOUT_FILENO, ", "); } if (str != NO_TEXT) { WRITE (STDOUT_FILENO, str); if (gatt == IDENTIFIER || gatt == OPERATOR || gatt == DENOTATION || gatt == INDICANT) { ASSERT (snprintf (output_line, SNPRINTF_SIZE, " \"%s\"", NSYMBOL (q)) >= 0); WRITE (STDOUT_FILENO, output_line); } } else { WRITE (STDOUT_FILENO, NSYMBOL (q)); } } } /* Make reduction */ if (a != NO_NOTE) { a (head); } make_sub (head, tail, result); va_end (list); if (z != NO_TICK) { *z = A68_TRUE; } } /*! \brief graciously ignore extra semicolons \param p position in tree \param expect information the parser may have on what is expected **/ static void ignore_superfluous_semicolons (NODE_T * p) { /* This routine relaxes the parser a bit with respect to superfluous semicolons, for instance "FI; OD". These provoke only a warning. */ for (; p != NO_NODE; FORWARD (p)) { ignore_superfluous_semicolons (SUB (p)); if (NEXT (p) != NO_NODE && IS (NEXT (p), SEMI_SYMBOL) && NEXT_NEXT (p) == NO_NODE) { diagnostic_node (A68_WARNING | A68_FORCE_DIAGNOSTICS, NEXT (p), WARNING_SKIPPED_SUPERFLUOUS, ATTRIBUTE (NEXT (p))); NEXT (p) = NO_NODE; } else if (IS (p, SEMI_SYMBOL) && is_semicolon_less (NEXT (p))) { diagnostic_node (A68_WARNING | A68_FORCE_DIAGNOSTICS, p, WARNING_SKIPPED_SUPERFLUOUS, ATTRIBUTE (p)); if (PREVIOUS (p) != NO_NODE) { NEXT (PREVIOUS (p)) = NEXT (p); } PREVIOUS (NEXT (p)) = PREVIOUS (p); } } } /*! \brief driver for the bottom-up parser \param p position in tree **/ void bottom_up_parser (NODE_T * p) { if (p != NO_NODE) { if (!setjmp (bottom_up_crash_exit)) { NODE_T *q; int error_count_0 = ERROR_COUNT (&program); ignore_superfluous_semicolons (p); /* A program is "label sequence; particular program" */ extract_labels (p, SERIAL_CLAUSE/* a fake here, but ok */ ); /* Parse the program itself */ for (q = p; q != NO_NODE; FORWARD (q)) { BOOL_T siga = A68_TRUE; if (SUB (q) != NO_NODE) { reduce_branch (q, SOME_CLAUSE); } while (siga) { siga = A68_FALSE; reduce (q, NO_NOTE, &siga, LABEL, DEFINING_IDENTIFIER, COLON_SYMBOL, STOP); reduce (q, NO_NOTE, &siga, LABEL, LABEL, DEFINING_IDENTIFIER, COLON_SYMBOL, STOP); } } /* Determine the encompassing enclosed clause */ for (q = p; q != NO_NODE; FORWARD (q)) { #if defined HAVE_PARALLEL_CLAUSE reduce (q, NO_NOTE, NO_TICK, PARALLEL_CLAUSE, PAR_SYMBOL, COLLATERAL_CLAUSE, STOP); #else reduce (q, par_clause, NO_TICK, PARALLEL_CLAUSE, PAR_SYMBOL, COLLATERAL_CLAUSE, STOP); #endif reduce (q, NO_NOTE, NO_TICK, ENCLOSED_CLAUSE, PARALLEL_CLAUSE, STOP); reduce (q, NO_NOTE, NO_TICK, ENCLOSED_CLAUSE, CLOSED_CLAUSE, STOP); reduce (q, NO_NOTE, NO_TICK, ENCLOSED_CLAUSE, COLLATERAL_CLAUSE, STOP); reduce (q, NO_NOTE, NO_TICK, ENCLOSED_CLAUSE, CONDITIONAL_CLAUSE, STOP); reduce (q, NO_NOTE, NO_TICK, ENCLOSED_CLAUSE, CASE_CLAUSE, STOP); reduce (q, NO_NOTE, NO_TICK, ENCLOSED_CLAUSE, CONFORMITY_CLAUSE, STOP); reduce (q, NO_NOTE, NO_TICK, ENCLOSED_CLAUSE, LOOP_CLAUSE, STOP); } /* Try reducing the particular program */ q = p; reduce (q, NO_NOTE, NO_TICK, PARTICULAR_PROGRAM, LABEL, ENCLOSED_CLAUSE, STOP); reduce (q, NO_NOTE, NO_TICK, PARTICULAR_PROGRAM, ENCLOSED_CLAUSE, STOP); if (SUB (p) == NO_NODE || NEXT (p) != NO_NODE) { recover_from_error (p, PARTICULAR_PROGRAM, (BOOL_T) ((ERROR_COUNT (&program) - error_count_0) > MAX_ERRORS)); } } } } /*! \brief reduce code clause \param p position in tree **/ static void reduce_code_clause (NODE_T * p) { BOOL_T siga = A68_TRUE; while (siga) { NODE_T *u; siga = A68_FALSE; for (u = p; u != NO_NODE; FORWARD (u)) { reduce (u, NO_NOTE, &siga, CODE_LIST, CODE_SYMBOL, ROW_CHAR_DENOTATION, STOP); reduce (u, NO_NOTE, &siga, CODE_LIST, CODE_LIST, ROW_CHAR_DENOTATION, STOP); reduce (u, NO_NOTE, &siga, CODE_LIST, CODE_LIST, COMMA_SYMBOL, ROW_CHAR_DENOTATION, STOP); reduce (u, NO_NOTE, &siga, CODE_CLAUSE, CODE_LIST, EDOC_SYMBOL, STOP); } } } /*! \brief reduce the sub-phrase that starts one level down \param p position in tree \param expect information the parser may have on what is expected **/ static void reduce_branch (NODE_T * q, int expect) { /* If this is unsuccessful then it will at least copy the resulting attribute as the parser can repair some faults. This gives less spurious diagnostics. */ if (q != NO_NODE && SUB (q) != NO_NODE) { NODE_T *p = SUB (q), *u = NO_NODE; int error_count_0 = ERROR_COUNT (&program), error_count_02; BOOL_T declarer_pack = A68_FALSE, no_error; switch (expect) { case STRUCTURE_PACK: case PARAMETER_PACK: case FORMAL_DECLARERS: case UNION_PACK: case SPECIFIER: { declarer_pack = A68_TRUE; } default: { declarer_pack = A68_FALSE; } } /* Sample all info needed to decide whether a bold tag is operator or indicant. Find the meaning of bold tags and quit in case of extra errors. */ extract_indicants (p); if (!declarer_pack) { extract_priorities (p); extract_operators (p); } error_count_02 = ERROR_COUNT (&program); elaborate_bold_tags (p); if ((ERROR_COUNT (&program) - error_count_02) > 0) { longjmp (bottom_up_crash_exit, 1); } /* Now we can reduce declarers, knowing which bold tags are indicants */ reduce_declarers (p, expect); /* Parse the phrase, as appropriate */ if (expect == CODE_CLAUSE) { reduce_code_clause (p); } else if (declarer_pack == A68_FALSE) { error_count_02 = ERROR_COUNT (&program); extract_declarations (p); if ((ERROR_COUNT (&program) - error_count_02) > 0) { longjmp (bottom_up_crash_exit, 1); } extract_labels (p, expect); for (u = p; u != NO_NODE; FORWARD (u)) { if (SUB (u) != NO_NODE) { if (IS (u, FORMAT_DELIMITER_SYMBOL)) { reduce_branch (u, FORMAT_TEXT); } else if (IS (u, FORMAT_OPEN_SYMBOL)) { reduce_branch (u, FORMAT_TEXT); } else if (IS (u, OPEN_SYMBOL)) { if (NEXT (u) != NO_NODE && IS (NEXT (u), THEN_BAR_SYMBOL)) { reduce_branch (u, ENQUIRY_CLAUSE); } else if (PREVIOUS (u) != NO_NODE && IS (PREVIOUS (u), PAR_SYMBOL)) { reduce_branch (u, COLLATERAL_CLAUSE); } } else if (is_one_of (u, IF_SYMBOL, ELIF_SYMBOL, CASE_SYMBOL, OUSE_SYMBOL, WHILE_SYMBOL, UNTIL_SYMBOL, ELSE_BAR_SYMBOL, ACCO_SYMBOL, STOP)) { reduce_branch (u, ENQUIRY_CLAUSE); } else if (IS (u, BEGIN_SYMBOL)) { reduce_branch (u, SOME_CLAUSE); } else if (is_one_of (u, THEN_SYMBOL, ELSE_SYMBOL, OUT_SYMBOL, DO_SYMBOL, ALT_DO_SYMBOL, STOP)) { reduce_branch (u, SERIAL_CLAUSE); } else if (IS (u, IN_SYMBOL)) { reduce_branch (u, COLLATERAL_CLAUSE); } else if (IS (u, THEN_BAR_SYMBOL)) { reduce_branch (u, SOME_CLAUSE); } else if (IS (u, LOOP_CLAUSE)) { reduce_branch (u, ENCLOSED_CLAUSE); } else if (is_one_of (u, FOR_SYMBOL, FROM_SYMBOL, BY_SYMBOL, TO_SYMBOL, DOWNTO_SYMBOL, STOP)) { reduce_branch (u, UNIT); } } } reduce_primary_parts (p, expect); if (expect != ENCLOSED_CLAUSE) { reduce_primaries (p, expect); if (expect == FORMAT_TEXT) { reduce_format_texts (p); } else { reduce_secondaries (p); reduce_formulae (p); reduce_tertiaries (p); } } for (u = p; u != NO_NODE; FORWARD (u)) { if (SUB (u) != NO_NODE) { if (IS (u, CODE_SYMBOL)) { reduce_branch (u, CODE_CLAUSE); } } } reduce_right_to_left_constructs (p); /* Reduce units and declarations */ reduce_basic_declarations (p); reduce_units (p); reduce_erroneous_units (p); if (expect != UNIT) { if (expect == GENERIC_ARGUMENT) { reduce_generic_arguments (p); } else if (expect == BOUNDS) { reduce_bounds (p); } else { reduce_declaration_lists (p); if (expect != DECLARATION_LIST) { for (u = p; u != NO_NODE; FORWARD (u)) { reduce (u, NO_NOTE, NO_TICK, LABELED_UNIT, LABEL, UNIT, STOP); reduce (u, NO_NOTE, NO_TICK, SPECIFIED_UNIT, SPECIFIER, COLON_SYMBOL, UNIT, STOP); } if (expect == SOME_CLAUSE) { expect = serial_or_collateral (p); } if (expect == SERIAL_CLAUSE) { reduce_serial_clauses (p); } else if (expect == ENQUIRY_CLAUSE) { reduce_enquiry_clauses (p); } else if (expect == COLLATERAL_CLAUSE) { reduce_collateral_clauses (p); } else if (expect == ARGUMENT) { reduce_arguments (p); } } } } reduce_enclosed_clauses (p, expect); } /* Do something if parsing failed */ if (SUB (p) == NO_NODE || NEXT (p) != NO_NODE) { recover_from_error (p, expect, (BOOL_T) ((ERROR_COUNT (&program) - error_count_0) > MAX_ERRORS)); no_error = A68_FALSE; } else { no_error = A68_TRUE; } ATTRIBUTE (q) = ATTRIBUTE (p); if (no_error) { SUB (q) = SUB (p); } } } /*! \brief driver for reducing declarers \param p position in tree \param expect information the parser may have on what is expected **/ static void reduce_declarers (NODE_T * p, int expect) { NODE_T *q; BOOL_T siga; /* Reduce lengtheties */ for (q = p; q != NO_NODE; FORWARD (q)) { siga = A68_TRUE; reduce (q, NO_NOTE, NO_TICK, LONGETY, LONG_SYMBOL, STOP); reduce (q, NO_NOTE, NO_TICK, SHORTETY, SHORT_SYMBOL, STOP); while (siga) { siga = A68_FALSE; reduce (q, NO_NOTE, &siga, LONGETY, LONGETY, LONG_SYMBOL, STOP); reduce (q, NO_NOTE, &siga, SHORTETY, SHORTETY, SHORT_SYMBOL, STOP); } } /* Reduce indicants */ for (q = p; q != NO_NODE; FORWARD (q)) { reduce (q, NO_NOTE, NO_TICK, INDICANT, INT_SYMBOL, STOP); reduce (q, NO_NOTE, NO_TICK, INDICANT, REAL_SYMBOL, STOP); reduce (q, NO_NOTE, NO_TICK, INDICANT, BITS_SYMBOL, STOP); reduce (q, NO_NOTE, NO_TICK, INDICANT, BYTES_SYMBOL, STOP); reduce (q, NO_NOTE, NO_TICK, INDICANT, COMPLEX_SYMBOL, STOP); reduce (q, NO_NOTE, NO_TICK, INDICANT, COMPL_SYMBOL, STOP); reduce (q, NO_NOTE, NO_TICK, INDICANT, BOOL_SYMBOL, STOP); reduce (q, NO_NOTE, NO_TICK, INDICANT, CHAR_SYMBOL, STOP); reduce (q, NO_NOTE, NO_TICK, INDICANT, FORMAT_SYMBOL, STOP); reduce (q, NO_NOTE, NO_TICK, INDICANT, STRING_SYMBOL, STOP); reduce (q, NO_NOTE, NO_TICK, INDICANT, FILE_SYMBOL, STOP); reduce (q, NO_NOTE, NO_TICK, INDICANT, CHANNEL_SYMBOL, STOP); reduce (q, NO_NOTE, NO_TICK, INDICANT, SEMA_SYMBOL, STOP); reduce (q, NO_NOTE, NO_TICK, INDICANT, PIPE_SYMBOL, STOP); reduce (q, NO_NOTE, NO_TICK, INDICANT, SOUND_SYMBOL, STOP); } /* Reduce standard stuff */ for (q = p; q != NO_NODE; FORWARD (q)) { if (whether (q, LONGETY, INDICANT, STOP)) { int a; if (SUB_NEXT (q) == NO_NODE) { diagnostic_node (A68_SYNTAX_ERROR, NEXT (q), ERROR_EXPECTED, INFO_APPROPRIATE_DECLARER); reduce (q, NO_NOTE, NO_TICK, DECLARER, LONGETY, INDICANT, STOP); } else { a = ATTRIBUTE (SUB_NEXT (q)); if (a == INT_SYMBOL || a == REAL_SYMBOL || a == BITS_SYMBOL || a == BYTES_SYMBOL || a == COMPLEX_SYMBOL || a == COMPL_SYMBOL) { reduce (q, NO_NOTE, NO_TICK, DECLARER, LONGETY, INDICANT, STOP); } else { diagnostic_node (A68_SYNTAX_ERROR, NEXT (q), ERROR_EXPECTED, INFO_APPROPRIATE_DECLARER); reduce (q, NO_NOTE, NO_TICK, DECLARER, LONGETY, INDICANT, STOP); } } } else if (whether (q, SHORTETY, INDICANT, STOP)) { int a; if (SUB_NEXT (q) == NO_NODE) { diagnostic_node (A68_SYNTAX_ERROR, NEXT (q), ERROR_EXPECTED, INFO_APPROPRIATE_DECLARER); reduce (q, NO_NOTE, NO_TICK, DECLARER, SHORTETY, INDICANT, STOP); } else { a = ATTRIBUTE (SUB_NEXT (q)); if (a == INT_SYMBOL || a == REAL_SYMBOL || a == BITS_SYMBOL || a == BYTES_SYMBOL || a == COMPLEX_SYMBOL || a == COMPL_SYMBOL) { reduce (q, NO_NOTE, NO_TICK, DECLARER, SHORTETY, INDICANT, STOP); } else { diagnostic_node (A68_SYNTAX_ERROR, NEXT (q), ERROR_EXPECTED, INFO_APPROPRIATE_DECLARER); reduce (q, NO_NOTE, NO_TICK, DECLARER, LONGETY, INDICANT, STOP); } } } } for (q = p; q != NO_NODE; FORWARD (q)) { reduce (q, NO_NOTE, NO_TICK, DECLARER, INDICANT, STOP); } /* Reduce declarer lists */ for (q = p; q != NO_NODE; FORWARD (q)) { if (NEXT (q) != NO_NODE && SUB_NEXT (q) != NO_NODE) { if (IS (q, STRUCT_SYMBOL)) { reduce_branch (NEXT (q), STRUCTURE_PACK); reduce (q, NO_NOTE, NO_TICK, DECLARER, STRUCT_SYMBOL, STRUCTURE_PACK, STOP); } else if (IS (q, UNION_SYMBOL)) { reduce_branch (NEXT (q), UNION_PACK); reduce (q, NO_NOTE, NO_TICK, DECLARER, UNION_SYMBOL, UNION_PACK, STOP); } else if (IS (q, PROC_SYMBOL)) { if (whether (q, PROC_SYMBOL, OPEN_SYMBOL, STOP)) { if (!is_formal_bounds (SUB_NEXT (q))) { reduce_branch (NEXT (q), FORMAL_DECLARERS); } } } else if (IS (q, OP_SYMBOL)) { if (whether (q, OP_SYMBOL, OPEN_SYMBOL, STOP)) { if (!is_formal_bounds (SUB_NEXT (q))) { reduce_branch (NEXT (q), FORMAL_DECLARERS); } } } } } /* Reduce row, proc or op declarers */ siga = A68_TRUE; while (siga) { siga = A68_FALSE; for (q = p; q != NO_NODE; FORWARD (q)) { /* FLEX DECL */ if (whether (q, FLEX_SYMBOL, DECLARER, STOP)) { reduce (q, NO_NOTE, &siga, DECLARER, FLEX_SYMBOL, DECLARER, STOP); } /* FLEX [] DECL */ if (whether (q, FLEX_SYMBOL, SUB_SYMBOL, DECLARER, STOP) && SUB_NEXT (q) != NO_NODE) { reduce_branch (NEXT (q), BOUNDS); reduce (q, NO_NOTE, &siga, DECLARER, FLEX_SYMBOL, BOUNDS, DECLARER, STOP); reduce (q, NO_NOTE, &siga, DECLARER, FLEX_SYMBOL, FORMAL_BOUNDS, DECLARER, STOP); } /* FLEX () DECL */ if (whether (q, FLEX_SYMBOL, OPEN_SYMBOL, DECLARER, STOP) && SUB_NEXT (q) != NO_NODE) { if (!whether (q, FLEX_SYMBOL, OPEN_SYMBOL, DECLARER, COLON_SYMBOL, STOP)) { reduce_branch (NEXT (q), BOUNDS); reduce (q, NO_NOTE, &siga, DECLARER, FLEX_SYMBOL, BOUNDS, DECLARER, STOP); reduce (q, NO_NOTE, &siga, DECLARER, FLEX_SYMBOL, FORMAL_BOUNDS, DECLARER, STOP); } } /* [] DECL */ if (whether (q, SUB_SYMBOL, DECLARER, STOP) && SUB (q) != NO_NODE) { reduce_branch (q, BOUNDS); reduce (q, NO_NOTE, &siga, DECLARER, BOUNDS, DECLARER, STOP); reduce (q, NO_NOTE, &siga, DECLARER, FORMAL_BOUNDS, DECLARER, STOP); } /* () DECL */ if (whether (q, OPEN_SYMBOL, DECLARER, STOP) && SUB (q) != NO_NODE) { if (whether (q, OPEN_SYMBOL, DECLARER, COLON_SYMBOL, STOP)) { /* Catch e.g. (INT i) () INT: */ if (is_formal_bounds (SUB (q))) { reduce_branch (q, BOUNDS); reduce (q, NO_NOTE, &siga, DECLARER, BOUNDS, DECLARER, STOP); reduce (q, NO_NOTE, &siga, DECLARER, FORMAL_BOUNDS, DECLARER, STOP); } } else { reduce_branch (q, BOUNDS); reduce (q, NO_NOTE, &siga, DECLARER, BOUNDS, DECLARER, STOP); reduce (q, NO_NOTE, &siga, DECLARER, FORMAL_BOUNDS, DECLARER, STOP); } } } /* PROC DECL, PROC () DECL, OP () DECL */ for (q = p; q != NO_NODE; FORWARD (q)) { int a = ATTRIBUTE (q); if (a == REF_SYMBOL) { reduce (q, NO_NOTE, &siga, DECLARER, REF_SYMBOL, DECLARER, STOP); } else if (a == PROC_SYMBOL) { reduce (q, NO_NOTE, &siga, DECLARER, PROC_SYMBOL, DECLARER, STOP); reduce (q, NO_NOTE, &siga, DECLARER, PROC_SYMBOL, FORMAL_DECLARERS, DECLARER, STOP); reduce (q, NO_NOTE, &siga, DECLARER, PROC_SYMBOL, VOID_SYMBOL, STOP); reduce (q, NO_NOTE, &siga, DECLARER, PROC_SYMBOL, FORMAL_DECLARERS, VOID_SYMBOL, STOP); } else if (a == OP_SYMBOL) { reduce (q, NO_NOTE, &siga, OPERATOR_PLAN, OP_SYMBOL, FORMAL_DECLARERS, DECLARER, STOP); reduce (q, NO_NOTE, &siga, OPERATOR_PLAN, OP_SYMBOL, FORMAL_DECLARERS, VOID_SYMBOL, STOP); } } } /* Reduce packs etcetera */ if (expect == STRUCTURE_PACK) { for (q = p; q != NO_NODE; FORWARD (q)) { siga = A68_TRUE; while (siga) { siga = A68_FALSE; reduce (q, NO_NOTE, &siga, STRUCTURED_FIELD, DECLARER, IDENTIFIER, STOP); reduce (q, NO_NOTE, &siga, STRUCTURED_FIELD, STRUCTURED_FIELD, COMMA_SYMBOL, IDENTIFIER, STOP); } } for (q = p; q != NO_NODE; FORWARD (q)) { siga = A68_TRUE; while (siga) { siga = A68_FALSE; reduce (q, NO_NOTE, &siga, STRUCTURED_FIELD_LIST, STRUCTURED_FIELD, STOP); reduce (q, NO_NOTE, &siga, STRUCTURED_FIELD_LIST, STRUCTURED_FIELD_LIST, COMMA_SYMBOL, STRUCTURED_FIELD, STOP); reduce (q, strange_separator, &siga, STRUCTURED_FIELD_LIST, STRUCTURED_FIELD_LIST, STRUCTURED_FIELD, STOP); reduce (q, strange_separator, &siga, STRUCTURED_FIELD_LIST, STRUCTURED_FIELD_LIST, SEMI_SYMBOL, STRUCTURED_FIELD, STOP); } } q = p; reduce (q, NO_NOTE, NO_TICK, STRUCTURE_PACK, OPEN_SYMBOL, STRUCTURED_FIELD_LIST, CLOSE_SYMBOL, STOP); } else if (expect == PARAMETER_PACK) { for (q = p; q != NO_NODE; FORWARD (q)) { siga = A68_TRUE; while (siga) { siga = A68_FALSE; reduce (q, NO_NOTE, &siga, PARAMETER, DECLARER, IDENTIFIER, STOP); reduce (q, NO_NOTE, &siga, PARAMETER, PARAMETER, COMMA_SYMBOL, IDENTIFIER, STOP); } } for (q = p; q != NO_NODE; FORWARD (q)) { siga = A68_TRUE; while (siga) { siga = A68_FALSE; reduce (q, NO_NOTE, &siga, PARAMETER_LIST, PARAMETER, STOP); reduce (q, NO_NOTE, &siga, PARAMETER_LIST, PARAMETER_LIST, COMMA_SYMBOL, PARAMETER, STOP); } } q = p; reduce (q, NO_NOTE, NO_TICK, PARAMETER_PACK, OPEN_SYMBOL, PARAMETER_LIST, CLOSE_SYMBOL, STOP); } else if (expect == FORMAL_DECLARERS) { for (q = p; q != NO_NODE; FORWARD (q)) { siga = A68_TRUE; while (siga) { siga = A68_FALSE; reduce (q, NO_NOTE, &siga, FORMAL_DECLARERS_LIST, DECLARER, STOP); reduce (q, NO_NOTE, &siga, FORMAL_DECLARERS_LIST, FORMAL_DECLARERS_LIST, COMMA_SYMBOL, DECLARER, STOP); reduce (q, strange_separator, &siga, FORMAL_DECLARERS_LIST, FORMAL_DECLARERS_LIST, SEMI_SYMBOL, DECLARER, STOP); reduce (q, strange_separator, &siga, FORMAL_DECLARERS_LIST, FORMAL_DECLARERS_LIST, DECLARER, STOP); } } q = p; reduce (q, NO_NOTE, NO_TICK, FORMAL_DECLARERS, OPEN_SYMBOL, FORMAL_DECLARERS_LIST, CLOSE_SYMBOL, STOP); } else if (expect == UNION_PACK) { for (q = p; q != NO_NODE; FORWARD (q)) { siga = A68_TRUE; while (siga) { siga = A68_FALSE; reduce (q, NO_NOTE, &siga, UNION_DECLARER_LIST, DECLARER, STOP); reduce (q, NO_NOTE, &siga, UNION_DECLARER_LIST, VOID_SYMBOL, STOP); reduce (q, NO_NOTE, &siga, UNION_DECLARER_LIST, UNION_DECLARER_LIST, COMMA_SYMBOL, DECLARER, STOP); reduce (q, NO_NOTE, &siga, UNION_DECLARER_LIST, UNION_DECLARER_LIST, COMMA_SYMBOL, VOID_SYMBOL, STOP); reduce (q, strange_separator, &siga, UNION_DECLARER_LIST, UNION_DECLARER_LIST, SEMI_SYMBOL, DECLARER, STOP); reduce (q, strange_separator, &siga, UNION_DECLARER_LIST, UNION_DECLARER_LIST, SEMI_SYMBOL, VOID_SYMBOL, STOP); reduce (q, strange_separator, &siga, UNION_DECLARER_LIST, UNION_DECLARER_LIST, DECLARER, STOP); reduce (q, strange_separator, &siga, UNION_DECLARER_LIST, UNION_DECLARER_LIST, VOID_SYMBOL, STOP); } } q = p; reduce (q, NO_NOTE, NO_TICK, UNION_PACK, OPEN_SYMBOL, UNION_DECLARER_LIST, CLOSE_SYMBOL, STOP); } else if (expect == SPECIFIER) { reduce (p, NO_NOTE, NO_TICK, SPECIFIER, OPEN_SYMBOL, DECLARER, IDENTIFIER, CLOSE_SYMBOL, STOP); reduce (p, NO_NOTE, NO_TICK, SPECIFIER, OPEN_SYMBOL, DECLARER, CLOSE_SYMBOL, STOP); reduce (p, NO_NOTE, NO_TICK, SPECIFIER, OPEN_SYMBOL, VOID_SYMBOL, CLOSE_SYMBOL, STOP); } else { for (q = p; q != NO_NODE; FORWARD (q)) { if (whether (q, OPEN_SYMBOL, COLON_SYMBOL, STOP) && !(expect == GENERIC_ARGUMENT || expect == BOUNDS)) { if (is_one_of (p, IN_SYMBOL, THEN_BAR_SYMBOL, STOP)) { reduce_branch (q, SPECIFIER); } } if (whether (q, OPEN_SYMBOL, DECLARER, COLON_SYMBOL, STOP)) { reduce_branch (q, PARAMETER_PACK); } if (whether (q, OPEN_SYMBOL, VOID_SYMBOL, COLON_SYMBOL, STOP)) { reduce_branch (q, PARAMETER_PACK); } } } } /*! \brief handle cases that need reducing from right-to-left \param p position in tree **/ static void reduce_right_to_left_constructs (NODE_T * p) { /* Here are cases that need reducing from right-to-left whereas many things can be reduced left-to-right. Assignations are a notable example; one could discuss whether it would not be more natural to write 1 =: k in stead of k := 1. The latter is said to be more natural, or it could be just computing history. Meanwhile we use this routine. */ if (p != NO_NODE) { reduce_right_to_left_constructs (NEXT (p)); /* Assignations */ if (IS (p, TERTIARY)) { reduce (p, NO_NOTE, NO_TICK, ASSIGNATION, TERTIARY, ASSIGN_SYMBOL, TERTIARY, STOP); reduce (p, NO_NOTE, NO_TICK, ASSIGNATION, TERTIARY, ASSIGN_SYMBOL, IDENTITY_RELATION, STOP); reduce (p, NO_NOTE, NO_TICK, ASSIGNATION, TERTIARY, ASSIGN_SYMBOL, AND_FUNCTION, STOP); reduce (p, NO_NOTE, NO_TICK, ASSIGNATION, TERTIARY, ASSIGN_SYMBOL, OR_FUNCTION, STOP); reduce (p, NO_NOTE, NO_TICK, ASSIGNATION, TERTIARY, ASSIGN_SYMBOL, ROUTINE_TEXT, STOP); reduce (p, NO_NOTE, NO_TICK, ASSIGNATION, TERTIARY, ASSIGN_SYMBOL, JUMP, STOP); reduce (p, NO_NOTE, NO_TICK, ASSIGNATION, TERTIARY, ASSIGN_SYMBOL, SKIP, STOP); reduce (p, NO_NOTE, NO_TICK, ASSIGNATION, TERTIARY, ASSIGN_SYMBOL, ASSIGNATION, STOP); reduce (p, NO_NOTE, NO_TICK, ASSIGNATION, TERTIARY, ASSIGN_SYMBOL, CODE_CLAUSE, STOP); } /* Routine texts with parameter pack */ else if (IS (p, PARAMETER_PACK)) { reduce (p, NO_NOTE, NO_TICK, ROUTINE_TEXT, PARAMETER_PACK, DECLARER, COLON_SYMBOL, ASSIGNATION, STOP); reduce (p, NO_NOTE, NO_TICK, ROUTINE_TEXT, PARAMETER_PACK, DECLARER, COLON_SYMBOL, IDENTITY_RELATION, STOP); reduce (p, NO_NOTE, NO_TICK, ROUTINE_TEXT, PARAMETER_PACK, DECLARER, COLON_SYMBOL, AND_FUNCTION, STOP); reduce (p, NO_NOTE, NO_TICK, ROUTINE_TEXT, PARAMETER_PACK, DECLARER, COLON_SYMBOL, OR_FUNCTION, STOP); reduce (p, NO_NOTE, NO_TICK, ROUTINE_TEXT, PARAMETER_PACK, DECLARER, COLON_SYMBOL, JUMP, STOP); reduce (p, NO_NOTE, NO_TICK, ROUTINE_TEXT, PARAMETER_PACK, DECLARER, COLON_SYMBOL, SKIP, STOP); reduce (p, NO_NOTE, NO_TICK, ROUTINE_TEXT, PARAMETER_PACK, DECLARER, COLON_SYMBOL, TERTIARY, STOP); reduce (p, NO_NOTE, NO_TICK, ROUTINE_TEXT, PARAMETER_PACK, DECLARER, COLON_SYMBOL, ROUTINE_TEXT, STOP); reduce (p, NO_NOTE, NO_TICK, ROUTINE_TEXT, PARAMETER_PACK, DECLARER, COLON_SYMBOL, CODE_CLAUSE, STOP); reduce (p, NO_NOTE, NO_TICK, ROUTINE_TEXT, PARAMETER_PACK, VOID_SYMBOL, COLON_SYMBOL, ASSIGNATION, STOP); reduce (p, NO_NOTE, NO_TICK, ROUTINE_TEXT, PARAMETER_PACK, VOID_SYMBOL, COLON_SYMBOL, IDENTITY_RELATION, STOP); reduce (p, NO_NOTE, NO_TICK, ROUTINE_TEXT, PARAMETER_PACK, VOID_SYMBOL, COLON_SYMBOL, AND_FUNCTION, STOP); reduce (p, NO_NOTE, NO_TICK, ROUTINE_TEXT, PARAMETER_PACK, VOID_SYMBOL, COLON_SYMBOL, OR_FUNCTION, STOP); reduce (p, NO_NOTE, NO_TICK, ROUTINE_TEXT, PARAMETER_PACK, VOID_SYMBOL, COLON_SYMBOL, JUMP, STOP); reduce (p, NO_NOTE, NO_TICK, ROUTINE_TEXT, PARAMETER_PACK, VOID_SYMBOL, COLON_SYMBOL, SKIP, STOP); reduce (p, NO_NOTE, NO_TICK, ROUTINE_TEXT, PARAMETER_PACK, VOID_SYMBOL, COLON_SYMBOL, TERTIARY, STOP); reduce (p, NO_NOTE, NO_TICK, ROUTINE_TEXT, PARAMETER_PACK, VOID_SYMBOL, COLON_SYMBOL, ROUTINE_TEXT, STOP); reduce (p, NO_NOTE, NO_TICK, ROUTINE_TEXT, PARAMETER_PACK, VOID_SYMBOL, COLON_SYMBOL, CODE_CLAUSE, STOP); } /* Routine texts without parameter pack */ else if (IS (p, DECLARER)) { if (!(PREVIOUS (p) != NO_NODE && IS (PREVIOUS (p), PARAMETER_PACK))) { reduce (p, NO_NOTE, NO_TICK, ROUTINE_TEXT, DECLARER, COLON_SYMBOL, ASSIGNATION, STOP); reduce (p, NO_NOTE, NO_TICK, ROUTINE_TEXT, DECLARER, COLON_SYMBOL, IDENTITY_RELATION, STOP); reduce (p, NO_NOTE, NO_TICK, ROUTINE_TEXT, DECLARER, COLON_SYMBOL, AND_FUNCTION, STOP); reduce (p, NO_NOTE, NO_TICK, ROUTINE_TEXT, DECLARER, COLON_SYMBOL, OR_FUNCTION, STOP); reduce (p, NO_NOTE, NO_TICK, ROUTINE_TEXT, DECLARER, COLON_SYMBOL, JUMP, STOP); reduce (p, NO_NOTE, NO_TICK, ROUTINE_TEXT, DECLARER, COLON_SYMBOL, SKIP, STOP); reduce (p, NO_NOTE, NO_TICK, ROUTINE_TEXT, DECLARER, COLON_SYMBOL, TERTIARY, STOP); reduce (p, NO_NOTE, NO_TICK, ROUTINE_TEXT, DECLARER, COLON_SYMBOL, ROUTINE_TEXT, STOP); reduce (p, NO_NOTE, NO_TICK, ROUTINE_TEXT, DECLARER, COLON_SYMBOL, CODE_CLAUSE, STOP); } } else if (IS (p, VOID_SYMBOL)) { if (!(PREVIOUS (p) != NO_NODE && IS (PREVIOUS (p), PARAMETER_PACK))) { reduce (p, NO_NOTE, NO_TICK, ROUTINE_TEXT, VOID_SYMBOL, COLON_SYMBOL, ASSIGNATION, STOP); reduce (p, NO_NOTE, NO_TICK, ROUTINE_TEXT, VOID_SYMBOL, COLON_SYMBOL, IDENTITY_RELATION, STOP); reduce (p, NO_NOTE, NO_TICK, ROUTINE_TEXT, VOID_SYMBOL, COLON_SYMBOL, AND_FUNCTION, STOP); reduce (p, NO_NOTE, NO_TICK, ROUTINE_TEXT, VOID_SYMBOL, COLON_SYMBOL, OR_FUNCTION, STOP); reduce (p, NO_NOTE, NO_TICK, ROUTINE_TEXT, VOID_SYMBOL, COLON_SYMBOL, JUMP, STOP); reduce (p, NO_NOTE, NO_TICK, ROUTINE_TEXT, VOID_SYMBOL, COLON_SYMBOL, SKIP, STOP); reduce (p, NO_NOTE, NO_TICK, ROUTINE_TEXT, VOID_SYMBOL, COLON_SYMBOL, TERTIARY, STOP); reduce (p, NO_NOTE, NO_TICK, ROUTINE_TEXT, VOID_SYMBOL, COLON_SYMBOL, ROUTINE_TEXT, STOP); reduce (p, NO_NOTE, NO_TICK, ROUTINE_TEXT, VOID_SYMBOL, COLON_SYMBOL, CODE_CLAUSE, STOP); } } } } /*! \brief reduce primary elements \param p position in tree \param expect information the parser may have on what is expected **/ static void reduce_primary_parts (NODE_T * p, int expect) { NODE_T *q = p; for (; q != NO_NODE; FORWARD (q)) { if (whether (q, IDENTIFIER, OF_SYMBOL, STOP)) { ATTRIBUTE (q) = FIELD_IDENTIFIER; } reduce (q, NO_NOTE, NO_TICK, ENVIRON_NAME, ENVIRON_SYMBOL, ROW_CHAR_DENOTATION, STOP); reduce (q, NO_NOTE, NO_TICK, NIHIL, NIL_SYMBOL, STOP); reduce (q, NO_NOTE, NO_TICK, SKIP, SKIP_SYMBOL, STOP); reduce (q, NO_NOTE, NO_TICK, SELECTOR, FIELD_IDENTIFIER, OF_SYMBOL, STOP); /* JUMPs without GOTO are resolved later */ reduce (q, NO_NOTE, NO_TICK, JUMP, GOTO_SYMBOL, IDENTIFIER, STOP); reduce (q, NO_NOTE, NO_TICK, DENOTATION, LONGETY, INT_DENOTATION, STOP); reduce (q, NO_NOTE, NO_TICK, DENOTATION, LONGETY, REAL_DENOTATION, STOP); reduce (q, NO_NOTE, NO_TICK, DENOTATION, LONGETY, BITS_DENOTATION, STOP); reduce (q, NO_NOTE, NO_TICK, DENOTATION, SHORTETY, INT_DENOTATION, STOP); reduce (q, NO_NOTE, NO_TICK, DENOTATION, SHORTETY, REAL_DENOTATION, STOP); reduce (q, NO_NOTE, NO_TICK, DENOTATION, SHORTETY, BITS_DENOTATION, STOP); reduce (q, NO_NOTE, NO_TICK, DENOTATION, INT_DENOTATION, STOP); reduce (q, NO_NOTE, NO_TICK, DENOTATION, REAL_DENOTATION, STOP); reduce (q, NO_NOTE, NO_TICK, DENOTATION, BITS_DENOTATION, STOP); reduce (q, NO_NOTE, NO_TICK, DENOTATION, ROW_CHAR_DENOTATION, STOP); reduce (q, NO_NOTE, NO_TICK, DENOTATION, TRUE_SYMBOL, STOP); reduce (q, NO_NOTE, NO_TICK, DENOTATION, FALSE_SYMBOL, STOP); reduce (q, NO_NOTE, NO_TICK, DENOTATION, EMPTY_SYMBOL, STOP); if (expect == SERIAL_CLAUSE || expect == ENQUIRY_CLAUSE || expect == SOME_CLAUSE) { BOOL_T siga = A68_TRUE; while (siga) { siga = A68_FALSE; reduce (q, NO_NOTE, &siga, LABEL, DEFINING_IDENTIFIER, COLON_SYMBOL, STOP); reduce (q, NO_NOTE, &siga, LABEL, LABEL, DEFINING_IDENTIFIER, COLON_SYMBOL, STOP); } } } for (q = p; q != NO_NODE; FORWARD (q)) { #if defined HAVE_PARALLEL_CLAUSE reduce (q, NO_NOTE, NO_TICK, PARALLEL_CLAUSE, PAR_SYMBOL, COLLATERAL_CLAUSE, STOP); #else reduce (q, par_clause, NO_TICK, PARALLEL_CLAUSE, PAR_SYMBOL, COLLATERAL_CLAUSE, STOP); #endif reduce (q, NO_NOTE, NO_TICK, ENCLOSED_CLAUSE, PARALLEL_CLAUSE, STOP); reduce (q, NO_NOTE, NO_TICK, ENCLOSED_CLAUSE, CLOSED_CLAUSE, STOP); reduce (q, NO_NOTE, NO_TICK, ENCLOSED_CLAUSE, COLLATERAL_CLAUSE, STOP); reduce (q, NO_NOTE, NO_TICK, ENCLOSED_CLAUSE, CONDITIONAL_CLAUSE, STOP); reduce (q, NO_NOTE, NO_TICK, ENCLOSED_CLAUSE, CASE_CLAUSE, STOP); reduce (q, NO_NOTE, NO_TICK, ENCLOSED_CLAUSE, CONFORMITY_CLAUSE, STOP); reduce (q, NO_NOTE, NO_TICK, ENCLOSED_CLAUSE, LOOP_CLAUSE, STOP); } } /*! \brief reduce primaries completely \param p position in tree \param expect information the parser may have on what is expected **/ static void reduce_primaries (NODE_T * p, int expect) { NODE_T *q = p; while (q != NO_NODE) { BOOL_T fwd = A68_TRUE, siga; /* Primaries excepts call and slice */ reduce (q, NO_NOTE, NO_TICK, PRIMARY, IDENTIFIER, STOP); reduce (q, NO_NOTE, NO_TICK, PRIMARY, DENOTATION, STOP); reduce (q, NO_NOTE, NO_TICK, CAST, DECLARER, ENCLOSED_CLAUSE, STOP); reduce (q, NO_NOTE, NO_TICK, CAST, VOID_SYMBOL, ENCLOSED_CLAUSE, STOP); reduce (q, NO_NOTE, NO_TICK, ASSERTION, ASSERT_SYMBOL, ENCLOSED_CLAUSE, STOP); reduce (q, NO_NOTE, NO_TICK, PRIMARY, CAST, STOP); reduce (q, NO_NOTE, NO_TICK, PRIMARY, ENCLOSED_CLAUSE, STOP); reduce (q, NO_NOTE, NO_TICK, PRIMARY, FORMAT_TEXT, STOP); /* Call and slice */ siga = A68_TRUE; while (siga) { NODE_T *x = NEXT (q); siga = A68_FALSE; if (IS (q, PRIMARY) && x != NO_NODE) { if (IS (x, OPEN_SYMBOL)) { reduce_branch (NEXT (q), GENERIC_ARGUMENT); reduce (q, NO_NOTE, &siga, SPECIFICATION, PRIMARY, GENERIC_ARGUMENT, STOP); reduce (q, NO_NOTE, &siga, PRIMARY, SPECIFICATION, STOP); } else if (IS (x, SUB_SYMBOL)) { reduce_branch (NEXT (q), GENERIC_ARGUMENT); reduce (q, NO_NOTE, &siga, SPECIFICATION, PRIMARY, GENERIC_ARGUMENT, STOP); reduce (q, NO_NOTE, &siga, PRIMARY, SPECIFICATION, STOP); } } } /* Now that call and slice are known, reduce remaining ( .. ) */ if (IS (q, OPEN_SYMBOL) && SUB (q) != NO_NODE) { reduce_branch (q, SOME_CLAUSE); reduce (q, NO_NOTE, NO_TICK, ENCLOSED_CLAUSE, CLOSED_CLAUSE, STOP); reduce (q, NO_NOTE, NO_TICK, ENCLOSED_CLAUSE, COLLATERAL_CLAUSE, STOP); reduce (q, NO_NOTE, NO_TICK, ENCLOSED_CLAUSE, CONDITIONAL_CLAUSE, STOP); reduce (q, NO_NOTE, NO_TICK, ENCLOSED_CLAUSE, CASE_CLAUSE, STOP); reduce (q, NO_NOTE, NO_TICK, ENCLOSED_CLAUSE, CONFORMITY_CLAUSE, STOP); if (PREVIOUS (q) != NO_NODE) { BACKWARD (q); fwd = A68_FALSE; } } /* Format text items */ if (expect == FORMAT_TEXT) { NODE_T *r; for (r = p; r != NO_NODE; FORWARD (r)) { reduce (r, NO_NOTE, NO_TICK, DYNAMIC_REPLICATOR, FORMAT_ITEM_N, ENCLOSED_CLAUSE, STOP); reduce (r, NO_NOTE, NO_TICK, GENERAL_PATTERN, FORMAT_ITEM_G, ENCLOSED_CLAUSE, STOP); reduce (r, NO_NOTE, NO_TICK, GENERAL_PATTERN, FORMAT_ITEM_H, ENCLOSED_CLAUSE, STOP); reduce (r, NO_NOTE, NO_TICK, FORMAT_PATTERN, FORMAT_ITEM_F, ENCLOSED_CLAUSE, STOP); } } if (fwd) { FORWARD (q); } } } /*! \brief enforce that ambiguous patterns are separated by commas \param p position in tree **/ static void ambiguous_patterns (NODE_T * p) { /* Example: printf (($+d.2d +d.2d$, 1, 2)) can produce either "+1.00 +2.00" or "+1+002.00". A comma must be supplied to resolve the ambiguity. The obvious thing would be to weave this into the syntax, letting the BU parser sort it out. But the C-style patterns do not suffer from Algol 68 pattern ambiguity, so by solving it this way we maximise freedom in writing the patterns as we want without introducing two "kinds" of patterns, and so we have shorter routines for implementing formatted transput. This is a pragmatic system. */ NODE_T *q, *last_pat = NO_NODE; for (q = p; q != NO_NODE; FORWARD (q)) { switch (ATTRIBUTE (q)) { case INTEGRAL_PATTERN: /* These are the potentially ambiguous patterns */ case REAL_PATTERN: case COMPLEX_PATTERN: case BITS_PATTERN: { if (last_pat != NO_NODE) { diagnostic_node (A68_SYNTAX_ERROR, q, ERROR_COMMA_MUST_SEPARATE, ATTRIBUTE (last_pat), ATTRIBUTE (q)); } last_pat = q; break; } case COMMA_SYMBOL: { last_pat = NO_NODE; break; } } } } /*! \brief reduce format texts completely \param p position in tree **/ void reduce_c_pattern (NODE_T * p, int pr, int let) { NODE_T *q; for (q = p; q != NO_NODE; FORWARD (q)) { reduce (q, NO_NOTE, NO_TICK, pr, FORMAT_ITEM_ESCAPE, let, STOP); reduce (q, NO_NOTE, NO_TICK, pr, FORMAT_ITEM_ESCAPE, FORMAT_ITEM_POINT, REPLICATOR, let, STOP); reduce (q, NO_NOTE, NO_TICK, pr, FORMAT_ITEM_ESCAPE, REPLICATOR, let, STOP); reduce (q, NO_NOTE, NO_TICK, pr, FORMAT_ITEM_ESCAPE, REPLICATOR, FORMAT_ITEM_POINT, REPLICATOR, let, STOP); reduce (q, NO_NOTE, NO_TICK, pr, FORMAT_ITEM_ESCAPE, FORMAT_ITEM_PLUS, let, STOP); reduce (q, NO_NOTE, NO_TICK, pr, FORMAT_ITEM_ESCAPE, FORMAT_ITEM_PLUS, FORMAT_ITEM_POINT, REPLICATOR, let, STOP); reduce (q, NO_NOTE, NO_TICK, pr, FORMAT_ITEM_ESCAPE, FORMAT_ITEM_PLUS, REPLICATOR, let, STOP); reduce (q, NO_NOTE, NO_TICK, pr, FORMAT_ITEM_ESCAPE, FORMAT_ITEM_PLUS, REPLICATOR, FORMAT_ITEM_POINT, REPLICATOR, let, STOP); reduce (q, NO_NOTE, NO_TICK, pr, FORMAT_ITEM_ESCAPE, FORMAT_ITEM_MINUS, let, STOP); reduce (q, NO_NOTE, NO_TICK, pr, FORMAT_ITEM_ESCAPE, FORMAT_ITEM_MINUS, FORMAT_ITEM_POINT, REPLICATOR, let, STOP); reduce (q, NO_NOTE, NO_TICK, pr, FORMAT_ITEM_ESCAPE, FORMAT_ITEM_MINUS, REPLICATOR, let, STOP); reduce (q, NO_NOTE, NO_TICK, pr, FORMAT_ITEM_ESCAPE, FORMAT_ITEM_MINUS, REPLICATOR, FORMAT_ITEM_POINT, REPLICATOR, let, STOP); reduce (q, NO_NOTE, NO_TICK, pr, FORMAT_ITEM_ESCAPE, FORMAT_ITEM_MINUS, FORMAT_ITEM_PLUS, let, STOP); reduce (q, NO_NOTE, NO_TICK, pr, FORMAT_ITEM_ESCAPE, FORMAT_ITEM_MINUS, FORMAT_ITEM_PLUS, FORMAT_ITEM_POINT, REPLICATOR, let, STOP); reduce (q, NO_NOTE, NO_TICK, pr, FORMAT_ITEM_ESCAPE, FORMAT_ITEM_MINUS, FORMAT_ITEM_PLUS, REPLICATOR, let, STOP); reduce (q, NO_NOTE, NO_TICK, pr, FORMAT_ITEM_ESCAPE, FORMAT_ITEM_MINUS, FORMAT_ITEM_PLUS, REPLICATOR, FORMAT_ITEM_POINT, REPLICATOR, let, STOP); } } /*! \brief reduce format texts completely \param p position in tree **/ static void reduce_format_texts (NODE_T * p) { NODE_T *q; /* Replicators */ for (q = p; q != NO_NODE; FORWARD (q)) { reduce (q, NO_NOTE, NO_TICK, REPLICATOR, STATIC_REPLICATOR, STOP); reduce (q, NO_NOTE, NO_TICK, REPLICATOR, DYNAMIC_REPLICATOR, STOP); } /* "OTHER" patterns */ reduce_c_pattern (p, BITS_C_PATTERN, FORMAT_ITEM_B); reduce_c_pattern (p, BITS_C_PATTERN, FORMAT_ITEM_O); reduce_c_pattern (p, BITS_C_PATTERN, FORMAT_ITEM_X); reduce_c_pattern (p, CHAR_C_PATTERN, FORMAT_ITEM_C); reduce_c_pattern (p, FIXED_C_PATTERN, FORMAT_ITEM_F); reduce_c_pattern (p, FLOAT_C_PATTERN, FORMAT_ITEM_E); reduce_c_pattern (p, GENERAL_C_PATTERN, FORMAT_ITEM_G); reduce_c_pattern (p, INTEGRAL_C_PATTERN, FORMAT_ITEM_D); reduce_c_pattern (p, INTEGRAL_C_PATTERN, FORMAT_ITEM_I); reduce_c_pattern (p, STRING_C_PATTERN, FORMAT_ITEM_S); /* Radix frames */ for (q = p; q != NO_NODE; FORWARD (q)) { reduce (q, NO_NOTE, NO_TICK, RADIX_FRAME, REPLICATOR, FORMAT_ITEM_R, STOP); } /* Insertions */ for (q = p; q != NO_NODE; FORWARD (q)) { reduce (q, NO_NOTE, NO_TICK, INSERTION, FORMAT_ITEM_X, STOP); reduce (q, NO_NOTE, NO_TICK, INSERTION, FORMAT_ITEM_Y, STOP); reduce (q, NO_NOTE, NO_TICK, INSERTION, FORMAT_ITEM_L, STOP); reduce (q, NO_NOTE, NO_TICK, INSERTION, FORMAT_ITEM_P, STOP); reduce (q, NO_NOTE, NO_TICK, INSERTION, FORMAT_ITEM_Q, STOP); reduce (q, NO_NOTE, NO_TICK, INSERTION, FORMAT_ITEM_K, STOP); reduce (q, NO_NOTE, NO_TICK, INSERTION, LITERAL, STOP); } for (q = p; q != NO_NODE; FORWARD (q)) { reduce (q, NO_NOTE, NO_TICK, INSERTION, REPLICATOR, INSERTION, STOP); } for (q = p; q != NO_NODE; FORWARD (q)) { BOOL_T siga = A68_TRUE; while (siga) { siga = A68_FALSE; reduce (q, NO_NOTE, &siga, INSERTION, INSERTION, INSERTION, STOP); } } /* Replicated suppressible frames */ for (q = p; q != NO_NODE; FORWARD (q)) { reduce (q, NO_NOTE, NO_TICK, FORMAT_A_FRAME, REPLICATOR, FORMAT_ITEM_S, FORMAT_ITEM_A, STOP); reduce (q, NO_NOTE, NO_TICK, FORMAT_Z_FRAME, REPLICATOR, FORMAT_ITEM_S, FORMAT_ITEM_Z, STOP); reduce (q, NO_NOTE, NO_TICK, FORMAT_D_FRAME, REPLICATOR, FORMAT_ITEM_S, FORMAT_ITEM_D, STOP); } /* Suppressible frames */ for (q = p; q != NO_NODE; FORWARD (q)) { reduce (q, NO_NOTE, NO_TICK, FORMAT_A_FRAME, FORMAT_ITEM_S, FORMAT_ITEM_A, STOP); reduce (q, NO_NOTE, NO_TICK, FORMAT_Z_FRAME, FORMAT_ITEM_S, FORMAT_ITEM_Z, STOP); reduce (q, NO_NOTE, NO_TICK, FORMAT_D_FRAME, FORMAT_ITEM_S, FORMAT_ITEM_D, STOP); reduce (q, NO_NOTE, NO_TICK, FORMAT_E_FRAME, FORMAT_ITEM_S, FORMAT_ITEM_E, STOP); reduce (q, NO_NOTE, NO_TICK, FORMAT_POINT_FRAME, FORMAT_ITEM_S, FORMAT_ITEM_POINT, STOP); reduce (q, NO_NOTE, NO_TICK, FORMAT_I_FRAME, FORMAT_ITEM_S, FORMAT_ITEM_I, STOP); } /* Replicated frames */ for (q = p; q != NO_NODE; FORWARD (q)) { reduce (q, NO_NOTE, NO_TICK, FORMAT_A_FRAME, REPLICATOR, FORMAT_ITEM_A, STOP); reduce (q, NO_NOTE, NO_TICK, FORMAT_Z_FRAME, REPLICATOR, FORMAT_ITEM_Z, STOP); reduce (q, NO_NOTE, NO_TICK, FORMAT_D_FRAME, REPLICATOR, FORMAT_ITEM_D, STOP); } /* Frames */ for (q = p; q != NO_NODE; FORWARD (q)) { reduce (q, NO_NOTE, NO_TICK, FORMAT_A_FRAME, FORMAT_ITEM_A, STOP); reduce (q, NO_NOTE, NO_TICK, FORMAT_Z_FRAME, FORMAT_ITEM_Z, STOP); reduce (q, NO_NOTE, NO_TICK, FORMAT_D_FRAME, FORMAT_ITEM_D, STOP); reduce (q, NO_NOTE, NO_TICK, FORMAT_E_FRAME, FORMAT_ITEM_E, STOP); reduce (q, NO_NOTE, NO_TICK, FORMAT_POINT_FRAME, FORMAT_ITEM_POINT, STOP); reduce (q, NO_NOTE, NO_TICK, FORMAT_I_FRAME, FORMAT_ITEM_I, STOP); } /* Frames with an insertion */ for (q = p; q != NO_NODE; FORWARD (q)) { reduce (q, NO_NOTE, NO_TICK, FORMAT_A_FRAME, INSERTION, FORMAT_A_FRAME, STOP); reduce (q, NO_NOTE, NO_TICK, FORMAT_Z_FRAME, INSERTION, FORMAT_Z_FRAME, STOP); reduce (q, NO_NOTE, NO_TICK, FORMAT_D_FRAME, INSERTION, FORMAT_D_FRAME, STOP); reduce (q, NO_NOTE, NO_TICK, FORMAT_E_FRAME, INSERTION, FORMAT_E_FRAME, STOP); reduce (q, NO_NOTE, NO_TICK, FORMAT_POINT_FRAME, INSERTION, FORMAT_POINT_FRAME, STOP); reduce (q, NO_NOTE, NO_TICK, FORMAT_I_FRAME, INSERTION, FORMAT_I_FRAME, STOP); } /* String patterns */ for (q = p; q != NO_NODE; FORWARD (q)) { reduce (q, NO_NOTE, NO_TICK, STRING_PATTERN, REPLICATOR, FORMAT_A_FRAME, STOP); } for (q = p; q != NO_NODE; FORWARD (q)) { reduce (q, NO_NOTE, NO_TICK, STRING_PATTERN, FORMAT_A_FRAME, STOP); } for (q = p; q != NO_NODE; FORWARD (q)) { BOOL_T siga = A68_TRUE; while (siga) { siga = A68_FALSE; reduce (q, NO_NOTE, &siga, STRING_PATTERN, STRING_PATTERN, STRING_PATTERN, STOP); reduce (q, NO_NOTE, &siga, STRING_PATTERN, STRING_PATTERN, INSERTION, STRING_PATTERN, STOP); } } /* Integral moulds */ for (q = p; q != NO_NODE; FORWARD (q)) { reduce (q, NO_NOTE, NO_TICK, INTEGRAL_MOULD, FORMAT_Z_FRAME, STOP); reduce (q, NO_NOTE, NO_TICK, INTEGRAL_MOULD, FORMAT_D_FRAME, STOP); } for (q = p; q != NO_NODE; FORWARD (q)) { BOOL_T siga = A68_TRUE; while (siga) { siga = A68_FALSE; reduce (q, NO_NOTE, &siga, INTEGRAL_MOULD, INTEGRAL_MOULD, INTEGRAL_MOULD, STOP); reduce (q, NO_NOTE, &siga, INTEGRAL_MOULD, INTEGRAL_MOULD, INSERTION, STOP); } } /* Sign moulds */ for (q = p; q != NO_NODE; FORWARD (q)) { reduce (q, NO_NOTE, NO_TICK, SIGN_MOULD, INTEGRAL_MOULD, FORMAT_ITEM_PLUS, STOP); reduce (q, NO_NOTE, NO_TICK, SIGN_MOULD, INTEGRAL_MOULD, FORMAT_ITEM_MINUS, STOP); } for (q = p; q != NO_NODE; FORWARD (q)) { reduce (q, NO_NOTE, NO_TICK, SIGN_MOULD, FORMAT_ITEM_PLUS, STOP); reduce (q, NO_NOTE, NO_TICK, SIGN_MOULD, FORMAT_ITEM_MINUS, STOP); } /* Exponent frames */ for (q = p; q != NO_NODE; FORWARD (q)) { reduce (q, NO_NOTE, NO_TICK, EXPONENT_FRAME, FORMAT_E_FRAME, SIGN_MOULD, INTEGRAL_MOULD, STOP); reduce (q, NO_NOTE, NO_TICK, EXPONENT_FRAME, FORMAT_E_FRAME, INTEGRAL_MOULD, STOP); } /* Real patterns */ for (q = p; q != NO_NODE; FORWARD (q)) { reduce (q, NO_NOTE, NO_TICK, REAL_PATTERN, SIGN_MOULD, INTEGRAL_MOULD, FORMAT_POINT_FRAME, INTEGRAL_MOULD, EXPONENT_FRAME, STOP); reduce (q, NO_NOTE, NO_TICK, REAL_PATTERN, SIGN_MOULD, INTEGRAL_MOULD, FORMAT_POINT_FRAME, INTEGRAL_MOULD, STOP); reduce (q, NO_NOTE, NO_TICK, REAL_PATTERN, SIGN_MOULD, INTEGRAL_MOULD, FORMAT_POINT_FRAME, EXPONENT_FRAME, STOP); reduce (q, NO_NOTE, NO_TICK, REAL_PATTERN, SIGN_MOULD, INTEGRAL_MOULD, FORMAT_POINT_FRAME, STOP); } for (q = p; q != NO_NODE; FORWARD (q)) { reduce (q, NO_NOTE, NO_TICK, REAL_PATTERN, SIGN_MOULD, FORMAT_POINT_FRAME, INTEGRAL_MOULD, EXPONENT_FRAME, STOP); reduce (q, NO_NOTE, NO_TICK, REAL_PATTERN, SIGN_MOULD, FORMAT_POINT_FRAME, INTEGRAL_MOULD, STOP); reduce (q, NO_NOTE, NO_TICK, REAL_PATTERN, SIGN_MOULD, FORMAT_POINT_FRAME, EXPONENT_FRAME, STOP); reduce (q, NO_NOTE, NO_TICK, REAL_PATTERN, SIGN_MOULD, FORMAT_POINT_FRAME, STOP); } for (q = p; q != NO_NODE; FORWARD (q)) { reduce (q, NO_NOTE, NO_TICK, REAL_PATTERN, INTEGRAL_MOULD, FORMAT_POINT_FRAME, INTEGRAL_MOULD, EXPONENT_FRAME, STOP); reduce (q, NO_NOTE, NO_TICK, REAL_PATTERN, INTEGRAL_MOULD, FORMAT_POINT_FRAME, INTEGRAL_MOULD, STOP); reduce (q, NO_NOTE, NO_TICK, REAL_PATTERN, INTEGRAL_MOULD, FORMAT_POINT_FRAME, EXPONENT_FRAME, STOP); reduce (q, NO_NOTE, NO_TICK, REAL_PATTERN, INTEGRAL_MOULD, FORMAT_POINT_FRAME, STOP); reduce (q, NO_NOTE, NO_TICK, REAL_PATTERN, FORMAT_POINT_FRAME, INTEGRAL_MOULD, EXPONENT_FRAME, STOP); reduce (q, NO_NOTE, NO_TICK, REAL_PATTERN, FORMAT_POINT_FRAME, INTEGRAL_MOULD, STOP); } for (q = p; q != NO_NODE; FORWARD (q)) { reduce (q, NO_NOTE, NO_TICK, REAL_PATTERN, SIGN_MOULD, INTEGRAL_MOULD, EXPONENT_FRAME, STOP); reduce (q, NO_NOTE, NO_TICK, REAL_PATTERN, INTEGRAL_MOULD, EXPONENT_FRAME, STOP); } /* Complex patterns */ for (q = p; q != NO_NODE; FORWARD (q)) { reduce (q, NO_NOTE, NO_TICK, COMPLEX_PATTERN, REAL_PATTERN, FORMAT_I_FRAME, REAL_PATTERN, STOP); } /* Bits patterns */ for (q = p; q != NO_NODE; FORWARD (q)) { reduce (q, NO_NOTE, NO_TICK, BITS_PATTERN, RADIX_FRAME, INTEGRAL_MOULD, STOP); } /* Integral patterns */ for (q = p; q != NO_NODE; FORWARD (q)) { reduce (q, NO_NOTE, NO_TICK, INTEGRAL_PATTERN, SIGN_MOULD, INTEGRAL_MOULD, STOP); reduce (q, NO_NOTE, NO_TICK, INTEGRAL_PATTERN, INTEGRAL_MOULD, STOP); } /* Patterns */ for (q = p; q != NO_NODE; FORWARD (q)) { reduce (q, NO_NOTE, NO_TICK, BOOLEAN_PATTERN, FORMAT_ITEM_B, COLLECTION, STOP); reduce (q, NO_NOTE, NO_TICK, CHOICE_PATTERN, FORMAT_ITEM_C, COLLECTION, STOP); } for (q = p; q != NO_NODE; FORWARD (q)) { reduce (q, NO_NOTE, NO_TICK, BOOLEAN_PATTERN, FORMAT_ITEM_B, STOP); reduce (q, NO_NOTE, NO_TICK, GENERAL_PATTERN, FORMAT_ITEM_G, STOP); reduce (q, NO_NOTE, NO_TICK, GENERAL_PATTERN, FORMAT_ITEM_H, STOP); } ambiguous_patterns (p); for (q = p; q != NO_NODE; FORWARD (q)) { reduce (q, a68_extension, NO_TICK, A68_PATTERN, BITS_C_PATTERN, STOP); reduce (q, a68_extension, NO_TICK, A68_PATTERN, CHAR_C_PATTERN, STOP); reduce (q, a68_extension, NO_TICK, A68_PATTERN, FIXED_C_PATTERN, STOP); reduce (q, a68_extension, NO_TICK, A68_PATTERN, FLOAT_C_PATTERN, STOP); reduce (q, a68_extension, NO_TICK, A68_PATTERN, GENERAL_C_PATTERN, STOP); reduce (q, a68_extension, NO_TICK, A68_PATTERN, INTEGRAL_C_PATTERN, STOP); reduce (q, a68_extension, NO_TICK, A68_PATTERN, STRING_C_PATTERN, STOP); reduce (q, NO_NOTE, NO_TICK, A68_PATTERN, BITS_PATTERN, STOP); reduce (q, NO_NOTE, NO_TICK, A68_PATTERN, BOOLEAN_PATTERN, STOP); reduce (q, NO_NOTE, NO_TICK, A68_PATTERN, CHOICE_PATTERN, STOP); reduce (q, NO_NOTE, NO_TICK, A68_PATTERN, COMPLEX_PATTERN, STOP); reduce (q, NO_NOTE, NO_TICK, A68_PATTERN, FORMAT_PATTERN, STOP); reduce (q, NO_NOTE, NO_TICK, A68_PATTERN, GENERAL_PATTERN, STOP); reduce (q, NO_NOTE, NO_TICK, A68_PATTERN, INTEGRAL_PATTERN, STOP); reduce (q, NO_NOTE, NO_TICK, A68_PATTERN, REAL_PATTERN, STOP); reduce (q, NO_NOTE, NO_TICK, A68_PATTERN, STRING_PATTERN, STOP); } /* Pictures */ for (q = p; q != NO_NODE; FORWARD (q)) { reduce (q, NO_NOTE, NO_TICK, PICTURE, INSERTION, STOP); reduce (q, NO_NOTE, NO_TICK, PICTURE, A68_PATTERN, STOP); reduce (q, NO_NOTE, NO_TICK, PICTURE, COLLECTION, STOP); reduce (q, NO_NOTE, NO_TICK, PICTURE, REPLICATOR, COLLECTION, STOP); } /* Picture lists */ for (q = p; q != NO_NODE; FORWARD (q)) { if (IS (q, PICTURE)) { BOOL_T siga = A68_TRUE; reduce (q, NO_NOTE, NO_TICK, PICTURE_LIST, PICTURE, STOP); while (siga) { siga = A68_FALSE; reduce (q, NO_NOTE, &siga, PICTURE_LIST, PICTURE_LIST, COMMA_SYMBOL, PICTURE, STOP); /* We filtered ambiguous patterns, so commas may be omitted */ reduce (q, NO_NOTE, &siga, PICTURE_LIST, PICTURE_LIST, PICTURE, STOP); } } } } /*! \brief reduce secondaries completely \param p position in tree **/ static void reduce_secondaries (NODE_T * p) { NODE_T *q; BOOL_T siga; for (q = p; q != NO_NODE; FORWARD (q)) { reduce (q, NO_NOTE, NO_TICK, SECONDARY, PRIMARY, STOP); reduce (q, NO_NOTE, NO_TICK, GENERATOR, LOC_SYMBOL, DECLARER, STOP); reduce (q, NO_NOTE, NO_TICK, GENERATOR, HEAP_SYMBOL, DECLARER, STOP); reduce (q, NO_NOTE, NO_TICK, GENERATOR, NEW_SYMBOL, DECLARER, STOP); reduce (q, NO_NOTE, NO_TICK, SECONDARY, GENERATOR, STOP); } siga = A68_TRUE; while (siga) { siga = A68_FALSE; for (q = p; NEXT (q) != NO_NODE; FORWARD (q)) { ; } for (; q != NO_NODE; BACKWARD (q)) { reduce (q, NO_NOTE, &siga, SELECTION, SELECTOR, SECONDARY, STOP); reduce (q, NO_NOTE, &siga, SECONDARY, SELECTION, STOP); } } } /*! \brief whether "q" is an operator with priority "k" \param q operator token \param k priority \return whether "q" is an operator with priority "k" **/ static int operator_with_priority (NODE_T * q, int k) { return (NEXT (q) != NO_NODE && ATTRIBUTE (NEXT (q)) == OPERATOR && PRIO (INFO (NEXT (q))) == k); } /*! \brief reduce formulae \param p position in tree **/ static void reduce_formulae (NODE_T * p) { NODE_T *q = p; int priority; while (q != NO_NODE) { if (is_one_of (q, OPERATOR, SECONDARY, STOP)) { q = reduce_dyadic (q, STOP); } else { FORWARD (q); } } /* Reduce the expression */ for (priority = MAX_PRIORITY; priority >= 0; priority--) { for (q = p; q != NO_NODE; FORWARD (q)) { if (operator_with_priority (q, priority)) { BOOL_T siga = A68_FALSE; NODE_T *op = NEXT (q); if (IS (q, SECONDARY)) { reduce (q, NO_NOTE, &siga, FORMULA, SECONDARY, OPERATOR, SECONDARY, STOP); reduce (q, NO_NOTE, &siga, FORMULA, SECONDARY, OPERATOR, MONADIC_FORMULA, STOP); reduce (q, NO_NOTE, &siga, FORMULA, SECONDARY, OPERATOR, FORMULA, STOP); } else if (IS (q, MONADIC_FORMULA)) { reduce (q, NO_NOTE, &siga, FORMULA, MONADIC_FORMULA, OPERATOR, SECONDARY, STOP); reduce (q, NO_NOTE, &siga, FORMULA, MONADIC_FORMULA, OPERATOR, MONADIC_FORMULA, STOP); reduce (q, NO_NOTE, &siga, FORMULA, MONADIC_FORMULA, OPERATOR, FORMULA, STOP); } if (priority == 0 && siga) { diagnostic_node (A68_SYNTAX_ERROR, op, ERROR_NO_PRIORITY); } siga = A68_TRUE; while (siga) { NODE_T *op2 = NEXT (q); siga = A68_FALSE; if (operator_with_priority (q, priority)) { reduce (q, NO_NOTE, &siga, FORMULA, FORMULA, OPERATOR, SECONDARY, STOP); } if (operator_with_priority (q, priority)) { reduce (q, NO_NOTE, &siga, FORMULA, FORMULA, OPERATOR, MONADIC_FORMULA, STOP); } if (operator_with_priority (q, priority)) { reduce (q, NO_NOTE, &siga, FORMULA, FORMULA, OPERATOR, FORMULA, STOP); } if (priority == 0 && siga) { diagnostic_node (A68_SYNTAX_ERROR, op2, ERROR_NO_PRIORITY); } } } } } } /*! \brief reduce dyadic expressions \param p position in tree \param u current priority \return token from where to continue **/ static NODE_T *reduce_dyadic (NODE_T * p, int u) { /* We work inside out - higher priority expressions get reduced first */ if (u > MAX_PRIORITY) { if (p == NO_NODE) { return (NO_NODE); } else if (IS (p, OPERATOR)) { /* Reduce monadic formulas */ NODE_T *q = p; BOOL_T siga; do { PRIO (INFO (q)) = 10; siga = (BOOL_T) ((NEXT (q) != NO_NODE) && (IS (NEXT (q), OPERATOR))); if (siga) { FORWARD (q); } } while (siga); reduce (q, NO_NOTE, NO_TICK, MONADIC_FORMULA, OPERATOR, SECONDARY, STOP); while (q != p) { BACKWARD (q); reduce (q, NO_NOTE, NO_TICK, MONADIC_FORMULA, OPERATOR, MONADIC_FORMULA, STOP); } } FORWARD (p); } else { p = reduce_dyadic (p, u + 1); while (p != NO_NODE && IS (p, OPERATOR) && PRIO (INFO (p)) == u) { FORWARD (p); p = reduce_dyadic (p, u + 1); } } return (p); } /*! \brief reduce tertiaries completely \param p position in tree **/ static void reduce_tertiaries (NODE_T * p) { NODE_T *q; BOOL_T siga; for (q = p; q != NO_NODE; FORWARD (q)) { reduce (q, NO_NOTE, NO_TICK, TERTIARY, NIHIL, STOP); reduce (q, NO_NOTE, NO_TICK, FORMULA, MONADIC_FORMULA, STOP); reduce (q, NO_NOTE, NO_TICK, TERTIARY, FORMULA, STOP); reduce (q, NO_NOTE, NO_TICK, TERTIARY, SECONDARY, STOP); } siga = A68_TRUE; while (siga) { siga = A68_FALSE; for (q = p; q != NO_NODE; FORWARD (q)) { reduce (q, NO_NOTE, &siga, TRANSPOSE_FUNCTION, TRANSPOSE_SYMBOL, TERTIARY, STOP); reduce (q, NO_NOTE, &siga, DIAGONAL_FUNCTION, TERTIARY, DIAGONAL_SYMBOL, TERTIARY, STOP); reduce (q, NO_NOTE, &siga, DIAGONAL_FUNCTION, DIAGONAL_SYMBOL, TERTIARY, STOP); reduce (q, NO_NOTE, &siga, COLUMN_FUNCTION, TERTIARY, COLUMN_SYMBOL, TERTIARY, STOP); reduce (q, NO_NOTE, &siga, COLUMN_FUNCTION, COLUMN_SYMBOL, TERTIARY, STOP); reduce (q, NO_NOTE, &siga, ROW_FUNCTION, TERTIARY, ROW_SYMBOL, TERTIARY, STOP); reduce (q, NO_NOTE, &siga, ROW_FUNCTION, ROW_SYMBOL, TERTIARY, STOP); } for (q = p; q != NO_NODE; FORWARD (q)) { reduce (q, a68_extension, &siga, TERTIARY, TRANSPOSE_FUNCTION, STOP); reduce (q, a68_extension, &siga, TERTIARY, DIAGONAL_FUNCTION, STOP); reduce (q, a68_extension, &siga, TERTIARY, COLUMN_FUNCTION, STOP); reduce (q, a68_extension, &siga, TERTIARY, ROW_FUNCTION, STOP); } } for (q = p; q != NO_NODE; FORWARD (q)) { reduce (q, NO_NOTE, NO_TICK, IDENTITY_RELATION, TERTIARY, IS_SYMBOL, TERTIARY, STOP); reduce (q, NO_NOTE, NO_TICK, IDENTITY_RELATION, TERTIARY, ISNT_SYMBOL, TERTIARY, STOP); } for (q = p; q != NO_NODE; FORWARD (q)) { reduce (q, NO_NOTE, NO_TICK, AND_FUNCTION, TERTIARY, ANDF_SYMBOL, TERTIARY, STOP); reduce (q, NO_NOTE, NO_TICK, OR_FUNCTION, TERTIARY, ORF_SYMBOL, TERTIARY, STOP); } } /*! \brief reduce units \param p position in tree **/ static void reduce_units (NODE_T * p) { NODE_T *q; /* Stray ~ is a SKIP */ for (q = p; q != NO_NODE; FORWARD (q)) { if (IS (q, OPERATOR) && IS_LITERALLY (q, "~")) { ATTRIBUTE (q) = SKIP; } } /* Reduce units */ for (q = p; q != NO_NODE; FORWARD (q)) { reduce (q, NO_NOTE, NO_TICK, UNIT, ASSIGNATION, STOP); reduce (q, NO_NOTE, NO_TICK, UNIT, IDENTITY_RELATION, STOP); reduce (q, a68_extension, NO_TICK, UNIT, AND_FUNCTION, STOP); reduce (q, a68_extension, NO_TICK, UNIT, OR_FUNCTION, STOP); reduce (q, NO_NOTE, NO_TICK, UNIT, ROUTINE_TEXT, STOP); reduce (q, NO_NOTE, NO_TICK, UNIT, JUMP, STOP); reduce (q, NO_NOTE, NO_TICK, UNIT, SKIP, STOP); reduce (q, NO_NOTE, NO_TICK, UNIT, TERTIARY, STOP); reduce (q, NO_NOTE, NO_TICK, UNIT, ASSERTION, STOP); reduce (q, NO_NOTE, NO_TICK, UNIT, CODE_CLAUSE, STOP); } } /*! \brief reduce_generic arguments \param p position in tree **/ static void reduce_generic_arguments (NODE_T * p) { NODE_T *q; BOOL_T siga; for (q = p; q != NO_NODE; FORWARD (q)) { if (IS (q, UNIT)) { reduce (q, NO_NOTE, NO_TICK, TRIMMER, UNIT, COLON_SYMBOL, UNIT, AT_SYMBOL, UNIT, STOP); reduce (q, NO_NOTE, NO_TICK, TRIMMER, UNIT, COLON_SYMBOL, UNIT, STOP); reduce (q, NO_NOTE, NO_TICK, TRIMMER, UNIT, COLON_SYMBOL, AT_SYMBOL, UNIT, STOP); reduce (q, NO_NOTE, NO_TICK, TRIMMER, UNIT, COLON_SYMBOL, STOP); reduce (q, NO_NOTE, NO_TICK, TRIMMER, UNIT, DOTDOT_SYMBOL, UNIT, AT_SYMBOL, UNIT, STOP); reduce (q, NO_NOTE, NO_TICK, TRIMMER, UNIT, DOTDOT_SYMBOL, UNIT, STOP); reduce (q, NO_NOTE, NO_TICK, TRIMMER, UNIT, DOTDOT_SYMBOL, AT_SYMBOL, UNIT, STOP); reduce (q, NO_NOTE, NO_TICK, TRIMMER, UNIT, DOTDOT_SYMBOL, STOP); } else if (IS (q, COLON_SYMBOL)) { reduce (q, NO_NOTE, NO_TICK, TRIMMER, COLON_SYMBOL, UNIT, AT_SYMBOL, UNIT, STOP); reduce (q, NO_NOTE, NO_TICK, TRIMMER, COLON_SYMBOL, UNIT, STOP); reduce (q, NO_NOTE, NO_TICK, TRIMMER, COLON_SYMBOL, AT_SYMBOL, UNIT, STOP); reduce (q, NO_NOTE, NO_TICK, TRIMMER, COLON_SYMBOL, STOP); } else if (IS (q, DOTDOT_SYMBOL)) { reduce (q, NO_NOTE, NO_TICK, TRIMMER, DOTDOT_SYMBOL, UNIT, AT_SYMBOL, UNIT, STOP); reduce (q, NO_NOTE, NO_TICK, TRIMMER, DOTDOT_SYMBOL, UNIT, STOP); reduce (q, NO_NOTE, NO_TICK, TRIMMER, DOTDOT_SYMBOL, AT_SYMBOL, UNIT, STOP); reduce (q, NO_NOTE, NO_TICK, TRIMMER, DOTDOT_SYMBOL, STOP); } } for (q = p; q != NO_NODE; FORWARD (q)) { reduce (q, NO_NOTE, NO_TICK, TRIMMER, UNIT, AT_SYMBOL, UNIT, STOP); } for (q = p; q != NO_NODE; FORWARD (q)) { reduce (q, NO_NOTE, NO_TICK, TRIMMER, AT_SYMBOL, UNIT, STOP); } for (q = p; q && NEXT (q); FORWARD (q)) { if (IS (q, COMMA_SYMBOL)) { if (!(ATTRIBUTE (NEXT (q)) == UNIT || ATTRIBUTE (NEXT (q)) == TRIMMER)) { pad_node (q, TRIMMER); } } else { if (IS (NEXT (q), COMMA_SYMBOL)) { if (ISNT (q, UNIT) && ISNT (q, TRIMMER)) { pad_node (q, TRIMMER); } } } } q = NEXT (p); ABEND (q == NO_NODE, "erroneous parser state", NO_TEXT); reduce (q, NO_NOTE, NO_TICK, GENERIC_ARGUMENT_LIST, UNIT, STOP); reduce (q, NO_NOTE, NO_TICK, GENERIC_ARGUMENT_LIST, TRIMMER, STOP); do { siga = A68_FALSE; reduce (q, NO_NOTE, &siga, GENERIC_ARGUMENT_LIST, GENERIC_ARGUMENT_LIST, COMMA_SYMBOL, UNIT, STOP); reduce (q, NO_NOTE, &siga, GENERIC_ARGUMENT_LIST, GENERIC_ARGUMENT_LIST, COMMA_SYMBOL, TRIMMER, STOP); reduce (q, strange_separator, &siga, GENERIC_ARGUMENT_LIST, GENERIC_ARGUMENT_LIST, UNIT, STOP); reduce (q, strange_separator, &siga, GENERIC_ARGUMENT_LIST, GENERIC_ARGUMENT_LIST, TRIMMER, STOP); } while (siga); } /*! \brief reduce bounds \param p position in tree **/ static void reduce_bounds (NODE_T * p) { NODE_T *q; BOOL_T siga; for (q = p; q != NO_NODE; FORWARD (q)) { reduce (q, NO_NOTE, NO_TICK, BOUND, UNIT, COLON_SYMBOL, UNIT, STOP); reduce (q, NO_NOTE, NO_TICK, BOUND, UNIT, DOTDOT_SYMBOL, UNIT, STOP); reduce (q, NO_NOTE, NO_TICK, BOUND, UNIT, STOP); } q = NEXT (p); reduce (q, NO_NOTE, NO_TICK, BOUNDS_LIST, BOUND, STOP); reduce (q, NO_NOTE, NO_TICK, FORMAL_BOUNDS_LIST, COMMA_SYMBOL, STOP); reduce (q, NO_NOTE, NO_TICK, ALT_FORMAL_BOUNDS_LIST, COLON_SYMBOL, STOP); reduce (q, NO_NOTE, NO_TICK, ALT_FORMAL_BOUNDS_LIST, DOTDOT_SYMBOL, STOP); do { siga = A68_FALSE; reduce (q, NO_NOTE, &siga, BOUNDS_LIST, BOUNDS_LIST, COMMA_SYMBOL, BOUND, STOP); reduce (q, NO_NOTE, &siga, FORMAL_BOUNDS_LIST, FORMAL_BOUNDS_LIST, COMMA_SYMBOL, STOP); reduce (q, NO_NOTE, &siga, ALT_FORMAL_BOUNDS_LIST, FORMAL_BOUNDS_LIST, COLON_SYMBOL, STOP); reduce (q, NO_NOTE, &siga, ALT_FORMAL_BOUNDS_LIST, FORMAL_BOUNDS_LIST, DOTDOT_SYMBOL, STOP); reduce (q, NO_NOTE, &siga, FORMAL_BOUNDS_LIST, ALT_FORMAL_BOUNDS_LIST, COMMA_SYMBOL, STOP); reduce (q, strange_separator, &siga, BOUNDS_LIST, BOUNDS_LIST, BOUND, STOP); } while (siga); } /*! \brief reduce argument packs \param p position in tree **/ static void reduce_arguments (NODE_T * p) { if (NEXT (p) != NO_NODE) { NODE_T *q = NEXT (p); BOOL_T siga; reduce (q, NO_NOTE, NO_TICK, ARGUMENT_LIST, UNIT, STOP); do { siga = A68_FALSE; reduce (q, NO_NOTE, &siga, ARGUMENT_LIST, ARGUMENT_LIST, COMMA_SYMBOL, UNIT, STOP); reduce (q, strange_separator, &siga, ARGUMENT_LIST, ARGUMENT_LIST, UNIT, STOP); } while (siga); } } /*! \brief reduce declarations \param p position in tree **/ static void reduce_basic_declarations (NODE_T * p) { NODE_T *q; for (q = p; q != NO_NODE; FORWARD (q)) { reduce (q, NO_NOTE, NO_TICK, ENVIRON_NAME, ENVIRON_SYMBOL, ROW_CHAR_DENOTATION, STOP); reduce (q, NO_NOTE, NO_TICK, PRIORITY_DECLARATION, PRIO_SYMBOL, DEFINING_OPERATOR, EQUALS_SYMBOL, PRIORITY, STOP); reduce (q, NO_NOTE, NO_TICK, MODE_DECLARATION, MODE_SYMBOL, DEFINING_INDICANT, EQUALS_SYMBOL, DECLARER, STOP); reduce (q, NO_NOTE, NO_TICK, MODE_DECLARATION, MODE_SYMBOL, DEFINING_INDICANT, EQUALS_SYMBOL, VOID_SYMBOL, STOP); reduce (q, NO_NOTE, NO_TICK, PROCEDURE_DECLARATION, PROC_SYMBOL, DEFINING_IDENTIFIER, EQUALS_SYMBOL, ROUTINE_TEXT, STOP); reduce (q, NO_NOTE, NO_TICK, PROCEDURE_VARIABLE_DECLARATION, PROC_SYMBOL, DEFINING_IDENTIFIER, ASSIGN_SYMBOL, ROUTINE_TEXT, STOP); reduce (q, NO_NOTE, NO_TICK, PROCEDURE_VARIABLE_DECLARATION, QUALIFIER, PROC_SYMBOL, DEFINING_IDENTIFIER, ASSIGN_SYMBOL, ROUTINE_TEXT, STOP); reduce (q, NO_NOTE, NO_TICK, BRIEF_OPERATOR_DECLARATION, OP_SYMBOL, DEFINING_OPERATOR, EQUALS_SYMBOL, ROUTINE_TEXT, STOP); /* Errors */ reduce (q, strange_tokens, NO_TICK, PRIORITY_DECLARATION, PRIO_SYMBOL, -DEFINING_OPERATOR, -EQUALS_SYMBOL, -PRIORITY, STOP); reduce (q, strange_tokens, NO_TICK, MODE_DECLARATION, MODE_SYMBOL, DEFINING_INDICANT, EQUALS_SYMBOL, -DECLARER, STOP); reduce (q, strange_tokens, NO_TICK, PROCEDURE_DECLARATION, PROC_SYMBOL, DEFINING_IDENTIFIER, EQUALS_SYMBOL, -ROUTINE_TEXT, STOP); reduce (q, strange_tokens, NO_TICK, PROCEDURE_VARIABLE_DECLARATION, PROC_SYMBOL, DEFINING_IDENTIFIER, ASSIGN_SYMBOL, -ROUTINE_TEXT, STOP); reduce (q, strange_tokens, NO_TICK, PROCEDURE_VARIABLE_DECLARATION, QUALIFIER, PROC_SYMBOL, DEFINING_IDENTIFIER, ASSIGN_SYMBOL, -ROUTINE_TEXT, STOP); reduce (q, strange_tokens, NO_TICK, BRIEF_OPERATOR_DECLARATION, OP_SYMBOL, DEFINING_OPERATOR, EQUALS_SYMBOL, -ROUTINE_TEXT, STOP); /* Errors. WILDCARD catches TERTIARY which catches IDENTIFIER */ reduce (q, strange_tokens, NO_TICK, PROCEDURE_DECLARATION, PROC_SYMBOL, WILDCARD, ROUTINE_TEXT, STOP); } for (q = p; q != NO_NODE; FORWARD (q)) { BOOL_T siga; do { siga = A68_FALSE; reduce (q, NO_NOTE, &siga, ENVIRON_NAME, ENVIRON_NAME, COMMA_SYMBOL, ROW_CHAR_DENOTATION, STOP); reduce (q, NO_NOTE, &siga, PRIORITY_DECLARATION, PRIORITY_DECLARATION, COMMA_SYMBOL, DEFINING_OPERATOR, EQUALS_SYMBOL, PRIORITY, STOP); reduce (q, NO_NOTE, &siga, MODE_DECLARATION, MODE_DECLARATION, COMMA_SYMBOL, DEFINING_INDICANT, EQUALS_SYMBOL, DECLARER, STOP); reduce (q, NO_NOTE, &siga, MODE_DECLARATION, MODE_DECLARATION, COMMA_SYMBOL, DEFINING_INDICANT, EQUALS_SYMBOL, VOID_SYMBOL, STOP); reduce (q, NO_NOTE, &siga, PROCEDURE_DECLARATION, PROCEDURE_DECLARATION, COMMA_SYMBOL, DEFINING_IDENTIFIER, EQUALS_SYMBOL, ROUTINE_TEXT, STOP); reduce (q, NO_NOTE, &siga, PROCEDURE_VARIABLE_DECLARATION, PROCEDURE_VARIABLE_DECLARATION, COMMA_SYMBOL, DEFINING_IDENTIFIER, ASSIGN_SYMBOL, ROUTINE_TEXT, STOP); reduce (q, NO_NOTE, &siga, BRIEF_OPERATOR_DECLARATION, BRIEF_OPERATOR_DECLARATION, COMMA_SYMBOL, DEFINING_OPERATOR, EQUALS_SYMBOL, ROUTINE_TEXT, STOP); /* Errors. WILDCARD catches TERTIARY which catches IDENTIFIER */ reduce (q, strange_tokens, &siga, PROCEDURE_DECLARATION, PROCEDURE_DECLARATION, COMMA_SYMBOL, WILDCARD, ROUTINE_TEXT, STOP); } while (siga); } } /*! \brief reduce declaration lists \param p position in tree **/ static void reduce_declaration_lists (NODE_T * p) { NODE_T *q; for (q = p; q != NO_NODE; FORWARD (q)) { reduce (q, NO_NOTE, NO_TICK, IDENTITY_DECLARATION, DECLARER, DEFINING_IDENTIFIER, EQUALS_SYMBOL, UNIT, STOP); reduce (q, NO_NOTE, NO_TICK, VARIABLE_DECLARATION, QUALIFIER, DECLARER, DEFINING_IDENTIFIER, ASSIGN_SYMBOL, UNIT, STOP); reduce (q, NO_NOTE, NO_TICK, VARIABLE_DECLARATION, QUALIFIER, DECLARER, DEFINING_IDENTIFIER, STOP); reduce (q, NO_NOTE, NO_TICK, VARIABLE_DECLARATION, DECLARER, DEFINING_IDENTIFIER, ASSIGN_SYMBOL, UNIT, STOP); reduce (q, NO_NOTE, NO_TICK, VARIABLE_DECLARATION, DECLARER, DEFINING_IDENTIFIER, STOP); } for (q = p; q != NO_NODE; FORWARD (q)) { BOOL_T siga; do { siga = A68_FALSE; reduce (q, NO_NOTE, &siga, IDENTITY_DECLARATION, IDENTITY_DECLARATION, COMMA_SYMBOL, DEFINING_IDENTIFIER, EQUALS_SYMBOL, UNIT, STOP); reduce (q, NO_NOTE, &siga, VARIABLE_DECLARATION, VARIABLE_DECLARATION, COMMA_SYMBOL, DEFINING_IDENTIFIER, ASSIGN_SYMBOL, UNIT, STOP); if (!whether (q, VARIABLE_DECLARATION, COMMA_SYMBOL, DEFINING_IDENTIFIER, ASSIGN_SYMBOL, UNIT, STOP)) { reduce (q, NO_NOTE, &siga, VARIABLE_DECLARATION, VARIABLE_DECLARATION, COMMA_SYMBOL, DEFINING_IDENTIFIER, STOP); } } while (siga); } for (q = p; q != NO_NODE; FORWARD (q)) { reduce (q, NO_NOTE, NO_TICK, OPERATOR_DECLARATION, OPERATOR_PLAN, DEFINING_OPERATOR, EQUALS_SYMBOL, UNIT, STOP); } for (q = p; q != NO_NODE; FORWARD (q)) { BOOL_T siga; do { siga = A68_FALSE; reduce (q, NO_NOTE, &siga, OPERATOR_DECLARATION, OPERATOR_DECLARATION, COMMA_SYMBOL, DEFINING_OPERATOR, EQUALS_SYMBOL, UNIT, STOP); } while (siga); } for (q = p; q != NO_NODE; FORWARD (q)) { reduce (q, NO_NOTE, NO_TICK, DECLARATION_LIST, MODE_DECLARATION, STOP); reduce (q, NO_NOTE, NO_TICK, DECLARATION_LIST, PRIORITY_DECLARATION, STOP); reduce (q, NO_NOTE, NO_TICK, DECLARATION_LIST, BRIEF_OPERATOR_DECLARATION, STOP); reduce (q, NO_NOTE, NO_TICK, DECLARATION_LIST, OPERATOR_DECLARATION, STOP); reduce (q, NO_NOTE, NO_TICK, DECLARATION_LIST, IDENTITY_DECLARATION, STOP); reduce (q, NO_NOTE, NO_TICK, DECLARATION_LIST, PROCEDURE_DECLARATION, STOP); reduce (q, NO_NOTE, NO_TICK, DECLARATION_LIST, PROCEDURE_VARIABLE_DECLARATION, STOP); reduce (q, NO_NOTE, NO_TICK, DECLARATION_LIST, VARIABLE_DECLARATION, STOP); reduce (q, NO_NOTE, NO_TICK, DECLARATION_LIST, ENVIRON_NAME, STOP); } for (q = p; q != NO_NODE; FORWARD (q)) { BOOL_T siga; do { siga = A68_FALSE; reduce (q, NO_NOTE, &siga, DECLARATION_LIST, DECLARATION_LIST, COMMA_SYMBOL, DECLARATION_LIST, STOP); } while (siga); } } /*! \brief reduce serial clauses \param p position in tree **/ static void reduce_serial_clauses (NODE_T * p) { if (NEXT (p) != NO_NODE) { NODE_T *q = NEXT (p), *u; BOOL_T siga, label_seen; /* Check wrong exits */ for (u = q; u != NO_NODE; FORWARD (u)) { if (IS (u, EXIT_SYMBOL)) { if (NEXT (u) == NO_NODE || ISNT (NEXT (u), LABELED_UNIT)) { diagnostic_node (A68_SYNTAX_ERROR, u, ERROR_LABELED_UNIT_MUST_FOLLOW); } } } /* Check wrong jumps and declarations */ for (u = q, label_seen = A68_FALSE; u != NO_NODE; FORWARD (u)) { if (IS (u, LABELED_UNIT)) { label_seen = A68_TRUE; } else if (IS (u, DECLARATION_LIST)) { if (label_seen) { diagnostic_node (A68_SYNTAX_ERROR, u, ERROR_LABEL_BEFORE_DECLARATION); } } } /* Reduce serial clauses */ reduce (q, NO_NOTE, NO_TICK, SERIAL_CLAUSE, LABELED_UNIT, STOP); reduce (q, NO_NOTE, NO_TICK, SERIAL_CLAUSE, UNIT, STOP); reduce (q, NO_NOTE, NO_TICK, INITIALISER_SERIES, DECLARATION_LIST, STOP); do { siga = A68_FALSE; if (IS (q, SERIAL_CLAUSE)) { reduce (q, NO_NOTE, &siga, SERIAL_CLAUSE, SERIAL_CLAUSE, SEMI_SYMBOL, UNIT, STOP); reduce (q, NO_NOTE, &siga, SERIAL_CLAUSE, SERIAL_CLAUSE, EXIT_SYMBOL, LABELED_UNIT, STOP); reduce (q, NO_NOTE, &siga, SERIAL_CLAUSE, SERIAL_CLAUSE, SEMI_SYMBOL, LABELED_UNIT, STOP); reduce (q, NO_NOTE, &siga, INITIALISER_SERIES, SERIAL_CLAUSE, SEMI_SYMBOL, DECLARATION_LIST, STOP); /* Errors */ reduce (q, strange_separator, &siga, SERIAL_CLAUSE, SERIAL_CLAUSE, COMMA_SYMBOL, UNIT, STOP); reduce (q, strange_separator, &siga, SERIAL_CLAUSE, SERIAL_CLAUSE, COMMA_SYMBOL, LABELED_UNIT, STOP); reduce (q, strange_separator, &siga, INITIALISER_SERIES, SERIAL_CLAUSE, COMMA_SYMBOL, DECLARATION_LIST, STOP); reduce (q, strange_separator, &siga, SERIAL_CLAUSE, SERIAL_CLAUSE, COLON_SYMBOL, UNIT, STOP); reduce (q, strange_separator, &siga, SERIAL_CLAUSE, SERIAL_CLAUSE, COLON_SYMBOL, LABELED_UNIT, STOP); reduce (q, strange_separator, &siga, INITIALISER_SERIES, SERIAL_CLAUSE, COLON_SYMBOL, DECLARATION_LIST, STOP); reduce (q, strange_separator, &siga, SERIAL_CLAUSE, SERIAL_CLAUSE, UNIT, STOP); reduce (q, strange_separator, &siga, SERIAL_CLAUSE, SERIAL_CLAUSE, LABELED_UNIT, STOP); reduce (q, strange_separator, &siga, INITIALISER_SERIES, SERIAL_CLAUSE, DECLARATION_LIST, STOP); } else if (IS (q, INITIALISER_SERIES)) { reduce (q, NO_NOTE, &siga, SERIAL_CLAUSE, INITIALISER_SERIES, SEMI_SYMBOL, UNIT, STOP); reduce (q, NO_NOTE, &siga, SERIAL_CLAUSE, INITIALISER_SERIES, SEMI_SYMBOL, LABELED_UNIT, STOP); reduce (q, NO_NOTE, &siga, INITIALISER_SERIES, INITIALISER_SERIES, SEMI_SYMBOL, DECLARATION_LIST, STOP); /* Errors */ reduce (q, strange_separator, &siga, SERIAL_CLAUSE, INITIALISER_SERIES, COMMA_SYMBOL, UNIT, STOP); reduce (q, strange_separator, &siga, SERIAL_CLAUSE, INITIALISER_SERIES, COMMA_SYMBOL, LABELED_UNIT, STOP); reduce (q, strange_separator, &siga, INITIALISER_SERIES, INITIALISER_SERIES, COMMA_SYMBOL, DECLARATION_LIST, STOP); reduce (q, strange_separator, &siga, SERIAL_CLAUSE, INITIALISER_SERIES, COLON_SYMBOL, UNIT, STOP); reduce (q, strange_separator, &siga, SERIAL_CLAUSE, INITIALISER_SERIES, COLON_SYMBOL, LABELED_UNIT, STOP); reduce (q, strange_separator, &siga, INITIALISER_SERIES, INITIALISER_SERIES, COLON_SYMBOL, DECLARATION_LIST, STOP); reduce (q, strange_separator, &siga, SERIAL_CLAUSE, INITIALISER_SERIES, UNIT, STOP); reduce (q, strange_separator, &siga, SERIAL_CLAUSE, INITIALISER_SERIES, LABELED_UNIT, STOP); reduce (q, strange_separator, &siga, INITIALISER_SERIES, INITIALISER_SERIES, DECLARATION_LIST, STOP); } } while (siga); } } /*! \brief reduce enquiry clauses \param p position in tree **/ static void reduce_enquiry_clauses (NODE_T * p) { if (NEXT (p) != NO_NODE) { NODE_T *q = NEXT (p); BOOL_T siga; reduce (q, NO_NOTE, NO_TICK, ENQUIRY_CLAUSE, UNIT, STOP); reduce (q, NO_NOTE, NO_TICK, INITIALISER_SERIES, DECLARATION_LIST, STOP); do { siga = A68_FALSE; if (IS (q, ENQUIRY_CLAUSE)) { reduce (q, NO_NOTE, &siga, ENQUIRY_CLAUSE, ENQUIRY_CLAUSE, SEMI_SYMBOL, UNIT, STOP); reduce (q, NO_NOTE, &siga, INITIALISER_SERIES, ENQUIRY_CLAUSE, SEMI_SYMBOL, DECLARATION_LIST, STOP); reduce (q, strange_separator, &siga, ENQUIRY_CLAUSE, ENQUIRY_CLAUSE, COMMA_SYMBOL, UNIT, STOP); reduce (q, strange_separator, &siga, INITIALISER_SERIES, ENQUIRY_CLAUSE, COMMA_SYMBOL, DECLARATION_LIST, STOP); reduce (q, strange_separator, &siga, ENQUIRY_CLAUSE, ENQUIRY_CLAUSE, COLON_SYMBOL, UNIT, STOP); reduce (q, strange_separator, &siga, INITIALISER_SERIES, ENQUIRY_CLAUSE, COLON_SYMBOL, DECLARATION_LIST, STOP); reduce (q, strange_separator, &siga, ENQUIRY_CLAUSE, ENQUIRY_CLAUSE, UNIT, STOP); reduce (q, strange_separator, &siga, INITIALISER_SERIES, ENQUIRY_CLAUSE, DECLARATION_LIST, STOP); } else if (IS (q, INITIALISER_SERIES)) { reduce (q, NO_NOTE, &siga, ENQUIRY_CLAUSE, INITIALISER_SERIES, SEMI_SYMBOL, UNIT, STOP); reduce (q, NO_NOTE, &siga, INITIALISER_SERIES, INITIALISER_SERIES, SEMI_SYMBOL, DECLARATION_LIST, STOP); reduce (q, strange_separator, &siga, ENQUIRY_CLAUSE, INITIALISER_SERIES, COMMA_SYMBOL, UNIT, STOP); reduce (q, strange_separator, &siga, INITIALISER_SERIES, INITIALISER_SERIES, COMMA_SYMBOL, DECLARATION_LIST, STOP); reduce (q, strange_separator, &siga, ENQUIRY_CLAUSE, INITIALISER_SERIES, COLON_SYMBOL, UNIT, STOP); reduce (q, strange_separator, &siga, INITIALISER_SERIES, INITIALISER_SERIES, COLON_SYMBOL, DECLARATION_LIST, STOP); reduce (q, strange_separator, &siga, ENQUIRY_CLAUSE, INITIALISER_SERIES, UNIT, STOP); reduce (q, strange_separator, &siga, INITIALISER_SERIES, INITIALISER_SERIES, DECLARATION_LIST, STOP); } } while (siga); } } /*! \brief reduce collateral clauses \param p position in tree **/ static void reduce_collateral_clauses (NODE_T * p) { if (NEXT (p) != NO_NODE) { NODE_T *q = NEXT (p); if (IS (q, UNIT)) { BOOL_T siga; reduce (q, NO_NOTE, NO_TICK, UNIT_LIST, UNIT, STOP); do { siga = A68_FALSE; reduce (q, NO_NOTE, &siga, UNIT_LIST, UNIT_LIST, COMMA_SYMBOL, UNIT, STOP); reduce (q, strange_separator, &siga, UNIT_LIST, UNIT_LIST, UNIT, STOP); } while (siga); } else if (IS (q, SPECIFIED_UNIT)) { BOOL_T siga; reduce (q, NO_NOTE, NO_TICK, SPECIFIED_UNIT_LIST, SPECIFIED_UNIT, STOP); do { siga = A68_FALSE; reduce (q, NO_NOTE, &siga, SPECIFIED_UNIT_LIST, SPECIFIED_UNIT_LIST, COMMA_SYMBOL, SPECIFIED_UNIT, STOP); reduce (q, strange_separator, &siga, SPECIFIED_UNIT_LIST, SPECIFIED_UNIT_LIST, SPECIFIED_UNIT, STOP); } while (siga); } } } /*! \brief reduces enclosed clauses \param p position in tree \param expect information the parser may have on what is expected **/ static void reduce_enclosed_clauses (NODE_T * q, int expect) { NODE_T *p = q; if (SUB (p) == NO_NODE) { if (IS (p, FOR_SYMBOL)) { reduce (p, NO_NOTE, NO_TICK, FOR_PART, FOR_SYMBOL, DEFINING_IDENTIFIER, STOP); } else if (IS (p, OPEN_SYMBOL)) { if (expect == ENQUIRY_CLAUSE) { reduce (p, NO_NOTE, NO_TICK, OPEN_PART, OPEN_SYMBOL, ENQUIRY_CLAUSE, STOP); } else if (expect == ARGUMENT) { reduce (p, NO_NOTE, NO_TICK, ARGUMENT, OPEN_SYMBOL, CLOSE_SYMBOL, STOP); reduce (p, NO_NOTE, NO_TICK, ARGUMENT, OPEN_SYMBOL, ARGUMENT_LIST, CLOSE_SYMBOL, STOP); reduce (p, empty_clause, NO_TICK, ARGUMENT, OPEN_SYMBOL, INITIALISER_SERIES, CLOSE_SYMBOL, STOP); } else if (expect == GENERIC_ARGUMENT) { if (whether (p, OPEN_SYMBOL, CLOSE_SYMBOL, STOP)) { pad_node (p, TRIMMER); reduce (p, NO_NOTE, NO_TICK, GENERIC_ARGUMENT, OPEN_SYMBOL, TRIMMER, CLOSE_SYMBOL, STOP); } reduce (p, NO_NOTE, NO_TICK, GENERIC_ARGUMENT, OPEN_SYMBOL, GENERIC_ARGUMENT_LIST, CLOSE_SYMBOL, STOP); } else if (expect == BOUNDS) { reduce (p, NO_NOTE, NO_TICK, FORMAL_BOUNDS, OPEN_SYMBOL, CLOSE_SYMBOL, STOP); reduce (p, NO_NOTE, NO_TICK, BOUNDS, OPEN_SYMBOL, BOUNDS_LIST, CLOSE_SYMBOL, STOP); reduce (p, NO_NOTE, NO_TICK, FORMAL_BOUNDS, OPEN_SYMBOL, FORMAL_BOUNDS_LIST, CLOSE_SYMBOL, STOP); reduce (p, NO_NOTE, NO_TICK, FORMAL_BOUNDS, OPEN_SYMBOL, ALT_FORMAL_BOUNDS_LIST, CLOSE_SYMBOL, STOP); } else { reduce (p, NO_NOTE, NO_TICK, CLOSED_CLAUSE, OPEN_SYMBOL, SERIAL_CLAUSE, CLOSE_SYMBOL, STOP); reduce (p, NO_NOTE, NO_TICK, COLLATERAL_CLAUSE, OPEN_SYMBOL, UNIT_LIST, CLOSE_SYMBOL, STOP); reduce (p, NO_NOTE, NO_TICK, COLLATERAL_CLAUSE, OPEN_SYMBOL, CLOSE_SYMBOL, STOP); reduce (p, empty_clause, NO_TICK, CLOSED_CLAUSE, OPEN_SYMBOL, INITIALISER_SERIES, CLOSE_SYMBOL, STOP); } } else if (IS (p, SUB_SYMBOL)) { if (expect == GENERIC_ARGUMENT) { if (whether (p, SUB_SYMBOL, BUS_SYMBOL, STOP)) { pad_node (p, TRIMMER); reduce (p, NO_NOTE, NO_TICK, GENERIC_ARGUMENT, SUB_SYMBOL, TRIMMER, BUS_SYMBOL, STOP); } reduce (p, NO_NOTE, NO_TICK, GENERIC_ARGUMENT, SUB_SYMBOL, GENERIC_ARGUMENT_LIST, BUS_SYMBOL, STOP); } else if (expect == BOUNDS) { reduce (p, NO_NOTE, NO_TICK, FORMAL_BOUNDS, SUB_SYMBOL, BUS_SYMBOL, STOP); reduce (p, NO_NOTE, NO_TICK, BOUNDS, SUB_SYMBOL, BOUNDS_LIST, BUS_SYMBOL, STOP); reduce (p, NO_NOTE, NO_TICK, FORMAL_BOUNDS, SUB_SYMBOL, FORMAL_BOUNDS_LIST, BUS_SYMBOL, STOP); reduce (p, NO_NOTE, NO_TICK, FORMAL_BOUNDS, SUB_SYMBOL, ALT_FORMAL_BOUNDS_LIST, BUS_SYMBOL, STOP); } } else if (IS (p, BEGIN_SYMBOL)) { reduce (p, NO_NOTE, NO_TICK, COLLATERAL_CLAUSE, BEGIN_SYMBOL, UNIT_LIST, END_SYMBOL, STOP); reduce (p, NO_NOTE, NO_TICK, COLLATERAL_CLAUSE, BEGIN_SYMBOL, END_SYMBOL, STOP); reduce (p, NO_NOTE, NO_TICK, CLOSED_CLAUSE, BEGIN_SYMBOL, SERIAL_CLAUSE, END_SYMBOL, STOP); reduce (p, empty_clause, NO_TICK, CLOSED_CLAUSE, BEGIN_SYMBOL, INITIALISER_SERIES, END_SYMBOL, STOP); } else if (IS (p, FORMAT_DELIMITER_SYMBOL)) { reduce (p, NO_NOTE, NO_TICK, FORMAT_TEXT, FORMAT_DELIMITER_SYMBOL, PICTURE_LIST, FORMAT_DELIMITER_SYMBOL, STOP); reduce (p, NO_NOTE, NO_TICK, FORMAT_TEXT, FORMAT_DELIMITER_SYMBOL, FORMAT_DELIMITER_SYMBOL, STOP); } else if (IS (p, FORMAT_OPEN_SYMBOL)) { reduce (p, NO_NOTE, NO_TICK, COLLECTION, FORMAT_OPEN_SYMBOL, PICTURE_LIST, FORMAT_CLOSE_SYMBOL, STOP); } else if (IS (p, IF_SYMBOL)) { reduce (p, NO_NOTE, NO_TICK, IF_PART, IF_SYMBOL, ENQUIRY_CLAUSE, STOP); reduce (p, empty_clause, NO_TICK, IF_PART, IF_SYMBOL, INITIALISER_SERIES, STOP); } else if (IS (p, THEN_SYMBOL)) { reduce (p, NO_NOTE, NO_TICK, THEN_PART, THEN_SYMBOL, SERIAL_CLAUSE, STOP); reduce (p, empty_clause, NO_TICK, THEN_PART, THEN_SYMBOL, INITIALISER_SERIES, STOP); } else if (IS (p, ELSE_SYMBOL)) { reduce (p, NO_NOTE, NO_TICK, ELSE_PART, ELSE_SYMBOL, SERIAL_CLAUSE, STOP); reduce (p, empty_clause, NO_TICK, ELSE_PART, ELSE_SYMBOL, INITIALISER_SERIES, STOP); } else if (IS (p, ELIF_SYMBOL)) { reduce (p, NO_NOTE, NO_TICK, ELIF_IF_PART, ELIF_SYMBOL, ENQUIRY_CLAUSE, STOP); } else if (IS (p, CASE_SYMBOL)) { reduce (p, NO_NOTE, NO_TICK, CASE_PART, CASE_SYMBOL, ENQUIRY_CLAUSE, STOP); reduce (p, empty_clause, NO_TICK, CASE_PART, CASE_SYMBOL, INITIALISER_SERIES, STOP); } else if (IS (p, IN_SYMBOL)) { reduce (p, NO_NOTE, NO_TICK, CASE_IN_PART, IN_SYMBOL, UNIT_LIST, STOP); reduce (p, NO_NOTE, NO_TICK, CONFORMITY_IN_PART, IN_SYMBOL, SPECIFIED_UNIT_LIST, STOP); } else if (IS (p, OUT_SYMBOL)) { reduce (p, NO_NOTE, NO_TICK, OUT_PART, OUT_SYMBOL, SERIAL_CLAUSE, STOP); reduce (p, empty_clause, NO_TICK, OUT_PART, OUT_SYMBOL, INITIALISER_SERIES, STOP); } else if (IS (p, OUSE_SYMBOL)) { reduce (p, NO_NOTE, NO_TICK, OUSE_PART, OUSE_SYMBOL, ENQUIRY_CLAUSE, STOP); } else if (IS (p, THEN_BAR_SYMBOL)) { reduce (p, NO_NOTE, NO_TICK, CHOICE, THEN_BAR_SYMBOL, SERIAL_CLAUSE, STOP); reduce (p, NO_NOTE, NO_TICK, CASE_CHOICE_CLAUSE, THEN_BAR_SYMBOL, UNIT_LIST, STOP); reduce (p, NO_NOTE, NO_TICK, CONFORMITY_CHOICE, THEN_BAR_SYMBOL, SPECIFIED_UNIT_LIST, STOP); reduce (p, NO_NOTE, NO_TICK, CONFORMITY_CHOICE, THEN_BAR_SYMBOL, SPECIFIED_UNIT, STOP); reduce (p, empty_clause, NO_TICK, CHOICE, THEN_BAR_SYMBOL, INITIALISER_SERIES, STOP); } else if (IS (p, ELSE_BAR_SYMBOL)) { reduce (p, NO_NOTE, NO_TICK, ELSE_OPEN_PART, ELSE_BAR_SYMBOL, ENQUIRY_CLAUSE, STOP); reduce (p, empty_clause, NO_TICK, ELSE_OPEN_PART, ELSE_BAR_SYMBOL, INITIALISER_SERIES, STOP); } else if (IS (p, FROM_SYMBOL)) { reduce (p, NO_NOTE, NO_TICK, FROM_PART, FROM_SYMBOL, UNIT, STOP); } else if (IS (p, BY_SYMBOL)) { reduce (p, NO_NOTE, NO_TICK, BY_PART, BY_SYMBOL, UNIT, STOP); } else if (IS (p, TO_SYMBOL)) { reduce (p, NO_NOTE, NO_TICK, TO_PART, TO_SYMBOL, UNIT, STOP); } else if (IS (p, DOWNTO_SYMBOL)) { reduce (p, NO_NOTE, NO_TICK, TO_PART, DOWNTO_SYMBOL, UNIT, STOP); } else if (IS (p, WHILE_SYMBOL)) { reduce (p, NO_NOTE, NO_TICK, WHILE_PART, WHILE_SYMBOL, ENQUIRY_CLAUSE, STOP); reduce (p, empty_clause, NO_TICK, WHILE_PART, WHILE_SYMBOL, INITIALISER_SERIES, STOP); } else if (IS (p, UNTIL_SYMBOL)) { reduce (p, NO_NOTE, NO_TICK, UNTIL_PART, UNTIL_SYMBOL, ENQUIRY_CLAUSE, STOP); reduce (p, empty_clause, NO_TICK, UNTIL_PART, UNTIL_SYMBOL, INITIALISER_SERIES, STOP); } else if (IS (p, DO_SYMBOL)) { reduce (p, NO_NOTE, NO_TICK, DO_PART, DO_SYMBOL, SERIAL_CLAUSE, UNTIL_PART, OD_SYMBOL, STOP); reduce (p, NO_NOTE, NO_TICK, DO_PART, DO_SYMBOL, SERIAL_CLAUSE, OD_SYMBOL, STOP); reduce (p, NO_NOTE, NO_TICK, DO_PART, DO_SYMBOL, UNTIL_PART, OD_SYMBOL, STOP); } else if (IS (p, ALT_DO_SYMBOL)) { reduce (p, NO_NOTE, NO_TICK, ALT_DO_PART, ALT_DO_SYMBOL, SERIAL_CLAUSE, UNTIL_PART, OD_SYMBOL, STOP); reduce (p, NO_NOTE, NO_TICK, ALT_DO_PART, ALT_DO_SYMBOL, SERIAL_CLAUSE, OD_SYMBOL, STOP); reduce (p, NO_NOTE, NO_TICK, ALT_DO_PART, ALT_DO_SYMBOL, UNTIL_PART, OD_SYMBOL, STOP); } } p = q; if (SUB (p) != NO_NODE) { if (IS (p, OPEN_PART)) { reduce (p, NO_NOTE, NO_TICK, CONDITIONAL_CLAUSE, OPEN_PART, CHOICE, CHOICE, CLOSE_SYMBOL, STOP); reduce (p, NO_NOTE, NO_TICK, CONDITIONAL_CLAUSE, OPEN_PART, CHOICE, CLOSE_SYMBOL, STOP); reduce (p, NO_NOTE, NO_TICK, CONDITIONAL_CLAUSE, OPEN_PART, CHOICE, BRIEF_ELIF_PART, STOP); reduce (p, NO_NOTE, NO_TICK, CASE_CLAUSE, OPEN_PART, CASE_CHOICE_CLAUSE, CHOICE, CLOSE_SYMBOL, STOP); reduce (p, NO_NOTE, NO_TICK, CASE_CLAUSE, OPEN_PART, CASE_CHOICE_CLAUSE, CLOSE_SYMBOL, STOP); reduce (p, NO_NOTE, NO_TICK, CASE_CLAUSE, OPEN_PART, CASE_CHOICE_CLAUSE, BRIEF_OUSE_PART, STOP); reduce (p, NO_NOTE, NO_TICK, CONFORMITY_CLAUSE, OPEN_PART, CONFORMITY_CHOICE, CHOICE, CLOSE_SYMBOL, STOP); reduce (p, NO_NOTE, NO_TICK, CONFORMITY_CLAUSE, OPEN_PART, CONFORMITY_CHOICE, CLOSE_SYMBOL, STOP); reduce (p, NO_NOTE, NO_TICK, CONFORMITY_CLAUSE, OPEN_PART, CONFORMITY_CHOICE, BRIEF_CONFORMITY_OUSE_PART, STOP); } else if (IS (p, ELSE_OPEN_PART)) { reduce (p, NO_NOTE, NO_TICK, BRIEF_ELIF_PART, ELSE_OPEN_PART, CHOICE, CHOICE, CLOSE_SYMBOL, STOP); reduce (p, NO_NOTE, NO_TICK, BRIEF_ELIF_PART, ELSE_OPEN_PART, CHOICE, CLOSE_SYMBOL, STOP); reduce (p, NO_NOTE, NO_TICK, BRIEF_ELIF_PART, ELSE_OPEN_PART, CHOICE, BRIEF_ELIF_PART, STOP); reduce (p, NO_NOTE, NO_TICK, BRIEF_OUSE_PART, ELSE_OPEN_PART, CASE_CHOICE_CLAUSE, CHOICE, CLOSE_SYMBOL, STOP); reduce (p, NO_NOTE, NO_TICK, BRIEF_OUSE_PART, ELSE_OPEN_PART, CASE_CHOICE_CLAUSE, CLOSE_SYMBOL, STOP); reduce (p, NO_NOTE, NO_TICK, BRIEF_OUSE_PART, ELSE_OPEN_PART, CASE_CHOICE_CLAUSE, BRIEF_OUSE_PART, STOP); reduce (p, NO_NOTE, NO_TICK, BRIEF_CONFORMITY_OUSE_PART, ELSE_OPEN_PART, CONFORMITY_CHOICE, CHOICE, CLOSE_SYMBOL, STOP); reduce (p, NO_NOTE, NO_TICK, BRIEF_CONFORMITY_OUSE_PART, ELSE_OPEN_PART, CONFORMITY_CHOICE, CLOSE_SYMBOL, STOP); reduce (p, NO_NOTE, NO_TICK, BRIEF_CONFORMITY_OUSE_PART, ELSE_OPEN_PART, CONFORMITY_CHOICE, BRIEF_CONFORMITY_OUSE_PART, STOP); } else if (IS (p, IF_PART)) { reduce (p, NO_NOTE, NO_TICK, CONDITIONAL_CLAUSE, IF_PART, THEN_PART, ELSE_PART, FI_SYMBOL, STOP); reduce (p, NO_NOTE, NO_TICK, CONDITIONAL_CLAUSE, IF_PART, THEN_PART, ELIF_PART, STOP); reduce (p, NO_NOTE, NO_TICK, CONDITIONAL_CLAUSE, IF_PART, THEN_PART, FI_SYMBOL, STOP); } else if (IS (p, ELIF_IF_PART)) { reduce (p, NO_NOTE, NO_TICK, ELIF_PART, ELIF_IF_PART, THEN_PART, ELSE_PART, FI_SYMBOL, STOP); reduce (p, NO_NOTE, NO_TICK, ELIF_PART, ELIF_IF_PART, THEN_PART, FI_SYMBOL, STOP); reduce (p, NO_NOTE, NO_TICK, ELIF_PART, ELIF_IF_PART, THEN_PART, ELIF_PART, STOP); } else if (IS (p, CASE_PART)) { reduce (p, NO_NOTE, NO_TICK, CASE_CLAUSE, CASE_PART, CASE_IN_PART, OUT_PART, ESAC_SYMBOL, STOP); reduce (p, NO_NOTE, NO_TICK, CASE_CLAUSE, CASE_PART, CASE_IN_PART, ESAC_SYMBOL, STOP); reduce (p, NO_NOTE, NO_TICK, CASE_CLAUSE, CASE_PART, CASE_IN_PART, CASE_OUSE_PART, STOP); reduce (p, NO_NOTE, NO_TICK, CONFORMITY_CLAUSE, CASE_PART, CONFORMITY_IN_PART, OUT_PART, ESAC_SYMBOL, STOP); reduce (p, NO_NOTE, NO_TICK, CONFORMITY_CLAUSE, CASE_PART, CONFORMITY_IN_PART, ESAC_SYMBOL, STOP); reduce (p, NO_NOTE, NO_TICK, CONFORMITY_CLAUSE, CASE_PART, CONFORMITY_IN_PART, CONFORMITY_OUSE_PART, STOP); } else if (IS (p, OUSE_PART)) { reduce (p, NO_NOTE, NO_TICK, CASE_OUSE_PART, OUSE_PART, CASE_IN_PART, OUT_PART, ESAC_SYMBOL, STOP); reduce (p, NO_NOTE, NO_TICK, CASE_OUSE_PART, OUSE_PART, CASE_IN_PART, ESAC_SYMBOL, STOP); reduce (p, NO_NOTE, NO_TICK, CASE_OUSE_PART, OUSE_PART, CASE_IN_PART, CASE_OUSE_PART, STOP); reduce (p, NO_NOTE, NO_TICK, CONFORMITY_OUSE_PART, OUSE_PART, CONFORMITY_IN_PART, OUT_PART, ESAC_SYMBOL, STOP); reduce (p, NO_NOTE, NO_TICK, CONFORMITY_OUSE_PART, OUSE_PART, CONFORMITY_IN_PART, ESAC_SYMBOL, STOP); reduce (p, NO_NOTE, NO_TICK, CONFORMITY_OUSE_PART, OUSE_PART, CONFORMITY_IN_PART, CONFORMITY_OUSE_PART, STOP); } else if (IS (p, FOR_PART)) { reduce (p, NO_NOTE, NO_TICK, LOOP_CLAUSE, FOR_PART, FROM_PART, BY_PART, TO_PART, WHILE_PART, ALT_DO_PART, STOP); reduce (p, NO_NOTE, NO_TICK, LOOP_CLAUSE, FOR_PART, FROM_PART, BY_PART, WHILE_PART, ALT_DO_PART, STOP); reduce (p, NO_NOTE, NO_TICK, LOOP_CLAUSE, FOR_PART, FROM_PART, TO_PART, WHILE_PART, ALT_DO_PART, STOP); reduce (p, NO_NOTE, NO_TICK, LOOP_CLAUSE, FOR_PART, FROM_PART, WHILE_PART, ALT_DO_PART, STOP); reduce (p, NO_NOTE, NO_TICK, LOOP_CLAUSE, FOR_PART, BY_PART, TO_PART, WHILE_PART, ALT_DO_PART, STOP); reduce (p, NO_NOTE, NO_TICK, LOOP_CLAUSE, FOR_PART, BY_PART, WHILE_PART, ALT_DO_PART, STOP); reduce (p, NO_NOTE, NO_TICK, LOOP_CLAUSE, FOR_PART, TO_PART, WHILE_PART, ALT_DO_PART, STOP); reduce (p, NO_NOTE, NO_TICK, LOOP_CLAUSE, FOR_PART, WHILE_PART, ALT_DO_PART, STOP); reduce (p, NO_NOTE, NO_TICK, LOOP_CLAUSE, FOR_PART, FROM_PART, BY_PART, TO_PART, ALT_DO_PART, STOP); reduce (p, NO_NOTE, NO_TICK, LOOP_CLAUSE, FOR_PART, FROM_PART, BY_PART, ALT_DO_PART, STOP); reduce (p, NO_NOTE, NO_TICK, LOOP_CLAUSE, FOR_PART, FROM_PART, TO_PART, ALT_DO_PART, STOP); reduce (p, NO_NOTE, NO_TICK, LOOP_CLAUSE, FOR_PART, FROM_PART, ALT_DO_PART, STOP); reduce (p, NO_NOTE, NO_TICK, LOOP_CLAUSE, FOR_PART, BY_PART, TO_PART, ALT_DO_PART, STOP); reduce (p, NO_NOTE, NO_TICK, LOOP_CLAUSE, FOR_PART, BY_PART, ALT_DO_PART, STOP); reduce (p, NO_NOTE, NO_TICK, LOOP_CLAUSE, FOR_PART, TO_PART, ALT_DO_PART, STOP); reduce (p, NO_NOTE, NO_TICK, LOOP_CLAUSE, FOR_PART, ALT_DO_PART, STOP); } else if (IS (p, FROM_PART)) { reduce (p, NO_NOTE, NO_TICK, LOOP_CLAUSE, FROM_PART, BY_PART, TO_PART, WHILE_PART, ALT_DO_PART, STOP); reduce (p, NO_NOTE, NO_TICK, LOOP_CLAUSE, FROM_PART, BY_PART, WHILE_PART, ALT_DO_PART, STOP); reduce (p, NO_NOTE, NO_TICK, LOOP_CLAUSE, FROM_PART, TO_PART, WHILE_PART, ALT_DO_PART, STOP); reduce (p, NO_NOTE, NO_TICK, LOOP_CLAUSE, FROM_PART, WHILE_PART, ALT_DO_PART, STOP); reduce (p, NO_NOTE, NO_TICK, LOOP_CLAUSE, FROM_PART, BY_PART, TO_PART, ALT_DO_PART, STOP); reduce (p, NO_NOTE, NO_TICK, LOOP_CLAUSE, FROM_PART, BY_PART, ALT_DO_PART, STOP); reduce (p, NO_NOTE, NO_TICK, LOOP_CLAUSE, FROM_PART, TO_PART, ALT_DO_PART, STOP); reduce (p, NO_NOTE, NO_TICK, LOOP_CLAUSE, FROM_PART, ALT_DO_PART, STOP); } else if (IS (p, BY_PART)) { reduce (p, NO_NOTE, NO_TICK, LOOP_CLAUSE, BY_PART, TO_PART, WHILE_PART, ALT_DO_PART, STOP); reduce (p, NO_NOTE, NO_TICK, LOOP_CLAUSE, BY_PART, WHILE_PART, ALT_DO_PART, STOP); reduce (p, NO_NOTE, NO_TICK, LOOP_CLAUSE, BY_PART, TO_PART, ALT_DO_PART, STOP); reduce (p, NO_NOTE, NO_TICK, LOOP_CLAUSE, BY_PART, ALT_DO_PART, STOP); } else if (IS (p, TO_PART)) { reduce (p, NO_NOTE, NO_TICK, LOOP_CLAUSE, TO_PART, WHILE_PART, ALT_DO_PART, STOP); reduce (p, NO_NOTE, NO_TICK, LOOP_CLAUSE, TO_PART, ALT_DO_PART, STOP); } else if (IS (p, WHILE_PART)) { reduce (p, NO_NOTE, NO_TICK, LOOP_CLAUSE, WHILE_PART, ALT_DO_PART, STOP); } else if (IS (p, DO_PART)) { reduce (p, NO_NOTE, NO_TICK, LOOP_CLAUSE, DO_PART, STOP); } } } /*! \brief substitute reduction when a phrase could not be parsed \param p position in tree \param expect information the parser may have on what is expected \param suppress suppresses a diagnostic_node message (nested c.q. related diagnostics) **/ static void recover_from_error (NODE_T * p, int expect, BOOL_T suppress) { /* This routine does not do fancy things as that might introduce more errors */ NODE_T *q = p; if (p == NO_NODE) { return; } if (expect == SOME_CLAUSE) { expect = serial_or_collateral (p); } if (!suppress) { /* Give an error message */ NODE_T *w = p; char *seq = phrase_to_text (p, &w); if (strlen (seq) == 0) { if (ERROR_COUNT (&program) == 0) { diagnostic_node (A68_SYNTAX_ERROR, w, ERROR_SYNTAX_EXPECTED, expect); } } else { diagnostic_node (A68_SYNTAX_ERROR, w, ERROR_INVALID_SEQUENCE, seq, expect); } if (ERROR_COUNT (&program) >= MAX_ERRORS) { longjmp (bottom_up_crash_exit, 1); } } /* Try to prevent spurious diagnostics by guessing what was expected */ while (NEXT (q) != NO_NODE) { FORWARD (q); } if (is_one_of (p, BEGIN_SYMBOL, OPEN_SYMBOL, STOP)) { if (expect == ARGUMENT || expect == COLLATERAL_CLAUSE || expect == PARAMETER_PACK || expect == STRUCTURE_PACK || expect == UNION_PACK) { make_sub (p, q, expect); } else if (expect == ENQUIRY_CLAUSE) { make_sub (p, q, OPEN_PART); } else if (expect == FORMAL_DECLARERS) { make_sub (p, q, FORMAL_DECLARERS); } else { make_sub (p, q, CLOSED_CLAUSE); } } else if (IS (p, FORMAT_DELIMITER_SYMBOL) && expect == FORMAT_TEXT) { make_sub (p, q, FORMAT_TEXT); } else if (IS (p, CODE_SYMBOL)) { make_sub (p, q, CODE_CLAUSE); } else if (is_one_of (p, THEN_BAR_SYMBOL, CHOICE, STOP)) { make_sub (p, q, CHOICE); } else if (is_one_of (p, IF_SYMBOL, IF_PART, STOP)) { make_sub (p, q, IF_PART); } else if (is_one_of (p, THEN_SYMBOL, THEN_PART, STOP)) { make_sub (p, q, THEN_PART); } else if (is_one_of (p, ELSE_SYMBOL, ELSE_PART, STOP)) { make_sub (p, q, ELSE_PART); } else if (is_one_of (p, ELIF_SYMBOL, ELIF_IF_PART, STOP)) { make_sub (p, q, ELIF_IF_PART); } else if (is_one_of (p, CASE_SYMBOL, CASE_PART, STOP)) { make_sub (p, q, CASE_PART); } else if (is_one_of (p, OUT_SYMBOL, OUT_PART, STOP)) { make_sub (p, q, OUT_PART); } else if (is_one_of (p, OUSE_SYMBOL, OUSE_PART, STOP)) { make_sub (p, q, OUSE_PART); } else if (is_one_of (p, FOR_SYMBOL, FOR_PART, STOP)) { make_sub (p, q, FOR_PART); } else if (is_one_of (p, FROM_SYMBOL, FROM_PART, STOP)) { make_sub (p, q, FROM_PART); } else if (is_one_of (p, BY_SYMBOL, BY_PART, STOP)) { make_sub (p, q, BY_PART); } else if (is_one_of (p, TO_SYMBOL, DOWNTO_SYMBOL, TO_PART, STOP)) { make_sub (p, q, TO_PART); } else if (is_one_of (p, WHILE_SYMBOL, WHILE_PART, STOP)) { make_sub (p, q, WHILE_PART); } else if (is_one_of (p, UNTIL_SYMBOL, UNTIL_PART, STOP)) { make_sub (p, q, UNTIL_PART); } else if (is_one_of (p, DO_SYMBOL, DO_PART, STOP)) { make_sub (p, q, DO_PART); } else if (is_one_of (p, ALT_DO_SYMBOL, ALT_DO_PART, STOP)) { make_sub (p, q, ALT_DO_PART); } else if (non_terminal_string (edit_line, expect) != NO_TEXT) { make_sub (p, q, expect); } } /*! \brief heuristic aid in pinpointing errors \param p position in tree **/ static void reduce_erroneous_units (NODE_T * p) { /* Constructs are reduced to units in an attempt to limit spurious diagnostics */ NODE_T *q; for (q = p; q != NO_NODE; FORWARD (q)) { /* Some implementations allow selection from a tertiary, when there is no risk of ambiguity. Algol68G follows RR, so some extra attention here to guide an unsuspecting user */ if (whether (q, SELECTOR, -SECONDARY, STOP)) { diagnostic_node (A68_SYNTAX_ERROR, NEXT (q), ERROR_SYNTAX_EXPECTED, SECONDARY); reduce (q, NO_NOTE, NO_TICK, UNIT, SELECTOR, WILDCARD, STOP); } /* Attention for identity relations that require tertiaries */ if (whether (q, -TERTIARY, IS_SYMBOL, TERTIARY, STOP) || whether (q, TERTIARY, IS_SYMBOL, -TERTIARY, STOP) || whether (q, -TERTIARY, IS_SYMBOL, -TERTIARY, STOP)) { diagnostic_node (A68_SYNTAX_ERROR, NEXT (q), ERROR_SYNTAX_EXPECTED, TERTIARY); reduce (q, NO_NOTE, NO_TICK, UNIT, WILDCARD, IS_SYMBOL, WILDCARD, STOP); } else if (whether (q, -TERTIARY, ISNT_SYMBOL, TERTIARY, STOP) || whether (q, TERTIARY, ISNT_SYMBOL, -TERTIARY, STOP) || whether (q, -TERTIARY, ISNT_SYMBOL, -TERTIARY, STOP)) { diagnostic_node (A68_SYNTAX_ERROR, NEXT (q), ERROR_SYNTAX_EXPECTED, TERTIARY); reduce (q, NO_NOTE, NO_TICK, UNIT, WILDCARD, ISNT_SYMBOL, WILDCARD, STOP); } } } /* A posteriori checks of the syntax tree built by the BU parser */ /*! \brief driver for a posteriori error checking \param p position in tree **/ void bottom_up_error_check (NODE_T * p) { for (; p != NO_NODE; FORWARD (p)) { if (IS (p, BOOLEAN_PATTERN)) { int k = 0; count_pictures (SUB (p), &k); if (!(k == 0 || k == 2)) { diagnostic_node (A68_SYNTAX_ERROR, p, ERROR_FORMAT_PICTURE_NUMBER, ATTRIBUTE (p)); } } else { bottom_up_error_check (SUB (p)); } } } /* Next part rearranges the tree after the symbol tables are finished */ /*! \brief transfer IDENTIFIER to JUMP where appropriate \param p position in tree **/ void rearrange_goto_less_jumps (NODE_T * p) { for (; p != NO_NODE; FORWARD (p)) { if (IS (p, UNIT)) { NODE_T *q = SUB (p); if (IS (q, TERTIARY)) { NODE_T *tertiary = q; q = SUB (q); if (q != NO_NODE && IS (q, SECONDARY)) { q = SUB (q); if (q != NO_NODE && IS (q, PRIMARY)) { q = SUB (q); if (q != NO_NODE && IS (q, IDENTIFIER)) { if (is_identifier_or_label_global (TABLE (q), NSYMBOL (q)) == LABEL) { ATTRIBUTE (tertiary) = JUMP; SUB (tertiary) = q; } } } } } } else if (IS (p, TERTIARY)) { NODE_T *q = SUB (p); if (q != NO_NODE && IS (q, SECONDARY)) { NODE_T *secondary = q; q = SUB (q); if (q != NO_NODE && IS (q, PRIMARY)) { q = SUB (q); if (q != NO_NODE && IS (q, IDENTIFIER)) { if (is_identifier_or_label_global (TABLE (q), NSYMBOL (q)) == LABEL) { ATTRIBUTE (secondary) = JUMP; SUB (secondary) = q; } } } } } else if (IS (p, SECONDARY)) { NODE_T *q = SUB (p); if (q != NO_NODE && IS (q, PRIMARY)) { NODE_T *primary = q; q = SUB (q); if (q != NO_NODE && IS (q, IDENTIFIER)) { if (is_identifier_or_label_global (TABLE (q), NSYMBOL (q)) == LABEL) { ATTRIBUTE (primary) = JUMP; SUB (primary) = q; } } } } else if (IS (p, PRIMARY)) { NODE_T *q = SUB (p); if (q != NO_NODE && IS (q, IDENTIFIER)) { if (is_identifier_or_label_global (TABLE (q), NSYMBOL (q)) == LABEL) { make_sub (q, q, JUMP); } } } rearrange_goto_less_jumps (SUB (p)); } } /***********************************************************/ /* VICTAL checker for formal, actual and virtual declarers */ /***********************************************************/ /*! \brief check generator \param p position in tree **/ static void victal_check_generator (NODE_T * p) { if (!victal_check_declarer (NEXT (p), ACTUAL_DECLARER_MARK)) { diagnostic_node (A68_SYNTAX_ERROR, p, ERROR_EXPECTED, "actual declarer"); } } /*! \brief check formal pack \param p position in tree \param x expected attribute \param z flag **/ static void victal_check_formal_pack (NODE_T * p, int x, BOOL_T * z) { if (p != NO_NODE) { if (IS (p, FORMAL_DECLARERS)) { victal_check_formal_pack (SUB (p), x, z); } else if (is_one_of (p, OPEN_SYMBOL, COMMA_SYMBOL, STOP)) { victal_check_formal_pack (NEXT (p), x, z); } else if (IS (p, FORMAL_DECLARERS_LIST)) { victal_check_formal_pack (NEXT (p), x, z); victal_check_formal_pack (SUB (p), x, z); } else if (IS (p, DECLARER)) { victal_check_formal_pack (NEXT (p), x, z); (*z) &= victal_check_declarer (SUB (p), x); } } } /*! \brief check operator declaration \param p position in tree **/ static void victal_check_operator_dec (NODE_T * p) { if (IS (NEXT (p), FORMAL_DECLARERS)) { BOOL_T z = A68_TRUE; victal_check_formal_pack (NEXT (p), FORMAL_DECLARER_MARK, &z); if (!z) { diagnostic_node (A68_SYNTAX_ERROR, p, ERROR_EXPECTED, "formal declarers"); } FORWARD (p); } if (!victal_check_declarer (NEXT (p), FORMAL_DECLARER_MARK)) { diagnostic_node (A68_SYNTAX_ERROR, p, ERROR_EXPECTED, "formal declarer"); } } /*! \brief check mode declaration \param p position in tree **/ static void victal_check_mode_dec (NODE_T * p) { if (p != NO_NODE) { if (IS (p, MODE_DECLARATION)) { victal_check_mode_dec (SUB (p)); victal_check_mode_dec (NEXT (p)); } else if (is_one_of (p, MODE_SYMBOL, DEFINING_INDICANT, STOP) || is_one_of (p, EQUALS_SYMBOL, COMMA_SYMBOL, STOP)) { victal_check_mode_dec (NEXT (p)); } else if (IS (p, DECLARER)) { if (!victal_check_declarer (p, ACTUAL_DECLARER_MARK)) { diagnostic_node (A68_SYNTAX_ERROR, p, ERROR_EXPECTED, "actual declarer"); } } } } /*! \brief check variable declaration \param p position in tree **/ static void victal_check_variable_dec (NODE_T * p) { if (p != NO_NODE) { if (IS (p, VARIABLE_DECLARATION)) { victal_check_variable_dec (SUB (p)); victal_check_variable_dec (NEXT (p)); } else if (is_one_of (p, DEFINING_IDENTIFIER, ASSIGN_SYMBOL, STOP) || IS (p, COMMA_SYMBOL)) { victal_check_variable_dec (NEXT (p)); } else if (IS (p, UNIT)) { victal_checker (SUB (p)); } else if (IS (p, DECLARER)) { if (!victal_check_declarer (p, ACTUAL_DECLARER_MARK)) { diagnostic_node (A68_SYNTAX_ERROR, p, ERROR_EXPECTED, "actual declarer"); } victal_check_variable_dec (NEXT (p)); } } } /*! \brief check identity declaration \param p position in tree **/ static void victal_check_identity_dec (NODE_T * p) { if (p != NO_NODE) { if (IS (p, IDENTITY_DECLARATION)) { victal_check_identity_dec (SUB (p)); victal_check_identity_dec (NEXT (p)); } else if (is_one_of (p, DEFINING_IDENTIFIER, EQUALS_SYMBOL, COMMA_SYMBOL, STOP)) { victal_check_identity_dec (NEXT (p)); } else if (IS (p, UNIT)) { victal_checker (SUB (p)); } else if (IS (p, DECLARER)) { if (!victal_check_declarer (p, FORMAL_DECLARER_MARK)) { diagnostic_node (A68_SYNTAX_ERROR, p, ERROR_EXPECTED, "formal declarer"); } victal_check_identity_dec (NEXT (p)); } } } /*! \brief check routine pack \param p position in tree \param x expected attribute \param z flag **/ static void victal_check_routine_pack (NODE_T * p, int x, BOOL_T * z) { if (p != NO_NODE) { if (IS (p, PARAMETER_PACK)) { victal_check_routine_pack (SUB (p), x, z); } else if (is_one_of (p, OPEN_SYMBOL, COMMA_SYMBOL, STOP)) { victal_check_routine_pack (NEXT (p), x, z); } else if (is_one_of (p, PARAMETER_LIST, PARAMETER, STOP)) { victal_check_routine_pack (NEXT (p), x, z); victal_check_routine_pack (SUB (p), x, z); } else if (IS (p, DECLARER)) { *z &= victal_check_declarer (SUB (p), x); } } } /*! \brief check routine text \param p position in tree **/ static void victal_check_routine_text (NODE_T * p) { if (IS (p, PARAMETER_PACK)) { BOOL_T z = A68_TRUE; victal_check_routine_pack (p, FORMAL_DECLARER_MARK, &z); if (!z) { diagnostic_node (A68_SYNTAX_ERROR, p, ERROR_EXPECTED, "formal declarers"); } FORWARD (p); } if (!victal_check_declarer (p, FORMAL_DECLARER_MARK)) { diagnostic_node (A68_SYNTAX_ERROR, p, ERROR_EXPECTED, "formal declarer"); } victal_checker (NEXT (p)); } /*! \brief check structure pack \param p position in tree \param x expected attribute \param z flag **/ static void victal_check_structure_pack (NODE_T * p, int x, BOOL_T * z) { if (p != NO_NODE) { if (IS (p, STRUCTURE_PACK)) { victal_check_structure_pack (SUB (p), x, z); } else if (is_one_of (p, OPEN_SYMBOL, COMMA_SYMBOL, STOP)) { victal_check_structure_pack (NEXT (p), x, z); } else if (is_one_of (p, STRUCTURED_FIELD_LIST, STRUCTURED_FIELD, STOP)) { victal_check_structure_pack (NEXT (p), x, z); victal_check_structure_pack (SUB (p), x, z); } else if (IS (p, DECLARER)) { (*z) &= victal_check_declarer (SUB (p), x); } } } /*! \brief check union pack \param p position in tree \param x expected attribute \param z flag **/ static void victal_check_union_pack (NODE_T * p, int x, BOOL_T * z) { if (p != NO_NODE) { if (IS (p, UNION_PACK)) { victal_check_union_pack (SUB (p), x, z); } else if (is_one_of (p, OPEN_SYMBOL, COMMA_SYMBOL, VOID_SYMBOL, STOP)) { victal_check_union_pack (NEXT (p), x, z); } else if (IS (p, UNION_DECLARER_LIST)) { victal_check_union_pack (NEXT (p), x, z); victal_check_union_pack (SUB (p), x, z); } else if (IS (p, DECLARER)) { victal_check_union_pack (NEXT (p), x, z); (*z) &= victal_check_declarer (SUB (p), FORMAL_DECLARER_MARK); } } } /*! \brief check declarer \param p position in tree \param x expected attribute **/ static BOOL_T victal_check_declarer (NODE_T * p, int x) { if (p == NO_NODE) { return (A68_FALSE); } else if (IS (p, DECLARER)) { return (victal_check_declarer (SUB (p), x)); } else if (is_one_of (p, LONGETY, SHORTETY, STOP)) { return (A68_TRUE); } else if (is_one_of (p, VOID_SYMBOL, INDICANT, STANDARD, STOP)) { return (A68_TRUE); } else if (IS (p, REF_SYMBOL)) { return (victal_check_declarer (NEXT (p), VIRTUAL_DECLARER_MARK)); } else if (IS (p, FLEX_SYMBOL)) { return (victal_check_declarer (NEXT (p), x)); } else if (IS (p, BOUNDS)) { victal_checker (SUB (p)); if (x == FORMAL_DECLARER_MARK) { diagnostic_node (A68_SYNTAX_ERROR, p, ERROR_EXPECTED, "formal bounds"); (void) victal_check_declarer (NEXT (p), x); return (A68_TRUE); } else if (x == VIRTUAL_DECLARER_MARK) { diagnostic_node (A68_SYNTAX_ERROR, p, ERROR_EXPECTED, "virtual bounds"); (void) victal_check_declarer (NEXT (p), x); return (A68_TRUE); } else { return (victal_check_declarer (NEXT (p), x)); } } else if (IS (p, FORMAL_BOUNDS)) { victal_checker (SUB (p)); if (x == ACTUAL_DECLARER_MARK) { diagnostic_node (A68_SYNTAX_ERROR, p, ERROR_EXPECTED, "actual bounds"); (void) victal_check_declarer (NEXT (p), x); return (A68_TRUE); } else { return (victal_check_declarer (NEXT (p), x)); } } else if (IS (p, STRUCT_SYMBOL)) { BOOL_T z = A68_TRUE; victal_check_structure_pack (NEXT (p), x, &z); return (z); } else if (IS (p, UNION_SYMBOL)) { BOOL_T z = A68_TRUE; victal_check_union_pack (NEXT (p), FORMAL_DECLARER_MARK, &z); if (!z) { diagnostic_node (A68_SYNTAX_ERROR, p, ERROR_EXPECTED, "formal declarer pack"); } return (A68_TRUE); } else if (IS (p, PROC_SYMBOL)) { if (IS (NEXT (p), FORMAL_DECLARERS)) { BOOL_T z = A68_TRUE; victal_check_formal_pack (NEXT (p), FORMAL_DECLARER_MARK, &z); if (!z) { diagnostic_node (A68_SYNTAX_ERROR, p, ERROR_EXPECTED, "formal declarer"); } FORWARD (p); } if (!victal_check_declarer (NEXT (p), FORMAL_DECLARER_MARK)) { diagnostic_node (A68_SYNTAX_ERROR, p, ERROR_EXPECTED, "formal declarer"); } return (A68_TRUE); } else { return (A68_FALSE); } } /*! \brief check cast \param p position in tree **/ static void victal_check_cast (NODE_T * p) { if (!victal_check_declarer (p, FORMAL_DECLARER_MARK)) { diagnostic_node (A68_SYNTAX_ERROR, p, ERROR_EXPECTED, "formal declarer"); victal_checker (NEXT (p)); } } /*! \brief driver for checking VICTALITY of declarers \param p position in tree **/ void victal_checker (NODE_T * p) { for (; p != NO_NODE; FORWARD (p)) { if (IS (p, MODE_DECLARATION)) { victal_check_mode_dec (SUB (p)); } else if (IS (p, VARIABLE_DECLARATION)) { victal_check_variable_dec (SUB (p)); } else if (IS (p, IDENTITY_DECLARATION)) { victal_check_identity_dec (SUB (p)); } else if (IS (p, GENERATOR)) { victal_check_generator (SUB (p)); } else if (IS (p, ROUTINE_TEXT)) { victal_check_routine_text (SUB (p)); } else if (IS (p, OPERATOR_PLAN)) { victal_check_operator_dec (SUB (p)); } else if (IS (p, CAST)) { victal_check_cast (SUB (p)); } else { victal_checker (SUB (p)); } } } /****************************************************/ /* Mode collection, equivalencing and derived modes */ /****************************************************/ /*************************/ /* Mode service routines */ /*************************/ /*! \brief reset moid \param p position in tree **/ static void reset_moid_tree (NODE_T * p) { for (; p != NO_NODE; FORWARD (p)) { MOID (p) = NO_MOID; reset_moid_tree (SUB (p)); } } /*! \brief renumber moids \param p moid list \param n index **/ void renumber_moids (MOID_T * p, int n) { if (p != NO_MOID) { NUMBER (p) = n; renumber_moids (NEXT (p), n + 1); } } /**************************************************/ /* Routines for establishing equivalence of modes */ /* Routines for adding modes */ /**************************************************/ /* After the initial version of the mode equivalencer was made to work (1993), I found: Algol Bulletin 30.3.3 C.H.A. Koster: On infinite modes, 86-89 [1969], which essentially concurs with the algorithm on mode equivalence I wrote (and which is still here). It is basic logic anyway: prove equivalence of things assuming their equivalence. */ /*! \brief whether packs are equivalent, same sequence of equivalence modes \param s pack 1 \param t pack 2 \return same **/ static BOOL_T is_packs_equivalent (PACK_T * s, PACK_T * t) { for (; s != NO_PACK && t != NO_PACK; FORWARD (s), FORWARD (t)) { if (!is_modes_equivalent (MOID (s), MOID (t))) { return (A68_FALSE); } if (TEXT (s) != TEXT (t)) { return (A68_FALSE); } } return ((BOOL_T) (s == NO_PACK && t == NO_PACK)); } /*! \brief whether packs are equivalent, must be subsets \param s pack 1 \param t pack 2 \return same **/ static BOOL_T is_united_packs_equivalent (PACK_T * s, PACK_T * t) { PACK_T *p, *q; BOOL_T f; /* whether s is a subset of t ... */ for (p = s; p != NO_PACK; FORWARD (p)) { for (f = A68_FALSE, q = t; q != NO_PACK && !f; FORWARD (q)) { f = is_modes_equivalent (MOID (p), MOID (q)); } if (!f) { return (A68_FALSE); } } /* ... and whether t is a subset of s */ for (p = t; p != NO_PACK; FORWARD (p)) { for (f = A68_FALSE, q = s; q != NO_PACK && !f; FORWARD (q)) { f = is_modes_equivalent (MOID (p), MOID (q)); } if (!f) { return (A68_FALSE); } } return (A68_TRUE); } /*! \brief whether moids a and b are structurally equivalent \param a moid \param b moid \return same **/ BOOL_T is_modes_equivalent (MOID_T * a, MOID_T * b) { if (a == NO_MOID || b == NO_MOID) { /* Modes can be NO_MOID in partial argument lists */ return (A68_FALSE); } else if (a == b) { return (A68_TRUE); } else if (a == MODE (ERROR) || b == MODE (ERROR)) { return (A68_FALSE); } else if (ATTRIBUTE (a) != ATTRIBUTE (b)) { return (A68_FALSE); } else if (DIM (a) != DIM (b)) { return (A68_FALSE); } else if (IS (a, STANDARD)) { return ((BOOL_T) (a == b)); } else if (EQUIVALENT (a) == b || EQUIVALENT (b) == a) { return (A68_TRUE); } else if (is_postulated_pair (top_postulate, a, b) || is_postulated_pair (top_postulate, b, a)) { return (A68_TRUE); } else if (IS (a, INDICANT)) { if (NODE (a) == NO_NODE || NODE (b) == NO_NODE) { return (A68_FALSE); } else { return (NODE (a) == NODE (b)); } } switch (ATTRIBUTE (a)) { case REF_SYMBOL: case ROW_SYMBOL: case FLEX_SYMBOL: { return (is_modes_equivalent (SUB (a), SUB (b))); } } if (IS (a, PROC_SYMBOL) && PACK (a) == NO_PACK && PACK (b) == NO_PACK) { return (is_modes_equivalent (SUB (a), SUB (b))); } else if (IS (a, STRUCT_SYMBOL)) { POSTULATE_T *save; BOOL_T z; save = top_postulate; make_postulate (&top_postulate, a, b); z = is_packs_equivalent (PACK (a), PACK (b)); free_postulate_list (top_postulate, save); top_postulate = save; return (z); } else if (IS (a, UNION_SYMBOL)) { return (is_united_packs_equivalent (PACK (a), PACK (b))); } else if (IS (a, PROC_SYMBOL) && PACK (a) != NO_PACK && PACK (b) != NO_PACK) { POSTULATE_T *save; BOOL_T z; save = top_postulate; make_postulate (&top_postulate, a, b); z = is_modes_equivalent (SUB (a), SUB (b)); if (z) { z = is_packs_equivalent (PACK (a), PACK (b)); } free_postulate_list (top_postulate, save); top_postulate = save; return (z); } else if (IS (a, SERIES_MODE) || IS (a, STOWED_MODE)) { return (is_packs_equivalent (PACK (a), PACK (b))); } return (A68_FALSE); } /*! \brief whether modes 1 and 2 are structurally equivalent \param p mode 1 \param q mode 2 \return same **/ static BOOL_T prove_moid_equivalence (MOID_T * p, MOID_T * q) { /* Prove two modes to be equivalent under assumption that they indeed are */ POSTULATE_T *save = top_postulate; BOOL_T z = is_modes_equivalent (p, q); free_postulate_list (top_postulate, save); top_postulate = save; return (z); } /*! \brief register mode in the global mode table, if mode is unique \param z mode table \param u mode to enter \return mode table entry **/ static MOID_T *register_extra_mode (MOID_T ** z, MOID_T * u) { MOID_T *head = TOP_MOID (&program); /* If we already know this mode, return the existing entry; otherwise link it in */ for (; head != NO_MOID; FORWARD (head)) { if (prove_moid_equivalence (head, u)) { return (head); } } /* Link to chain and exit */ NUMBER (u) = mode_count++; NEXT (u) = (* z); return (* z = u); } /*! \brief add mode "sub" to chain "z" \param z chain to insert into \param att attribute \param dim dimension \param node node \param sub subordinate mode \param pack pack \return new entry **/ MOID_T *add_mode (MOID_T ** z, int att, int dim, NODE_T * node, MOID_T * sub, PACK_T * pack) { MOID_T *new_mode = new_moid (); ABEND (att == REF_SYMBOL && sub == NO_MOID, ERROR_INTERNAL_CONSISTENCY, "store REF NULL"); ABEND (att == FLEX_SYMBOL && sub == NO_MOID, ERROR_INTERNAL_CONSISTENCY, "store FLEX NULL"); ABEND (att == ROW_SYMBOL && sub == NO_MOID, ERROR_INTERNAL_CONSISTENCY, "store [] NULL"); USE (new_mode) = A68_FALSE; SIZE (new_mode) = 0; ATTRIBUTE (new_mode) = att; DIM (new_mode) = dim; NODE (new_mode) = node; HAS_ROWS (new_mode) = (BOOL_T) (att == ROW_SYMBOL); SUB (new_mode) = sub; PACK (new_mode) = pack; NEXT (new_mode) = NO_MOID; EQUIVALENT (new_mode) = NO_MOID; SLICE (new_mode) = NO_MOID; DEFLEXED (new_mode) = NO_MOID; NAME (new_mode) = NO_MOID; MULTIPLE (new_mode) = NO_MOID; ROWED (new_mode) = NO_MOID; return (register_extra_mode (z, new_mode)); } /*! \brief contract a UNION \param u united mode \param mods modification count **/ static void contract_union (MOID_T * u) { PACK_T *s = PACK (u); for (; s != NO_PACK; FORWARD (s)) { PACK_T *t = s; while (t != NO_PACK) { if (NEXT (t) != NO_PACK && MOID (NEXT (t)) == MOID (s)) { MOID (t) = MOID (t); NEXT (t) = NEXT_NEXT (t); } else { FORWARD (t); } } } } /*! \brief absorb UNION pack \param t pack \param mods modification count \return absorbed pack **/ static PACK_T *absorb_union_pack (PACK_T * u) { BOOL_T go_on; PACK_T *t, *z; do { z = NO_PACK; go_on = A68_FALSE; for (t = u; t != NO_PACK; FORWARD (t)) { if (IS (MOID (t), UNION_SYMBOL)) { PACK_T *s; go_on = A68_TRUE; for (s = PACK (MOID (t)); s != NO_PACK; FORWARD (s)) { (void) add_mode_to_pack (&z, MOID (s), NO_TEXT, NODE (s)); } } else { (void) add_mode_to_pack (&z, MOID (t), NO_TEXT, NODE (t)); } } u = z; } while (go_on); return (z); } /*! \brief absorb nested series modes recursively \param p mode **/ static void absorb_series_pack (MOID_T ** p) { BOOL_T go_on; do { PACK_T *z = NO_PACK, *t; go_on = A68_FALSE; for (t = PACK (*p); t != NO_PACK; FORWARD (t)) { if (MOID (t) != NO_MOID && IS (MOID (t), SERIES_MODE)) { PACK_T *s; go_on = A68_TRUE; for (s = PACK (MOID (t)); s != NO_PACK; FORWARD (s)) { add_mode_to_pack (&z, MOID (s), NO_TEXT, NODE (s)); } } else { add_mode_to_pack (&z, MOID (t), NO_TEXT, NODE (t)); } } PACK (*p) = z; } while (go_on); } /*! \brief absorb nested series and united modes recursively \param p mode **/ static void absorb_series_union_pack (MOID_T ** p) { BOOL_T go_on; do { PACK_T *z = NO_PACK, *t; go_on = A68_FALSE; for (t = PACK (*p); t != NO_PACK; FORWARD (t)) { if (MOID (t) != NO_MOID && (IS (MOID (t), SERIES_MODE) || IS (MOID (t), UNION_SYMBOL))) { PACK_T *s; go_on = A68_TRUE; for (s = PACK (MOID (t)); s != NO_PACK; FORWARD (s)) { add_mode_to_pack (&z, MOID (s), NO_TEXT, NODE (s)); } } else { add_mode_to_pack (&z, MOID (t), NO_TEXT, NODE (t)); } } PACK (*p) = z; } while (go_on); } /*! \brief make SERIES (u, v) \param u mode 1 \param v mode 2 \return SERIES (u, v) **/ static MOID_T *make_series_from_moids (MOID_T * u, MOID_T * v) { MOID_T *x = new_moid (); ATTRIBUTE (x) = SERIES_MODE; add_mode_to_pack (&(PACK (x)), u, NO_TEXT, NODE (u)); add_mode_to_pack (&(PACK (x)), v, NO_TEXT, NODE (v)); absorb_series_pack (&x); DIM (x) = count_pack_members (PACK (x)); (void) register_extra_mode (&TOP_MOID (&program), x); if (DIM (x) == 1) { return (MOID (PACK (x))); } else { return (x); } } /*! \brief absorb firmly related unions in mode \param m united mode \return absorbed "m" **/ static MOID_T *absorb_related_subsets (MOID_T * m) { /* For instance invalid UNION (PROC REF UNION (A, B), A, B) -> valid UNION (A, B), which is used in balancing conformity clauses. */ int mods; do { PACK_T *u = NO_PACK, *v; mods = 0; for (v = PACK (m); v != NO_PACK; FORWARD (v)) { MOID_T *n = depref_completely (MOID (v)); if (IS (n, UNION_SYMBOL) && is_subset (n, m, SAFE_DEFLEXING)) { /* Unpack it */ PACK_T *w; for (w = PACK (n); w != NO_PACK; FORWARD (w)) { add_mode_to_pack (&u, MOID (w), NO_TEXT, NODE (w)); } mods++; } else { add_mode_to_pack (&u, MOID (v), NO_TEXT, NODE (v)); } } PACK (m) = absorb_union_pack (u); } while (mods != 0); return (m); } /*! \brief make united mode, from mode that is a SERIES (..) \param m series mode \return mode table entry **/ static MOID_T *make_united_mode (MOID_T * m) { MOID_T *u; PACK_T *v, *w; int mods; if (m == NO_MOID) { return (MODE (ERROR)); } else if (ATTRIBUTE (m) != SERIES_MODE) { return (m); } /* Do not unite a single UNION */ if (DIM (m) == 1 && IS (MOID (PACK (m)), UNION_SYMBOL)) { return (MOID (PACK (m))); } /* Straighten the series */ absorb_series_union_pack (&m); /* Copy the series into a UNION */ u = new_moid (); ATTRIBUTE (u) = UNION_SYMBOL; PACK (u) = NO_PACK; v = PACK (u); w = PACK (m); for (w = PACK (m); w != NO_PACK; FORWARD (w)) { add_mode_to_pack (&(PACK (u)), MOID (w), NO_TEXT, NODE (m)); } /* Absorb and contract the new UNION */ do { mods = 0; absorb_series_union_pack (&u); DIM (u) = count_pack_members (PACK (u)); PACK (u) = absorb_union_pack (PACK (u)); contract_union (u); } while (mods != 0); /* A UNION of one mode is that mode itself */ if (DIM (u) == 1) { return (MOID (PACK (u))); } else { return (register_extra_mode (&TOP_MOID (&program), u)); } } /*! \brief add row and its slices to chain, recursively \param p chain to insert into \param dim dimension \param sub mode of slice \param n position in tree \param derivate whether derived, ie. not in the source \return pointer to entry **/ static MOID_T *add_row (MOID_T ** p, int dim, MOID_T * sub, NODE_T * n, BOOL_T derivate) { MOID_T * q = add_mode (p, ROW_SYMBOL, dim, n, sub, NO_PACK); DERIVATE (q) |= derivate; if (dim > 1) { SLICE (q) = add_row (&NEXT (q), dim - 1, sub, n, derivate); } else { SLICE (q) = sub; } return (q); } /*! \brief add a moid to a pack, maybe with a (field) name \param p pack \param m moid to add \param text field name \param node position in tree **/ void add_mode_to_pack (PACK_T ** p, MOID_T * m, char *text, NODE_T * node) { PACK_T *z = new_pack (); MOID (z) = m; TEXT (z) = text; NODE (z) = node; NEXT (z) = *p; PREVIOUS (z) = NO_PACK; if (NEXT (z) != NO_PACK) { PREVIOUS (NEXT (z)) = z; } /* Link in chain */ *p = z; } /*! \brief add a moid to a pack, maybe with a (field) name \param p pack \param m moid to add \param text field name \param node position in tree **/ void add_mode_to_pack_end (PACK_T ** p, MOID_T * m, char *text, NODE_T * node) { PACK_T *z = new_pack (); MOID (z) = m; TEXT (z) = text; NODE (z) = node; NEXT (z) = NO_PACK; if (NEXT (z) != NO_PACK) { PREVIOUS (NEXT (z)) = z; } /* Link in chain */ while ((*p) != NO_PACK) { p = &(NEXT (*p)); } PREVIOUS (z) = (*p); (*p) = z; } /*! \brief absorb UNION members \param p position in tree \param mods modification count **/ static void absorb_unions (MOID_T * m) { /* UNION (A, UNION (B, C)) = UNION (A, B, C) or UNION (A, UNION (A, B)) = UNION (A, B). */ for (; m != NO_MOID; FORWARD (m)) { if (IS (m, UNION_SYMBOL)) { PACK (m) = absorb_union_pack (PACK (m)); } } } /*! \brief contract UNIONs \param p position in tree \param mods modification count **/ static void contract_unions (MOID_T * m) { /* UNION (A, B, A) -> UNION (A, B) */ for (; m != NO_MOID; FORWARD (m)) { if (IS (m, UNION_SYMBOL) && EQUIVALENT (m) == NO_MOID) { contract_union (m); } } } /***************************************************/ /* Routines to collect MOIDs from the program text */ /***************************************************/ /*! \brief search standard mode in standard environ \param sizety sizety \param indicant position in tree \return moid entry in standard environ **/ static MOID_T *search_standard_mode (int sizety, NODE_T * indicant) { MOID_T *p = TOP_MOID (&program); /* Search standard mode */ for (; p != NO_MOID; FORWARD (p)) { if (IS (p, STANDARD) && DIM (p) == sizety && NSYMBOL (NODE (p)) == NSYMBOL (indicant)) { return (p); } } /* Sanity check if (sizety == -2 || sizety == 2) { return (NO_MOID); } */ /* Map onto greater precision */ if (sizety < 0) { return (search_standard_mode (sizety + 1, indicant)); } else if (sizety > 0) { return (search_standard_mode (sizety - 1, indicant)); } else { return (NO_MOID); } } /*! \brief collect mode from STRUCT field \param p position in tree \param u pack to insert to **/ static void get_mode_from_struct_field (NODE_T * p, PACK_T ** u) { if (p != NO_NODE) { if (IS (p, IDENTIFIER)) { ATTRIBUTE (p) = FIELD_IDENTIFIER; (void) add_mode_to_pack (u, NO_MOID, NSYMBOL (p), p); } else if (IS (p, DECLARER)) { MOID_T *new_one = get_mode_from_declarer (p); PACK_T *t; get_mode_from_struct_field (NEXT (p), u); for (t = *u; t && MOID (t) == NO_MOID; FORWARD (t)) { MOID (t) = new_one; MOID (NODE (t)) = new_one; } } else { get_mode_from_struct_field (NEXT (p), u); get_mode_from_struct_field (SUB (p), u); } } } /*! \brief collect MODE from formal pack \param p position in tree \param u pack to insert to **/ static void get_mode_from_formal_pack (NODE_T * p, PACK_T ** u) { if (p != NO_NODE) { if (IS (p, DECLARER)) { MOID_T *z; get_mode_from_formal_pack (NEXT (p), u); z = get_mode_from_declarer (p); (void) add_mode_to_pack (u, z, NO_TEXT, p); } else { get_mode_from_formal_pack (NEXT (p), u); get_mode_from_formal_pack (SUB (p), u); } } } /*! \brief collect MODE or VOID from formal UNION pack \param p position in tree \param u pack to insert to **/ static void get_mode_from_union_pack (NODE_T * p, PACK_T ** u) { if (p != NO_NODE) { if (IS (p, DECLARER) || IS (p, VOID_SYMBOL)) { MOID_T *z; get_mode_from_union_pack (NEXT (p), u); z = get_mode_from_declarer (p); (void) add_mode_to_pack (u, z, NO_TEXT, p); } else { get_mode_from_union_pack (NEXT (p), u); get_mode_from_union_pack (SUB (p), u); } } } /*! \brief collect mode from PROC, OP pack \param p position in tree \param u pack to insert to **/ static void get_mode_from_routine_pack (NODE_T * p, PACK_T ** u) { if (p != NO_NODE) { if (IS (p, IDENTIFIER)) { (void) add_mode_to_pack (u, NO_MOID, NO_TEXT, p); } else if (IS (p, DECLARER)) { MOID_T *z = get_mode_from_declarer (p); PACK_T *t = *u; for (; t != NO_PACK && MOID (t) == NO_MOID; FORWARD (t)) { MOID (t) = z; MOID (NODE (t)) = z; } (void) add_mode_to_pack (u, z, NO_TEXT, p); } else { get_mode_from_routine_pack (NEXT (p), u); get_mode_from_routine_pack (SUB (p), u); } } } /*! \brief collect MODE from DECLARER \param p position in tree \param put_where insert in symbol table from "p" or in its parent \return mode table entry **/ static MOID_T *get_mode_from_declarer (NODE_T * p) { if (p == NO_NODE) { return (NO_MOID); } else { if (IS (p, DECLARER)) { if (MOID (p) != NO_MOID) { return (MOID (p)); } else { return (MOID (p) = get_mode_from_declarer (SUB (p))); } } else { if (IS (p, VOID_SYMBOL)) { MOID (p) = MODE (VOID); return (MOID (p)); } else if (IS (p, LONGETY)) { if (whether (p, LONGETY, INDICANT, STOP)) { int k = count_sizety (SUB (p)); MOID (p) = search_standard_mode (k, NEXT (p)); return (MOID (p)); } else { return (NO_MOID); } } else if (IS (p, SHORTETY)) { if (whether (p, SHORTETY, INDICANT, STOP)) { int k = count_sizety (SUB (p)); MOID (p) = search_standard_mode (k, NEXT (p)); return (MOID (p)); } else { return (NO_MOID); } } else if (IS (p, INDICANT)) { MOID_T *q = search_standard_mode (0, p); if (q != NO_MOID) { MOID (p) = q; } else { /* Position of definition tells indicants apart */ TAG_T *y = find_tag_global (TABLE (p), INDICANT, NSYMBOL (p)); if (y == NO_TAG) { diagnostic_node (A68_ERROR, p, ERROR_UNDECLARED_TAG_2, NSYMBOL (p)); } else { MOID (p) = add_mode (&TOP_MOID (&program), INDICANT, 0, NODE (y), NO_MOID, NO_PACK); } } return (MOID (p)); } else if (IS (p, REF_SYMBOL)) { MOID_T *new_one = get_mode_from_declarer (NEXT (p)); MOID (p) = add_mode (&TOP_MOID (&program), REF_SYMBOL, 0, p, new_one, NO_PACK); return (MOID (p)); } else if (IS (p, FLEX_SYMBOL)) { MOID_T *new_one = get_mode_from_declarer (NEXT (p)); MOID (p) = add_mode (&TOP_MOID (&program), FLEX_SYMBOL, 0, p, new_one, NO_PACK); SLICE (MOID (p)) = SLICE (new_one); return (MOID (p)); } else if (IS (p, FORMAL_BOUNDS)) { MOID_T *new_one = get_mode_from_declarer (NEXT (p)); MOID (p) = add_row (&TOP_MOID (&program), 1 + count_formal_bounds (SUB (p)), new_one, p, A68_FALSE); return (MOID (p)); } else if (IS (p, BOUNDS)) { MOID_T *new_one = get_mode_from_declarer (NEXT (p)); MOID (p) = add_row (&TOP_MOID (&program), count_bounds (SUB (p)), new_one, p, A68_FALSE); return (MOID (p)); } else if (IS (p, STRUCT_SYMBOL)) { PACK_T *u = NO_PACK; get_mode_from_struct_field (NEXT (p), &u); MOID (p) = add_mode (&TOP_MOID (&program), STRUCT_SYMBOL, count_pack_members (u), p, NO_MOID, u); return (MOID (p)); } else if (IS (p, UNION_SYMBOL)) { PACK_T *u = NO_PACK; get_mode_from_union_pack (NEXT (p), &u); MOID (p) = add_mode (&TOP_MOID (&program), UNION_SYMBOL, count_pack_members (u), p, NO_MOID, u); return (MOID (p)); } else if (IS (p, PROC_SYMBOL)) { NODE_T *save = p; PACK_T *u = NO_PACK; MOID_T *new_one; if (IS (NEXT (p), FORMAL_DECLARERS)) { get_mode_from_formal_pack (SUB_NEXT (p), &u); FORWARD (p); } new_one = get_mode_from_declarer (NEXT (p)); MOID (p) = add_mode (&TOP_MOID (&program), PROC_SYMBOL, count_pack_members (u), save, new_one, u); MOID (save) = MOID (p); return (MOID (p)); } else { return (NO_MOID); } } } } /*! \brief collect MODEs from a routine-text header \param p position in tree \return mode table entry **/ static MOID_T *get_mode_from_routine_text (NODE_T * p) { PACK_T *u = NO_PACK; MOID_T *n; NODE_T *q = p; if (IS (p, PARAMETER_PACK)) { get_mode_from_routine_pack (SUB (p), &u); FORWARD (p); } n = get_mode_from_declarer (p); return (add_mode (&TOP_MOID (&program), PROC_SYMBOL, count_pack_members (u), q, n, u)); } /*! \brief collect modes from operator-plan \param p position in tree \return mode table entry **/ static MOID_T *get_mode_from_operator (NODE_T * p) { PACK_T *u = NO_PACK; MOID_T *new_one; NODE_T *save = p; if (IS (NEXT (p), FORMAL_DECLARERS)) { get_mode_from_formal_pack (SUB_NEXT (p), &u); FORWARD (p); } new_one = get_mode_from_declarer (NEXT (p)); MOID (p) = add_mode (&TOP_MOID (&program), PROC_SYMBOL, count_pack_members (u), save, new_one, u); return (MOID (p)); } /*! \brief collect mode from denotation \param p position in tree \return mode table entry **/ static void get_mode_from_denotation (NODE_T * p, int sizety) { if (p != NO_NODE) { if (IS (p, ROW_CHAR_DENOTATION)) { if (strlen (NSYMBOL (p)) == 1) { MOID (p) = MODE (CHAR); } else { MOID (p) = MODE (ROW_CHAR); } } else if (IS (p, TRUE_SYMBOL) || IS (p, FALSE_SYMBOL)) { MOID (p) = MODE (BOOL); } else if (IS (p, INT_DENOTATION)) { if (sizety == 0) { MOID (p) = MODE (INT); } else if (sizety == 1) { MOID (p) = MODE (LONG_INT); } else if (sizety == 2) { MOID (p) = MODE (LONGLONG_INT); } else { MOID (p) = (sizety > 0 ? MODE (LONGLONG_INT) : MODE (INT)); } } else if (IS (p, REAL_DENOTATION)) { if (sizety == 0) { MOID (p) = MODE (REAL); } else if (sizety == 1) { MOID (p) = MODE (LONG_REAL); } else if (sizety == 2) { MOID (p) = MODE (LONGLONG_REAL); } else { MOID (p) = (sizety > 0 ? MODE (LONGLONG_REAL) : MODE (REAL)); } } else if (IS (p, BITS_DENOTATION)) { if (sizety == 0) { MOID (p) = MODE (BITS); } else if (sizety == 1) { MOID (p) = MODE (LONG_BITS); } else if (sizety == 2) { MOID (p) = MODE (LONGLONG_BITS); } else { MOID (p) = (sizety > 0 ? MODE (LONGLONG_BITS) : MODE (BITS)); } } else if (IS (p, LONGETY) || IS (p, SHORTETY)) { get_mode_from_denotation (NEXT (p), count_sizety (SUB (p))); MOID (p) = MOID (NEXT (p)); } else if (IS (p, EMPTY_SYMBOL)) { MOID (p) = MODE (VOID); } } } /*! \brief collect modes from the syntax tree \param p position in tree \param attribute **/ static void get_modes_from_tree (NODE_T * p, int attribute) { NODE_T *q; for (q = p; q != NO_NODE; FORWARD (q)) { if (IS (q, VOID_SYMBOL)) { MOID (q) = MODE (VOID); } else if (IS (q, DECLARER)) { if (attribute == VARIABLE_DECLARATION) { MOID_T *new_one = get_mode_from_declarer (q); MOID (q) = add_mode (&TOP_MOID (&program), REF_SYMBOL, 0, NO_NODE, new_one, NO_PACK); } else { MOID (q) = get_mode_from_declarer (q); } } else if (IS (q, ROUTINE_TEXT)) { MOID (q) = get_mode_from_routine_text (SUB (q)); } else if (IS (q, OPERATOR_PLAN)) { MOID (q) = get_mode_from_operator (SUB (q)); } else if (is_one_of (q, LOC_SYMBOL, HEAP_SYMBOL, NEW_SYMBOL, STOP)) { if (attribute == GENERATOR) { MOID_T *new_one = get_mode_from_declarer (NEXT (q)); MOID (NEXT (q)) = new_one; MOID (q) = add_mode (&TOP_MOID (&program), REF_SYMBOL, 0, NO_NODE, new_one, NO_PACK); } } else { if (attribute == DENOTATION) { get_mode_from_denotation (q, 0); } } } if (attribute != DENOTATION) { for (q = p; q != NO_NODE; FORWARD (q)) { if (SUB (q) != NO_NODE) { get_modes_from_tree (SUB (q), ATTRIBUTE (q)); } } } } /*! \brief collect modes from proc variables \param p position in tree **/ static void get_mode_from_proc_variables (NODE_T * p) { if (p != NO_NODE) { if (IS (p, PROCEDURE_VARIABLE_DECLARATION)) { get_mode_from_proc_variables (SUB (p)); get_mode_from_proc_variables (NEXT (p)); } else if (IS (p, QUALIFIER) || IS (p, PROC_SYMBOL) || IS (p, COMMA_SYMBOL)) { get_mode_from_proc_variables (NEXT (p)); } else if (IS (p, DEFINING_IDENTIFIER)) { MOID_T *new_one = MOID (NEXT_NEXT (p)); MOID (p) = add_mode (&TOP_MOID (&program), REF_SYMBOL, 0, p, new_one, NO_PACK); } } } /*! \brief collect modes from proc variable declarations \param p position in tree **/ static void get_mode_from_proc_var_declarations_tree (NODE_T * p) { for (; p != NO_NODE; FORWARD (p)) { get_mode_from_proc_var_declarations_tree (SUB (p)); if (IS (p, PROCEDURE_VARIABLE_DECLARATION)) { get_mode_from_proc_variables (p); } } } /**********************************/ /* Various routines to test modes */ /**********************************/ /*! \brief whether a mode declaration refers to self or relates to void \param def entry of indicant in mode table, NO_MOID if z is an applied mode \param z mode to check \param yin whether shields YIN \param yang whether shields YANG \param video whether shields VOID \param p mode under test \return same **/ static BOOL_T is_well_formed (MOID_T *def, MOID_T * z, BOOL_T yin, BOOL_T yang, BOOL_T video) { if (z == NO_MOID) { return (A68_FALSE); } else if (yin && yang) { return (z == MODE (VOID) ? video : A68_TRUE); } else if (z == MODE (VOID)) { return (video); } else if (IS (z, STANDARD)) { return (A68_TRUE); } else if (IS (z, INDICANT)) { if (def == NO_MOID) { /* Check an applied indicant for relation to VOID */ while (z != NO_MOID) { z = EQUIVALENT (z); } if (z == MODE (VOID)) { return (video); } else { return (A68_TRUE); } } else { if (z == def || USE (z)) { return (yin && yang); } else { BOOL_T wwf; USE (z) = A68_TRUE; wwf = is_well_formed (def, EQUIVALENT (z), yin, yang, video); USE (z) = A68_FALSE; return (wwf); } } } else if (IS (z, REF_SYMBOL)) { return (is_well_formed (def, SUB (z), A68_TRUE, yang, A68_FALSE)); } else if (IS (z, PROC_SYMBOL)) { return (PACK (z) != NO_PACK ? A68_TRUE : is_well_formed (def, SUB (z), A68_TRUE, yang, A68_TRUE)); } else if (IS (z, ROW_SYMBOL)) { return (is_well_formed (def, SUB (z), yin, yang, A68_FALSE)); } else if (IS (z, FLEX_SYMBOL)) { return (is_well_formed (def, SUB (z), yin, yang, A68_FALSE)); } else if (IS (z, STRUCT_SYMBOL)) { PACK_T *s = PACK (z); for (; s != NO_PACK; FORWARD (s)) { if (! is_well_formed (def, MOID (s), yin, A68_TRUE, A68_FALSE)) { return (A68_FALSE); } } return (A68_TRUE); } else if (IS (z, UNION_SYMBOL)) { PACK_T *s = PACK (z); for (; s != NO_PACK; FORWARD (s)) { if (! is_well_formed (def, MOID (s), yin, yang, A68_TRUE)) { return (A68_FALSE); } } return (A68_TRUE); } else { return (A68_FALSE); } } /*! \brief replace a mode by its equivalent mode (walk chain) \param q mode to track **/ static void resolve_eq_members (MOID_T * q) { PACK_T *p; resolve_equivalent (&SUB (q)); resolve_equivalent (&DEFLEXED (q)); resolve_equivalent (&MULTIPLE (q)); resolve_equivalent (&NAME (q)); resolve_equivalent (&SLICE (q)); resolve_equivalent (&TRIM (q)); resolve_equivalent (&ROWED (q)); for (p = PACK (q); p != NO_PACK; FORWARD (p)) { resolve_equivalent (&MOID (p)); } } /*! \brief track equivalent tags \param z tag to track **/ static void resolve_eq_tags (TAG_T * z) { for (; z != NO_TAG; FORWARD (z)) { if (MOID (z) != NO_MOID) { resolve_equivalent (& MOID (z)); } } } /*! \brief bind modes in syntax tree \param p position in tree **/ static void bind_modes (NODE_T * p) { for (; p != NO_NODE; FORWARD (p)) { resolve_equivalent (& MOID (p)); if (SUB (p) != NO_NODE && is_new_lexical_level (p)) { TABLE_T *s = TABLE (SUB (p)); TAG_T *z = INDICANTS (s); for (; z != NO_TAG; FORWARD (z)) { if (NODE (z) != NO_NODE) { resolve_equivalent (& MOID (NEXT_NEXT (NODE (z)))); MOID (z) = MOID (NEXT_NEXT (NODE (z))); MOID (NODE (z)) = MOID (z); } } } bind_modes (SUB (p)); } } /* Routines for calculating subordinates for selections, for instance selection from REF STRUCT (A) yields REF A fields and selection from [] STRUCT (A) yields [] A fields. */ /*! \brief make name pack \param src source pack \param dst destination pack with REF modes \param p chain to insert new modes into **/ static void make_name_pack (PACK_T * src, PACK_T ** dst, MOID_T ** p) { if (src != NO_PACK) { MOID_T *z; make_name_pack (NEXT (src), dst, p); z = add_mode (p, REF_SYMBOL, 0, NO_NODE, MOID (src), NO_PACK); (void) add_mode_to_pack (dst, z, TEXT (src), NODE (src)); } } /*! \brief make flex multiple row pack \param src source pack \param dst destination pack with REF modes \param p chain to insert new modes into \param dim dimension **/ static void make_flex_multiple_row_pack (PACK_T * src, PACK_T ** dst, MOID_T ** p, int dim) { if (src != NO_PACK) { MOID_T *z; make_flex_multiple_row_pack (NEXT (src), dst, p, dim); z = add_row (p, dim, MOID (src), NO_NODE, A68_FALSE); z = add_mode (p, FLEX_SYMBOL, 0, NO_NODE, z, NO_PACK); (void) add_mode_to_pack (dst, z, TEXT (src), NODE (src)); } } /*! \brief make name struct \param m structured mode \param p chain to insert new modes into \return mode table entry **/ static MOID_T *make_name_struct (MOID_T * m, MOID_T ** p) { PACK_T *u = NO_PACK; make_name_pack (PACK (m), &u, p); return (add_mode (p, STRUCT_SYMBOL, DIM (m), NO_NODE, NO_MOID, u)); } /*! \brief make name row \param m rowed mode \param p chain to insert new modes into \return mode table entry **/ static MOID_T *make_name_row (MOID_T * m, MOID_T ** p) { if (SLICE (m) != NO_MOID) { return (add_mode (p, REF_SYMBOL, 0, NO_NODE, SLICE (m), NO_PACK)); } else if (SUB (m) != NO_MOID) { return (add_mode (p, REF_SYMBOL, 0, NO_NODE, SUB (m), NO_PACK)); } else { return (NO_MOID); /* weird, FLEX INT or so ... */ } } /*! \brief make multiple row pack \param src source pack \param dst destination pack with REF modes \param p chain to insert new modes into \param dim dimension **/ static void make_multiple_row_pack (PACK_T * src, PACK_T ** dst, MOID_T ** p, int dim) { if (src != NO_PACK) { make_multiple_row_pack (NEXT (src), dst, p, dim); (void) add_mode_to_pack (dst, add_row (p, dim, MOID (src), NO_NODE, A68_FALSE), TEXT (src), NODE (src)); } } /*! \brief make flex multiple struct \param m structured mode \param p chain to insert new modes into \param dim dimension \return mode table entry **/ static MOID_T *make_flex_multiple_struct (MOID_T * m, MOID_T ** p, int dim) { PACK_T *u = NO_PACK; make_flex_multiple_row_pack (PACK (m), &u, p, dim); return (add_mode (p, STRUCT_SYMBOL, DIM (m), NO_NODE, NO_MOID, u)); } /*! \brief make multiple struct \param m structured mode \param p chain to insert new modes into \param dim dimension \return mode table entry **/ static MOID_T *make_multiple_struct (MOID_T * m, MOID_T ** p, int dim) { PACK_T *u = NO_PACK; make_multiple_row_pack (PACK (m), &u, p, dim); return (add_mode (p, STRUCT_SYMBOL, DIM (m), NO_NODE, NO_MOID, u)); } /*! \brief whether mode has row \param m mode under test \return same **/ static BOOL_T is_mode_has_row (MOID_T * m) { if (IS (m, STRUCT_SYMBOL) || IS (m, UNION_SYMBOL)) { BOOL_T k = A68_FALSE; PACK_T *p = PACK (m); for (; p != NO_PACK && k == A68_FALSE; FORWARD (p)) { HAS_ROWS (MOID (p)) = is_mode_has_row (MOID (p)); k |= (HAS_ROWS (MOID (p))); } return (k); } else { return ((BOOL_T) (HAS_ROWS (m) || IS (m, ROW_SYMBOL) || IS (m, FLEX_SYMBOL))); } } /*! \brief compute derived modes \param mod module **/ static void compute_derived_modes (MODULE_T *mod) { MOID_T *z; int k, len = 0, nlen = 1; /* UNION things */ absorb_unions (TOP_MOID (mod)); contract_unions (TOP_MOID (mod)); /* The for-statement below prevents an endless loop */ for (k = 1; k <= 10 && len != nlen; k ++) { /* Make deflexed modes */ for (z = TOP_MOID (mod); z != NO_MOID; FORWARD (z)) { if (SUB (z) != NO_MOID) { if (IS_REF_FLEX (z) && DEFLEXED (SUB_SUB (z)) != NO_MOID) { DEFLEXED (z) = add_mode (&TOP_MOID (mod), REF_SYMBOL, 0, NODE (z), DEFLEXED (SUB_SUB (z)), NO_PACK); } else if (IS (z, REF_SYMBOL) && DEFLEXED (SUB (z)) != NO_MOID) { DEFLEXED (z) = add_mode (&TOP_MOID (mod), REF_SYMBOL, 0, NODE (z), DEFLEXED (SUB (z)), NO_PACK); } else if (IS (z, ROW_SYMBOL) && DEFLEXED (SUB (z)) != NO_MOID) { DEFLEXED (z) = add_mode (&TOP_MOID (mod), ROW_SYMBOL, DIM (z), NODE (z), DEFLEXED (SUB (z)), NO_PACK); } else if (IS (z, FLEX_SYMBOL) && DEFLEXED (SUB (z)) != NO_MOID) { DEFLEXED (z) = DEFLEXED (SUB (z)); } else if (IS (z, FLEX_SYMBOL)) { DEFLEXED (z) = SUB (z); } else { DEFLEXED (z) = z; } } } /* Derived modes for stowed modes */ for (z = TOP_MOID (mod); z != NO_MOID; FORWARD (z)) { if (NAME (z) == NO_MOID && IS (z, REF_SYMBOL)) { if (IS (SUB (z), STRUCT_SYMBOL)) { NAME (z) = make_name_struct (SUB (z), &TOP_MOID (mod)); } else if (IS (SUB (z), ROW_SYMBOL)) { NAME (z) = make_name_row (SUB (z), &TOP_MOID (mod)); } else if (IS (SUB (z), FLEX_SYMBOL) && SUB_SUB (z) != NO_MOID) { NAME (z) = make_name_row (SUB_SUB (z), &TOP_MOID (mod)); } } if (MULTIPLE (z) != NO_MOID) { ; } else if (IS (z, REF_SYMBOL)) { if (MULTIPLE (SUB (z)) != NO_MOID) { MULTIPLE (z) = make_name_struct (MULTIPLE (SUB (z)), &TOP_MOID (mod)); } } else if (IS (z, ROW_SYMBOL)) { if (IS (SUB (z), STRUCT_SYMBOL)) { MULTIPLE (z) = make_multiple_struct (SUB (z), &TOP_MOID (mod), DIM (z)); } } } for (z = TOP_MOID (mod); z != NO_MOID; FORWARD (z)) { if (TRIM (z) == NO_MOID && IS (z, FLEX_SYMBOL)) { TRIM (z) = SUB (z); } if (TRIM (z) == NO_MOID && IS_REF_FLEX (z)) { TRIM (z) = add_mode (&TOP_MOID (mod), REF_SYMBOL, 0, NODE (z), SUB_SUB (z), NO_PACK); } } /* Fill out stuff for rows, f.i. inverse relations */ for (z = TOP_MOID (mod); z != NO_MOID; FORWARD (z)) { if (IS (z, ROW_SYMBOL) && DIM (z) > 0 && SUB (z) != NO_MOID && ! DERIVATE (z)) { (void) add_row (&TOP_MOID (mod), DIM (z) + 1, SUB (z), NODE (z), A68_TRUE); } else if (IS (z, REF_SYMBOL) && IS (SUB (z), ROW_SYMBOL) && ! DERIVATE (SUB (z))) { MOID_T *x = add_row (&TOP_MOID (mod), DIM (SUB (z)) + 1, SUB_SUB (z), NODE (SUB (z)), A68_TRUE); MOID_T *y = add_mode (&TOP_MOID (mod), REF_SYMBOL, 0, NODE (z), x, NO_PACK); NAME (y) = z; } } for (z = TOP_MOID (mod); z != NO_MOID; FORWARD (z)) { if (IS (z, ROW_SYMBOL) && SLICE (z) != NO_MOID) { ROWED (SLICE (z)) = z; } if (IS (z, REF_SYMBOL)) { MOID_T *y = SUB (z); if (SLICE (y) != NO_MOID && IS (SLICE (y), ROW_SYMBOL) && NAME (z) != NO_MOID) { ROWED (NAME (z)) = z; } } } bind_modes (TOP_NODE (mod)); for (z = TOP_MOID (mod); z != NO_MOID; FORWARD (z)) { if (IS (z, INDICANT) && NODE (z) != NO_NODE) { EQUIVALENT (z) = MOID (NODE (z)); } } for (z = TOP_MOID (mod); z != NO_MOID; FORWARD (z)) { resolve_eq_members (z); } resolve_eq_tags (INDICANTS (a68g_standenv)); resolve_eq_tags (IDENTIFIERS (a68g_standenv)); resolve_eq_tags (OPERATORS (a68g_standenv)); resolve_equivalent (&MODE (STRING)); resolve_equivalent (&MODE (COMPLEX)); resolve_equivalent (&MODE (COMPL)); resolve_equivalent (&MODE (LONG_COMPLEX)); resolve_equivalent (&MODE (LONG_COMPL)); resolve_equivalent (&MODE (LONGLONG_COMPLEX)); resolve_equivalent (&MODE (LONGLONG_COMPL)); resolve_equivalent (&MODE (SEMA)); resolve_equivalent (&MODE (PIPE)); /* UNION members could be resolved */ absorb_unions (TOP_MOID (mod)); contract_unions (TOP_MOID (mod)); /* FLEX INDICANT could be resolved */ for (z = TOP_MOID (mod); z != NO_MOID; FORWARD (z)) { if (IS (z, FLEX_SYMBOL) && SUB (z) != NO_MOID) { if (SUB_SUB (z) != NO_MOID && IS (SUB_SUB (z), STRUCT_SYMBOL)) { MULTIPLE (z) = make_flex_multiple_struct (SUB_SUB (z), &TOP_MOID (mod), DIM (SUB (z))); } } } /* See what new known modes we have generated by resolving. */ for (z = TOP_MOID (mod); z != STANDENV_MOID (&program); FORWARD (z)) { MOID_T *v; for (v = NEXT (z); v != NO_MOID; FORWARD (v)) { if (prove_moid_equivalence (z, v)) { EQUIVALENT (z) = v; EQUIVALENT (v) = NO_MOID; } } } /* Count the modes to check self consistency */ len = nlen; for (nlen = 0, z = TOP_MOID (mod); z != NO_MOID; FORWARD (z)) { nlen++; } } ABEND (MODE (STRING) != MODE (FLEX_ROW_CHAR), "equivalencing is broken", NO_TEXT); /* Find out what modes contain rows */ for (z = TOP_MOID (mod); z != NO_MOID; FORWARD (z)) { HAS_ROWS (z) = is_mode_has_row (z); } /* Check flexible modes */ for (z = TOP_MOID (mod); z != NO_MOID; FORWARD (z)) { if (IS (z, FLEX_SYMBOL) && ISNT (SUB (z), ROW_SYMBOL)) { diagnostic_node (A68_ERROR, NODE (z), ERROR_NOT_WELL_FORMED, z); } } /* Check on fields in structured modes f.i. STRUCT (REAL x, INT n, REAL x) is wrong */ for (z = TOP_MOID (mod); z != NO_MOID; FORWARD (z)) { if (IS (z, STRUCT_SYMBOL) && EQUIVALENT (z) == NO_MOID) { PACK_T *s = PACK (z); for (; s != NO_PACK; FORWARD (s)) { PACK_T *t = NEXT (s); BOOL_T x = A68_TRUE; for (t = NEXT (s); t != NO_PACK && x; FORWARD (t)) { if (TEXT (s) == TEXT (t)) { diagnostic_node (A68_ERROR, NODE (z), ERROR_MULTIPLE_FIELD); while (NEXT (s) != NO_PACK && TEXT (NEXT (s)) == TEXT (t)) { FORWARD (s); } x = A68_FALSE; } } } } } /* Various union test */ for (z = TOP_MOID (mod); z != NO_MOID; FORWARD (z)) { if (IS (z, UNION_SYMBOL) && EQUIVALENT (z) == NO_MOID) { PACK_T *s = PACK (z); /* Discard unions with one member */ if (count_pack_members (s) == 1) { diagnostic_node (A68_ERROR, NODE (z), ERROR_COMPONENT_NUMBER, z); } /* Discard incestuous unions with firmly related modes */ for (; s != NO_PACK; FORWARD (s)) { PACK_T *t; for (t = NEXT (s); t != NO_PACK; FORWARD (t)) { if (MOID (t) != MOID (s)) { if (is_firm (MOID (s), MOID (t))) { diagnostic_node (A68_ERROR, NODE (z), ERROR_COMPONENT_RELATED, z); } } } } /* Discard incestuous unions with firmly related subsets */ for (s = PACK (z); s != NO_PACK; FORWARD (s)) { MOID_T *n = depref_completely (MOID (s)); if (IS (n, UNION_SYMBOL) && is_subset (n, z, NO_DEFLEXING)) { diagnostic_node (A68_ERROR, NODE (z), ERROR_SUBSET_RELATED, z, n); } } } } /* Wrap up and exit */ /* Overwrite old equivalent modes now */ /* for (u = &TOP_MOID (mod); (*u) != NO_MOID; u = & NEXT (*u)) { while ((*u) != NO_MOID && EQUIVALENT (*u) != NO_MOID) { (*u) = NEXT (*u); } } */ free_postulate_list (top_postulate, NO_POSTULATE); top_postulate = NO_POSTULATE; } /*! \brief make list of all modes in the program \param top_node top node in tree **/ void make_moid_list (MODULE_T *mod) { MOID_T *z; /* Collect modes from the syntax tree */ reset_moid_tree (TOP_NODE (mod)); get_modes_from_tree (TOP_NODE (mod), STOP); get_mode_from_proc_var_declarations_tree (TOP_NODE (mod)); /* Connect indicants to their declarers */ for (z = TOP_MOID (mod); z != NO_MOID; FORWARD (z)) { if (IS (z, INDICANT)) { NODE_T *u = NODE (z); ABEND (NEXT (u) == NO_NODE, "error in mode table", NO_TEXT); ABEND (NEXT_NEXT (u) == NO_NODE, "error in mode table", NO_TEXT); ABEND (MOID (NEXT_NEXT (u)) == NO_MOID, "error in mode table", NO_TEXT); EQUIVALENT (z) = MOID (NEXT_NEXT (u)); } } /* Checks on wrong declarations */ for (z = TOP_MOID (mod); z != NO_MOID; FORWARD (z)) { USE (z) = A68_FALSE; } for (z = TOP_MOID (mod); z != NO_MOID; FORWARD (z)) { if (IS (z, INDICANT) && EQUIVALENT (z) != NO_MOID) { if (!is_well_formed (z, EQUIVALENT (z), A68_FALSE, A68_FALSE, A68_TRUE)) { diagnostic_node (A68_ERROR, NODE (z), ERROR_NOT_WELL_FORMED, z); } } else if (NODE (z) != NO_NODE) { if (!is_well_formed (NO_MOID, z, A68_FALSE, A68_FALSE, A68_TRUE)) { diagnostic_node (A68_ERROR, NODE (z), ERROR_NOT_WELL_FORMED, z); } } } for (z = TOP_MOID (mod); z != NO_MOID; FORWARD (z)) { ABEND (USE (z), ERROR_INTERNAL_CONSISTENCY, NO_TEXT); } if (ERROR_COUNT (mod) != 0) { return; } compute_derived_modes (mod); init_postulates (); } /****************************************/ /* Symbol table handling, managing TAGS */ /****************************************/ /* \brief set level for procedures \param p position in tree \param n proc level number */ void set_proc_level (NODE_T * p, int n) { for (; p != NO_NODE; FORWARD (p)) { PROCEDURE_LEVEL (INFO (p)) = n; if (IS (p, ROUTINE_TEXT)) { set_proc_level (SUB (p), n + 1); } else { set_proc_level (SUB (p), n); } } } /* \brief set nests for diagnostics \param p position in tree \param s start of enclosing nest */ void set_nest (NODE_T * p, NODE_T * s) { for (; p != NO_NODE; FORWARD (p)) { NEST (p) = s; if (IS (p, PARTICULAR_PROGRAM)) { set_nest (SUB (p), p); } else if (IS (p, CLOSED_CLAUSE) && LINE_NUMBER (p) != 0) { set_nest (SUB (p), p); } else if (IS (p, COLLATERAL_CLAUSE) && LINE_NUMBER (p) != 0) { set_nest (SUB (p), p); } else if (IS (p, CONDITIONAL_CLAUSE) && LINE_NUMBER (p) != 0) { set_nest (SUB (p), p); } else if (IS (p, CASE_CLAUSE) && LINE_NUMBER (p) != 0) { set_nest (SUB (p), p); } else if (IS (p, CONFORMITY_CLAUSE) && LINE_NUMBER (p) != 0) { set_nest (SUB (p), p); } else if (IS (p, LOOP_CLAUSE) && LINE_NUMBER (p) != 0) { set_nest (SUB (p), p); } else { set_nest (SUB (p), s); } } } /* Routines that work with tags and symbol tables */ static void tax_tags (NODE_T *); static void tax_specifier_list (NODE_T *); static void tax_parameter_list (NODE_T *); static void tax_format_texts (NODE_T *); /*! \brief find a tag, searching symbol tables towards the root \param table symbol table to search \param a attribute of tag \param name name of tag \return type of tag, identifier or label or ... **/ int first_tag_global (TABLE_T * table, char *name) { if (table != NO_TABLE) { TAG_T *s = NO_TAG; for (s = IDENTIFIERS (table); s != NO_TAG; FORWARD (s)) { if (NSYMBOL (NODE (s)) == name) { return (IDENTIFIER); } } for (s = INDICANTS (table); s != NO_TAG; FORWARD (s)) { if (NSYMBOL (NODE (s)) == name) { return (INDICANT); } } for (s = LABELS (table); s != NO_TAG; FORWARD (s)) { if (NSYMBOL (NODE (s)) == name) { return (LABEL); } } for (s = OPERATORS (table); s != NO_TAG; FORWARD (s)) { if (NSYMBOL (NODE (s)) == name) { return (OP_SYMBOL); } } for (s = PRIO (table); s != NO_TAG; FORWARD (s)) { if (NSYMBOL (NODE (s)) == name) { return (PRIO_SYMBOL); } } return (first_tag_global (PREVIOUS (table), name)); } else { return (STOP); } } #define PORTCHECK_TAX(p, q) {\ if (q == A68_FALSE) {\ diagnostic_node (A68_WARNING | A68_FORCE_DIAGNOSTICS, p, WARNING_TAG_NOT_PORTABLE);\ }} /*! \brief check portability of sub tree \param p position in tree **/ void portcheck (NODE_T * p) { for (; p != NO_NODE; FORWARD (p)) { portcheck (SUB (p)); if (OPTION_PORTCHECK (&program)) { if (IS (p, INDICANT) && MOID (p) != NO_MOID) { PORTCHECK_TAX (p, PORTABLE (MOID (p))); PORTABLE (MOID (p)) = A68_TRUE; } else if (IS (p, IDENTIFIER)) { PORTCHECK_TAX (p, PORTABLE (TAX (p))); PORTABLE (TAX (p)) = A68_TRUE; } else if (IS (p, OPERATOR)) { PORTCHECK_TAX (p, PORTABLE (TAX (p))); PORTABLE (TAX (p)) = A68_TRUE; } } } } /*! \brief whether routine can be "lengthety-mapped" \param z name of routine \return same **/ static BOOL_T is_mappable_routine (char *z) { #define ACCEPT(u, v) {\ if (strlen (u) >= strlen (v)) {\ if (strcmp (&u[strlen (u) - strlen (v)], v) == 0) {\ return (A68_TRUE);\ }}} /* Math routines */ ACCEPT (z, "arccos"); ACCEPT (z, "arcsin"); ACCEPT (z, "arctan"); ACCEPT (z, "cbrt"); ACCEPT (z, "cos"); ACCEPT (z, "curt"); ACCEPT (z, "exp"); ACCEPT (z, "ln"); ACCEPT (z, "log"); ACCEPT (z, "pi"); ACCEPT (z, "sin"); ACCEPT (z, "sqrt"); ACCEPT (z, "tan"); /* Random generator */ ACCEPT (z, "nextrandom"); ACCEPT (z, "random"); /* BITS */ ACCEPT (z, "bitspack"); /* Enquiries */ ACCEPT (z, "maxint"); ACCEPT (z, "intwidth"); ACCEPT (z, "maxreal"); ACCEPT (z, "realwidth"); ACCEPT (z, "expwidth"); ACCEPT (z, "maxbits"); ACCEPT (z, "bitswidth"); ACCEPT (z, "byteswidth"); ACCEPT (z, "smallreal"); return (A68_FALSE); #undef ACCEPT } /*! \brief map "short sqrt" onto "sqrt" etcetera \param u name of routine \return tag to map onto **/ static TAG_T *bind_lengthety_identifier (char *u) { #define CAR(u, v) (strncmp (u, v, strlen(v)) == 0) /* We can only map routines blessed by "is_mappable_routine", so there is no "short print" or "long char in string". */ if (CAR (u, "short")) { do { char *v; TAG_T *w; u = &u[strlen ("short")]; v = TEXT (add_token (&top_token, u)); w = find_tag_local (a68g_standenv, IDENTIFIER, v); if (w != NO_TAG && is_mappable_routine (v)) { return (w); } } while (CAR (u, "short")); } else if (CAR (u, "long")) { do { char *v; TAG_T *w; u = &u[strlen ("long")]; v = TEXT (add_token (&top_token, u)); w = find_tag_local (a68g_standenv, IDENTIFIER, v); if (w != NO_TAG && is_mappable_routine (v)) { return (w); } } while (CAR (u, "long")); } return (NO_TAG); #undef CAR } /*! \brief bind identifier tags to the symbol table \param p position in tree **/ static void bind_identifier_tag_to_symbol_table (NODE_T * p) { for (; p != NO_NODE; FORWARD (p)) { bind_identifier_tag_to_symbol_table (SUB (p)); if (is_one_of (p, IDENTIFIER, DEFINING_IDENTIFIER, STOP)) { int att = first_tag_global (TABLE (p), NSYMBOL (p)); TAG_T *z; if (att == STOP) { if ((z = bind_lengthety_identifier (NSYMBOL (p))) != NO_TAG) { MOID (p) = MOID (z); /* } else { diagnostic_node (A68_ERROR, p, ERROR_UNDECLARED_TAG); z = add_tag (TABLE (p), IDENTIFIER, p, MODE (ERROR), NORMAL_IDENTIFIER); MOID (p) = MODE (ERROR); */ } TAX (p) = z; } else { z = find_tag_global (TABLE (p), att, NSYMBOL (p)); if (att == IDENTIFIER && z != NO_TAG) { MOID (p) = MOID (z); } else if (att == LABEL && z != NO_TAG) { ; } else if ((z = bind_lengthety_identifier (NSYMBOL (p))) != NO_TAG) { MOID (p) = MOID (z); } else { diagnostic_node (A68_ERROR, p, ERROR_UNDECLARED_TAG); z = add_tag (TABLE (p), IDENTIFIER, p, MODE (ERROR), NORMAL_IDENTIFIER); MOID (p) = MODE (ERROR); } TAX (p) = z; if (IS (p, DEFINING_IDENTIFIER)) { NODE (z) = p; } } } } } /*! \brief bind indicant tags to the symbol table \param p position in tree **/ static void bind_indicant_tag_to_symbol_table (NODE_T * p) { for (; p != NO_NODE; FORWARD (p)) { bind_indicant_tag_to_symbol_table (SUB (p)); if (is_one_of (p, INDICANT, DEFINING_INDICANT, STOP)) { TAG_T *z = find_tag_global (TABLE (p), INDICANT, NSYMBOL (p)); if (z != NO_TAG) { MOID (p) = MOID (z); TAX (p) = z; if (IS (p, DEFINING_INDICANT)) { NODE (z) = p; } } } } } /*! \brief enter specifier identifiers in the symbol table \param p position in tree **/ static void tax_specifiers (NODE_T * p) { for (; p != NO_NODE; FORWARD (p)) { tax_specifiers (SUB (p)); if (SUB (p) != NO_NODE && IS (p, SPECIFIER)) { tax_specifier_list (SUB (p)); } } } /*! \brief enter specifier identifiers in the symbol table \param p position in tree **/ static void tax_specifier_list (NODE_T * p) { if (p != NO_NODE) { if (IS (p, OPEN_SYMBOL)) { tax_specifier_list (NEXT (p)); } else if (is_one_of (p, CLOSE_SYMBOL, VOID_SYMBOL, STOP)) { ; } else if (IS (p, IDENTIFIER)) { TAG_T *z = add_tag (TABLE (p), IDENTIFIER, p, NO_MOID, SPECIFIER_IDENTIFIER); HEAP (z) = LOC_SYMBOL; } else if (IS (p, DECLARER)) { tax_specifiers (SUB (p)); tax_specifier_list (NEXT (p)); /* last identifier entry is identifier with this declarer */ if (IDENTIFIERS (TABLE (p)) != NO_TAG && PRIO (IDENTIFIERS (TABLE (p))) == SPECIFIER_IDENTIFIER) MOID (IDENTIFIERS (TABLE (p))) = MOID (p); } } } /*! \brief enter parameter identifiers in the symbol table \param p position in tree **/ static void tax_parameters (NODE_T * p) { for (; p != NO_NODE; FORWARD (p)) { if (SUB (p) != NO_NODE) { tax_parameters (SUB (p)); if (IS (p, PARAMETER_PACK)) { tax_parameter_list (SUB (p)); } } } } /*! \brief enter parameter identifiers in the symbol table \param p position in tree **/ static void tax_parameter_list (NODE_T * p) { if (p != NO_NODE) { if (is_one_of (p, OPEN_SYMBOL, COMMA_SYMBOL, STOP)) { tax_parameter_list (NEXT (p)); } else if (IS (p, CLOSE_SYMBOL)) { ; } else if (is_one_of (p, PARAMETER_LIST, PARAMETER, STOP)) { tax_parameter_list (NEXT (p)); tax_parameter_list (SUB (p)); } else if (IS (p, IDENTIFIER)) { /* parameters are always local */ HEAP (add_tag (TABLE (p), IDENTIFIER, p, NO_MOID, PARAMETER_IDENTIFIER)) = LOC_SYMBOL; } else if (IS (p, DECLARER)) { TAG_T *s; tax_parameter_list (NEXT (p)); /* last identifier entries are identifiers with this declarer */ for (s = IDENTIFIERS (TABLE (p)); s != NO_TAG && MOID (s) == NO_MOID; FORWARD (s)) { MOID (s) = MOID (p); } tax_parameters (SUB (p)); } } } /*! \brief enter FOR identifiers in the symbol table \param p position in tree **/ static void tax_for_identifiers (NODE_T * p) { for (; p != NO_NODE; FORWARD (p)) { tax_for_identifiers (SUB (p)); if (IS (p, FOR_SYMBOL)) { if ((FORWARD (p)) != NO_NODE) { (void) add_tag (TABLE (p), IDENTIFIER, p, MODE (INT), LOOP_IDENTIFIER); } } } } /*! \brief enter routine texts in the symbol table \param p position in tree **/ static void tax_routine_texts (NODE_T * p) { for (; p != NO_NODE; FORWARD (p)) { tax_routine_texts (SUB (p)); if (IS (p, ROUTINE_TEXT)) { TAG_T *z = add_tag (TABLE (p), ANONYMOUS, p, MOID (p), ROUTINE_TEXT); TAX (p) = z; HEAP (z) = LOC_SYMBOL; USE (z) = A68_TRUE; } } } /*! \brief enter format texts in the symbol table \param p position in tree **/ static void tax_format_texts (NODE_T * p) { for (; p != NO_NODE; FORWARD (p)) { tax_format_texts (SUB (p)); if (IS (p, FORMAT_TEXT)) { TAG_T *z = add_tag (TABLE (p), ANONYMOUS, p, MODE (FORMAT), FORMAT_TEXT); TAX (p) = z; USE (z) = A68_TRUE; } else if (IS (p, FORMAT_DELIMITER_SYMBOL) && NEXT (p) != NO_NODE) { TAG_T *z = add_tag (TABLE (p), ANONYMOUS, p, MODE (FORMAT), FORMAT_IDENTIFIER); TAX (p) = z; USE (z) = A68_TRUE; } } } /*! \brief enter FORMAT pictures in the symbol table \param p position in tree **/ static void tax_pictures (NODE_T * p) { for (; p != NO_NODE; FORWARD (p)) { tax_pictures (SUB (p)); if (IS (p, PICTURE)) { TAX (p) = add_tag (TABLE (p), ANONYMOUS, p, MODE (COLLITEM), FORMAT_IDENTIFIER); } } } /*! \brief enter generators in the symbol table \param p position in tree **/ static void tax_generators (NODE_T * p) { for (; p != NO_NODE; FORWARD (p)) { tax_generators (SUB (p)); if (IS (p, GENERATOR)) { if (IS (SUB (p), LOC_SYMBOL)) { TAG_T *z = add_tag (TABLE (p), ANONYMOUS, p, SUB_MOID (SUB (p)), GENERATOR); HEAP (z) = LOC_SYMBOL; USE (z) = A68_TRUE; TAX (p) = z; } } } } /*! \brief find a firmly related operator for operands \param c symbol table \param n name of operator \param l left operand mode \param r right operand mode \param self own tag of "n", as to not relate to itself \return pointer to entry in table **/ static TAG_T *find_firmly_related_op (TABLE_T * c, char *n, MOID_T * l, MOID_T * r, TAG_T * self) { if (c != NO_TABLE) { TAG_T *s = OPERATORS (c); for (; s != NO_TAG; FORWARD (s)) { if (s != self && NSYMBOL (NODE (s)) == n) { PACK_T *t = PACK (MOID (s)); if (t != NO_PACK && is_firm (MOID (t), l)) { /* catch monadic operator */ if ((FORWARD (t)) == NO_PACK) { if (r == NO_MOID) { return (s); } } else { /* catch dyadic operator */ if (r != NO_MOID && is_firm (MOID (t), r)) { return (s); } } } } } } return (NO_TAG); } /*! \brief check for firmly related operators in this range \param p position in tree \param s operator tag to start from **/ static void test_firmly_related_ops_local (NODE_T * p, TAG_T * s) { if (s != NO_TAG) { PACK_T *u = PACK (MOID (s)); MOID_T *l = MOID (u); MOID_T *r = (NEXT (u) != NO_PACK ? MOID (NEXT (u)) : NO_MOID); TAG_T *t = find_firmly_related_op (TAG_TABLE (s), NSYMBOL (NODE (s)), l, r, s); if (t != NO_TAG) { if (TAG_TABLE (t) == a68g_standenv) { diagnostic_node (A68_ERROR, p, ERROR_OPERATOR_RELATED, MOID (s), NSYMBOL (NODE (s)), MOID (t), NSYMBOL (NODE (t))); ABEND (A68_TRUE, "standard environ error", NO_TEXT); } else { diagnostic_node (A68_ERROR, p, ERROR_OPERATOR_RELATED, MOID (s), NSYMBOL (NODE (s)), MOID (t), NSYMBOL (NODE (t))); } } if (NEXT (s) != NO_TAG) { test_firmly_related_ops_local ((p == NO_NODE ? NO_NODE : NODE (NEXT (s))), NEXT (s)); } } } /*! \brief find firmly related operators in this program \param p position in tree **/ static void test_firmly_related_ops (NODE_T * p) { for (; p != NO_NODE; FORWARD (p)) { if (SUB (p) != NO_NODE && is_new_lexical_level (p)) { TAG_T *oops = OPERATORS (TABLE (SUB (p))); if (oops != NO_TAG) { test_firmly_related_ops_local (NODE (oops), oops); } } test_firmly_related_ops (SUB (p)); } } /*! \brief driver for the processing of TAXes \param p position in tree **/ void collect_taxes (NODE_T * p) { tax_tags (p); tax_specifiers (p); tax_parameters (p); tax_for_identifiers (p); tax_routine_texts (p); tax_pictures (p); tax_format_texts (p); tax_generators (p); bind_identifier_tag_to_symbol_table (p); bind_indicant_tag_to_symbol_table (p); test_firmly_related_ops (p); test_firmly_related_ops_local (NO_NODE, OPERATORS (a68g_standenv)); } /*! \brief whether tag has already been declared in this range \param n name of tag \param a attribute of tag **/ static void already_declared (NODE_T * n, int a) { if (find_tag_local (TABLE (n), a, NSYMBOL (n)) != NO_TAG) { diagnostic_node (A68_ERROR, n, ERROR_MULTIPLE_TAG); } } /*! \brief whether tag has already been declared in this range \param n name of tag \param a attribute of tag **/ static void already_declared_hidden (NODE_T * n, int a) { TAG_T *s; if (find_tag_local (TABLE (n), a, NSYMBOL (n)) != NO_TAG) { diagnostic_node (A68_ERROR, n, ERROR_MULTIPLE_TAG); } if ((s = find_tag_global (PREVIOUS (TABLE (n)), a, NSYMBOL (n))) != NO_TAG) { if (TAG_TABLE (s) == a68g_standenv) { diagnostic_node (A68_WARNING, n, WARNING_HIDES_PRELUDE, MOID (s), NSYMBOL (n)); } else { diagnostic_node (A68_WARNING, n, WARNING_HIDES, NSYMBOL (n)); } } } /*! \brief add tag to local symbol table \param s table where to insert \param a attribute \param n name of tag \param m mode of tag \param p position in tree \return entry in symbol table **/ TAG_T *add_tag (TABLE_T * s, int a, NODE_T * n, MOID_T * m, int p) { #define INSERT_TAG(l, n) {NEXT (n) = *(l); *(l) = (n);} if (s != NO_TABLE) { TAG_T *z = new_tag (); TAG_TABLE (z) = s; PRIO (z) = p; MOID (z) = m; NODE (z) = n; /* TAX(n) = z; */ switch (a) { case IDENTIFIER:{ already_declared_hidden (n, IDENTIFIER); already_declared_hidden (n, LABEL); INSERT_TAG (&IDENTIFIERS (s), z); break; } case INDICANT:{ already_declared_hidden (n, INDICANT); already_declared (n, OP_SYMBOL); already_declared (n, PRIO_SYMBOL); INSERT_TAG (&INDICANTS (s), z); break; } case LABEL:{ already_declared_hidden (n, LABEL); already_declared_hidden (n, IDENTIFIER); INSERT_TAG (&LABELS (s), z); break; } case OP_SYMBOL:{ already_declared (n, INDICANT); INSERT_TAG (&OPERATORS (s), z); break; } case PRIO_SYMBOL:{ already_declared (n, PRIO_SYMBOL); already_declared (n, INDICANT); INSERT_TAG (&PRIO (s), z); break; } case ANONYMOUS:{ INSERT_TAG (&ANONYMOUS (s), z); break; } default:{ ABEND (A68_TRUE, ERROR_INTERNAL_CONSISTENCY, "add tag"); } } return (z); } else { return (NO_TAG); } } /*! \brief find a tag, searching symbol tables towards the root \param table symbol table to search \param a attribute of tag \param name name of tag \return entry in symbol table **/ TAG_T *find_tag_global (TABLE_T * table, int a, char *name) { if (table != NO_TABLE) { TAG_T *s = NO_TAG; switch (a) { case IDENTIFIER:{ s = IDENTIFIERS (table); break; } case INDICANT:{ s = INDICANTS (table); break; } case LABEL:{ s = LABELS (table); break; } case OP_SYMBOL:{ s = OPERATORS (table); break; } case PRIO_SYMBOL:{ s = PRIO (table); break; } default:{ ABEND (A68_TRUE, "impossible state in find_tag_global", NO_TEXT); break; } } for (; s != NO_TAG; FORWARD (s)) { if (NSYMBOL (NODE (s)) == name) { return (s); } } return (find_tag_global (PREVIOUS (table), a, name)); } else { return (NO_TAG); } } /*! \brief whether identifier or label global \param table symbol table to search \param name name of tag \return attribute of tag **/ int is_identifier_or_label_global (TABLE_T * table, char *name) { if (table != NO_TABLE) { TAG_T *s; for (s = IDENTIFIERS (table); s != NO_TAG; FORWARD (s)) { if (NSYMBOL (NODE (s)) == name) { return (IDENTIFIER); } } for (s = LABELS (table); s != NO_TAG; FORWARD (s)) { if (NSYMBOL (NODE (s)) == name) { return (LABEL); } } return (is_identifier_or_label_global (PREVIOUS (table), name)); } else { return (0); } } /*! \brief find a tag, searching only local symbol table \param table symbol table to search \param a attribute of tag \param name name of tag \return entry in symbol table **/ TAG_T *find_tag_local (TABLE_T * table, int a, char *name) { if (table != NO_TABLE) { TAG_T *s = NO_TAG; if (a == OP_SYMBOL) { s = OPERATORS (table); } else if (a == PRIO_SYMBOL) { s = PRIO (table); } else if (a == IDENTIFIER) { s = IDENTIFIERS (table); } else if (a == INDICANT) { s = INDICANTS (table); } else if (a == LABEL) { s = LABELS (table); } else { ABEND (A68_TRUE, "impossible state in find_tag_local", NO_TEXT); } for (; s != NO_TAG; FORWARD (s)) { if (NSYMBOL (NODE (s)) == name) { return (s); } } } return (NO_TAG); } /*! \brief whether context specifies HEAP or LOC for an identifier \param p position in tree \return attribute of generator **/ static int tab_qualifier (NODE_T * p) { if (p != NO_NODE) { if (is_one_of (p, UNIT, ASSIGNATION, TERTIARY, SECONDARY, GENERATOR, STOP)) { return (tab_qualifier (SUB (p))); } else if (is_one_of (p, LOC_SYMBOL, HEAP_SYMBOL, NEW_SYMBOL, STOP)) { return (ATTRIBUTE (p) == LOC_SYMBOL ? LOC_SYMBOL : HEAP_SYMBOL); } else { return (LOC_SYMBOL); } } else { return (LOC_SYMBOL); } } /*! \brief enter identity declarations in the symbol table \param p position in tree \param m mode of identifiers to enter (picked from the left-most one in fi. INT i = 1, j = 2) **/ static void tax_identity_dec (NODE_T * p, MOID_T ** m) { if (p != NO_NODE) { if (IS (p, IDENTITY_DECLARATION)) { tax_identity_dec (SUB (p), m); tax_identity_dec (NEXT (p), m); } else if (IS (p, DECLARER)) { tax_tags (SUB (p)); *m = MOID (p); tax_identity_dec (NEXT (p), m); } else if (IS (p, COMMA_SYMBOL)) { tax_identity_dec (NEXT (p), m); } else if (IS (p, DEFINING_IDENTIFIER)) { TAG_T *entry = find_tag_local (TABLE (p), IDENTIFIER, NSYMBOL (p)); MOID (p) = *m; HEAP (entry) = LOC_SYMBOL; TAX (p) = entry; MOID (entry) = *m; if (ATTRIBUTE (*m) == REF_SYMBOL) { HEAP (entry) = tab_qualifier (NEXT_NEXT (p)); } tax_identity_dec (NEXT_NEXT (p), m); } else { tax_tags (p); } } } /*! \brief enter variable declarations in the symbol table \param p position in tree \param q qualifier of generator (HEAP, LOC) picked from left-most identifier \param m mode of identifiers to enter (picked from the left-most one in fi. INT i, j, k) **/ static void tax_variable_dec (NODE_T * p, int *q, MOID_T ** m) { if (p != NO_NODE) { if (IS (p, VARIABLE_DECLARATION)) { tax_variable_dec (SUB (p), q, m); tax_variable_dec (NEXT (p), q, m); } else if (IS (p, DECLARER)) { tax_tags (SUB (p)); *m = MOID (p); tax_variable_dec (NEXT (p), q, m); } else if (IS (p, QUALIFIER)) { *q = ATTRIBUTE (SUB (p)); tax_variable_dec (NEXT (p), q, m); } else if (IS (p, COMMA_SYMBOL)) { tax_variable_dec (NEXT (p), q, m); } else if (IS (p, DEFINING_IDENTIFIER)) { TAG_T *entry = find_tag_local (TABLE (p), IDENTIFIER, NSYMBOL (p)); MOID (p) = *m; TAX (p) = entry; HEAP (entry) = *q; if (*q == LOC_SYMBOL) { TAG_T *z = add_tag (TABLE (p), ANONYMOUS, p, SUB (*m), GENERATOR); HEAP (z) = LOC_SYMBOL; USE (z) = A68_TRUE; BODY (entry) = z; } else { BODY (entry) = NO_TAG; } MOID (entry) = *m; tax_variable_dec (NEXT (p), q, m); } else { tax_tags (p); } } } /*! \brief enter procedure variable declarations in the symbol table \param p position in tree \param q qualifier of generator (HEAP, LOC) picked from left-most identifier **/ static void tax_proc_variable_dec (NODE_T * p, int *q) { if (p != NO_NODE) { if (IS (p, PROCEDURE_VARIABLE_DECLARATION)) { tax_proc_variable_dec (SUB (p), q); tax_proc_variable_dec (NEXT (p), q); } else if (IS (p, QUALIFIER)) { *q = ATTRIBUTE (SUB (p)); tax_proc_variable_dec (NEXT (p), q); } else if (is_one_of (p, PROC_SYMBOL, COMMA_SYMBOL, STOP)) { tax_proc_variable_dec (NEXT (p), q); } else if (IS (p, DEFINING_IDENTIFIER)) { TAG_T *entry = find_tag_local (TABLE (p), IDENTIFIER, NSYMBOL (p)); TAX (p) = entry; HEAP (entry) = *q; MOID (entry) = MOID (p); if (*q == LOC_SYMBOL) { TAG_T *z = add_tag (TABLE (p), ANONYMOUS, p, SUB_MOID (p), GENERATOR); HEAP (z) = LOC_SYMBOL; USE (z) = A68_TRUE; BODY (entry) = z; } else { BODY (entry) = NO_TAG; } tax_proc_variable_dec (NEXT (p), q); } else { tax_tags (p); } } } /*! \brief enter procedure declarations in the symbol table \param p position in tree **/ static void tax_proc_dec (NODE_T * p) { if (p != NO_NODE) { if (IS (p, PROCEDURE_DECLARATION)) { tax_proc_dec (SUB (p)); tax_proc_dec (NEXT (p)); } else if (is_one_of (p, PROC_SYMBOL, COMMA_SYMBOL, STOP)) { tax_proc_dec (NEXT (p)); } else if (IS (p, DEFINING_IDENTIFIER)) { TAG_T *entry = find_tag_local (TABLE (p), IDENTIFIER, NSYMBOL (p)); MOID_T *m = MOID (NEXT_NEXT (p)); MOID (p) = m; TAX (p) = entry; CODEX (entry) |= PROC_DECLARATION_MASK; HEAP (entry) = LOC_SYMBOL; MOID (entry) = m; tax_proc_dec (NEXT (p)); } else { tax_tags (p); } } } /*! \brief check validity of operator declaration \param p position in tree **/ static void check_operator_dec (NODE_T * p) { int k = 0; NODE_T *pack = SUB_SUB (NEXT_NEXT (p)); /* That's where the parameter pack is */ if (ATTRIBUTE (NEXT_NEXT (p)) != ROUTINE_TEXT) { pack = SUB (pack); } k = 1 + count_operands (pack); if (k < 1 && k > 2) { diagnostic_node (A68_SYNTAX_ERROR, p, ERROR_OPERAND_NUMBER); k = 0; } if (k == 1 && a68g_strchr (NOMADS, NSYMBOL (p)[0]) != NO_TEXT) { diagnostic_node (A68_SYNTAX_ERROR, p, ERROR_OPERATOR_INVALID, NOMADS); } else if (k == 2 && !find_tag_global (TABLE (p), PRIO_SYMBOL, NSYMBOL (p))) { diagnostic_node (A68_SYNTAX_ERROR, p, ERROR_DYADIC_PRIORITY); } } /*! \brief enter operator declarations in the symbol table \param p position in tree \param m mode of operators to enter (picked from the left-most one) **/ static void tax_op_dec (NODE_T * p, MOID_T ** m) { if (p != NO_NODE) { if (IS (p, OPERATOR_DECLARATION)) { tax_op_dec (SUB (p), m); tax_op_dec (NEXT (p), m); } else if (IS (p, OPERATOR_PLAN)) { tax_tags (SUB (p)); *m = MOID (p); tax_op_dec (NEXT (p), m); } else if (IS (p, OP_SYMBOL)) { tax_op_dec (NEXT (p), m); } else if (IS (p, COMMA_SYMBOL)) { tax_op_dec (NEXT (p), m); } else if (IS (p, DEFINING_OPERATOR)) { TAG_T *entry = OPERATORS (TABLE (p)); check_operator_dec (p); while (entry != NO_TAG && NODE (entry) != p) { FORWARD (entry); } MOID (p) = *m; TAX (p) = entry; HEAP (entry) = LOC_SYMBOL; MOID (entry) = *m; tax_op_dec (NEXT (p), m); } else { tax_tags (p); } } } /*! \brief enter brief operator declarations in the symbol table \param p position in tree **/ static void tax_brief_op_dec (NODE_T * p) { if (p != NO_NODE) { if (IS (p, BRIEF_OPERATOR_DECLARATION)) { tax_brief_op_dec (SUB (p)); tax_brief_op_dec (NEXT (p)); } else if (is_one_of (p, OP_SYMBOL, COMMA_SYMBOL, STOP)) { tax_brief_op_dec (NEXT (p)); } else if (IS (p, DEFINING_OPERATOR)) { TAG_T *entry = OPERATORS (TABLE (p)); MOID_T *m = MOID (NEXT_NEXT (p)); check_operator_dec (p); while (entry != NO_TAG && NODE (entry) != p) { FORWARD (entry); } MOID (p) = m; TAX (p) = entry; HEAP (entry) = LOC_SYMBOL; MOID (entry) = m; tax_brief_op_dec (NEXT (p)); } else { tax_tags (p); } } } /*! \brief enter priority declarations in the symbol table \param p position in tree **/ static void tax_prio_dec (NODE_T * p) { if (p != NO_NODE) { if (IS (p, PRIORITY_DECLARATION)) { tax_prio_dec (SUB (p)); tax_prio_dec (NEXT (p)); } else if (is_one_of (p, PRIO_SYMBOL, COMMA_SYMBOL, STOP)) { tax_prio_dec (NEXT (p)); } else if (IS (p, DEFINING_OPERATOR)) { TAG_T *entry = PRIO (TABLE (p)); while (entry != NO_TAG && NODE (entry) != p) { FORWARD (entry); } MOID (p) = NO_MOID; TAX (p) = entry; HEAP (entry) = LOC_SYMBOL; tax_prio_dec (NEXT (p)); } else { tax_tags (p); } } } /*! \brief enter TAXes in the symbol table \param p position in tree **/ static void tax_tags (NODE_T * p) { for (; p != NO_NODE; FORWARD (p)) { int heap = LOC_SYMBOL; MOID_T *m = NO_MOID; if (IS (p, IDENTITY_DECLARATION)) { tax_identity_dec (p, &m); } else if (IS (p, VARIABLE_DECLARATION)) { tax_variable_dec (p, &heap, &m); } else if (IS (p, PROCEDURE_DECLARATION)) { tax_proc_dec (p); } else if (IS (p, PROCEDURE_VARIABLE_DECLARATION)) { tax_proc_variable_dec (p, &heap); } else if (IS (p, OPERATOR_DECLARATION)) { tax_op_dec (p, &m); } else if (IS (p, BRIEF_OPERATOR_DECLARATION)) { tax_brief_op_dec (p); } else if (IS (p, PRIORITY_DECLARATION)) { tax_prio_dec (p); } else { tax_tags (SUB (p)); } } } /*! \brief reset symbol table nest count \param p position in tree **/ void reset_symbol_table_nest_count (NODE_T * p) { for (; p != NO_NODE; FORWARD (p)) { if (SUB (p) != NO_NODE && is_new_lexical_level (p)) { NEST (TABLE (SUB (p))) = symbol_table_count++; } reset_symbol_table_nest_count (SUB (p)); } } /*! \brief bind routines in symbol table to the tree \param p position in tree **/ void bind_routine_tags_to_tree (NODE_T * p) { /* By inserting coercions etc. some may have shifted */ for (; p != NO_NODE; FORWARD (p)) { if (IS (p, ROUTINE_TEXT) && TAX (p) != NO_TAG) { NODE (TAX (p)) = p; } bind_routine_tags_to_tree (SUB (p)); } } /*! \brief bind formats in symbol table to tree \param p position in tree **/ void bind_format_tags_to_tree (NODE_T * p) { /* By inserting coercions etc. some may have shifted */ for (; p != NO_NODE; FORWARD (p)) { if (IS (p, FORMAT_TEXT) && TAX (p) != NO_TAG) { NODE (TAX (p)) = p; } else if (IS (p, FORMAT_DELIMITER_SYMBOL) && NEXT (p) != NO_NODE && TAX (p) != NO_TAG) { NODE (TAX (p)) = p; } bind_format_tags_to_tree (SUB (p)); } } /*! \brief fill outer level of symbol table \param p position in tree \param s parent symbol table **/ void fill_symbol_table_outer (NODE_T * p, TABLE_T * s) { for (; p != NO_NODE; FORWARD (p)) { if (TABLE (p) != NO_TABLE) { OUTER (TABLE (p)) = s; } if (SUB (p) != NO_NODE && IS (p, ROUTINE_TEXT)) { fill_symbol_table_outer (SUB (p), TABLE (SUB (p))); } else if (SUB (p) != NO_NODE && IS (p, FORMAT_TEXT)) { fill_symbol_table_outer (SUB (p), TABLE (SUB (p))); } else { fill_symbol_table_outer (SUB (p), s); } } } /*! \brief flood branch in tree with local symbol table "s" \param p position in tree \param s parent symbol table **/ static void flood_with_symbol_table_restricted (NODE_T * p, TABLE_T * s) { for (; p != NO_NODE; FORWARD (p)) { TABLE (p) = s; if (ATTRIBUTE (p) != ROUTINE_TEXT && ATTRIBUTE (p) != SPECIFIED_UNIT) { if (is_new_lexical_level (p)) { PREVIOUS (TABLE (SUB (p))) = s; } else { flood_with_symbol_table_restricted (SUB (p), s); } } } } /*! \brief final structure of symbol table after parsing \param p position in tree \param l current lexical level **/ void finalise_symbol_table_setup (NODE_T * p, int l) { TABLE_T *s = TABLE (p); NODE_T *q = p; while (q != NO_NODE) { /* routine texts are ranges */ if (IS (q, ROUTINE_TEXT)) { flood_with_symbol_table_restricted (SUB (q), new_symbol_table (s)); } /* specifiers are ranges */ else if (IS (q, SPECIFIED_UNIT)) { flood_with_symbol_table_restricted (SUB (q), new_symbol_table (s)); } /* level count and recursion */ if (SUB (q) != NO_NODE) { if (is_new_lexical_level (q)) { LEX_LEVEL (SUB (q)) = l + 1; PREVIOUS (TABLE (SUB (q))) = s; finalise_symbol_table_setup (SUB (q), l + 1); if (IS (q, WHILE_PART)) { /* This was a bug that went unnoticed for 15 years! */ TABLE_T *s2 = TABLE (SUB (q)); if ((FORWARD (q)) == NO_NODE) { return; } if (IS (q, ALT_DO_PART)) { PREVIOUS (TABLE (SUB (q))) = s2; LEX_LEVEL (SUB (q)) = l + 2; finalise_symbol_table_setup (SUB (q), l + 2); } } } else { TABLE (SUB (q)) = s; finalise_symbol_table_setup (SUB (q), l); } } TABLE (q) = s; if (IS (q, FOR_SYMBOL)) { FORWARD (q); } FORWARD (q); } /* FOR identifiers are in the DO ... OD range */ for (q = p; q != NO_NODE; FORWARD (q)) { if (IS (q, FOR_SYMBOL)) { TABLE (NEXT (q)) = TABLE (SEQUENCE (NEXT (q))); } } } /*! \brief first structure of symbol table for parsing \param p position in tree **/ void preliminary_symbol_table_setup (NODE_T * p) { NODE_T *q; TABLE_T *s = TABLE (p); BOOL_T not_a_for_range = A68_FALSE; /* let the tree point to the current symbol table */ for (q = p; q != NO_NODE; FORWARD (q)) { TABLE (q) = s; } /* insert new tables when required */ for (q = p; q != NO_NODE && !not_a_for_range; FORWARD (q)) { if (SUB (q) != NO_NODE) { /* BEGIN ... END, CODE ... EDOC, DEF ... FED, DO ... OD, $ ... $, { ... } are ranges */ if (is_one_of (q, BEGIN_SYMBOL, DO_SYMBOL, ALT_DO_SYMBOL, FORMAT_DELIMITER_SYMBOL, ACCO_SYMBOL, STOP)) { TABLE (SUB (q)) = new_symbol_table (s); preliminary_symbol_table_setup (SUB (q)); } /* ( ... ) is a range */ else if (IS (q, OPEN_SYMBOL)) { if (whether (q, OPEN_SYMBOL, THEN_BAR_SYMBOL, STOP)) { TABLE (SUB (q)) = s; preliminary_symbol_table_setup (SUB (q)); FORWARD (q); TABLE (SUB (q)) = new_symbol_table (s); preliminary_symbol_table_setup (SUB (q)); if ((FORWARD (q)) == NO_NODE) { not_a_for_range = A68_TRUE; } else { if (IS (q, THEN_BAR_SYMBOL)) { TABLE (SUB (q)) = new_symbol_table (s); preliminary_symbol_table_setup (SUB (q)); } if (IS (q, OPEN_SYMBOL)) { TABLE (SUB (q)) = new_symbol_table (s); preliminary_symbol_table_setup (SUB (q)); } } } else { /* don't worry about STRUCT (...), UNION (...), PROC (...) yet */ TABLE (SUB (q)) = new_symbol_table (s); preliminary_symbol_table_setup (SUB (q)); } } /* IF ... THEN ... ELSE ... FI are ranges */ else if (IS (q, IF_SYMBOL)) { if (whether (q, IF_SYMBOL, THEN_SYMBOL, STOP)) { TABLE (SUB (q)) = s; preliminary_symbol_table_setup (SUB (q)); FORWARD (q); TABLE (SUB (q)) = new_symbol_table (s); preliminary_symbol_table_setup (SUB (q)); if ((FORWARD (q)) == NO_NODE) { not_a_for_range = A68_TRUE; } else { if (IS (q, ELSE_SYMBOL)) { TABLE (SUB (q)) = new_symbol_table (s); preliminary_symbol_table_setup (SUB (q)); } if (IS (q, IF_SYMBOL)) { TABLE (SUB (q)) = new_symbol_table (s); preliminary_symbol_table_setup (SUB (q)); } } } else { TABLE (SUB (q)) = new_symbol_table (s); preliminary_symbol_table_setup (SUB (q)); } } /* CASE ... IN ... OUT ... ESAC are ranges */ else if (IS (q, CASE_SYMBOL)) { if (whether (q, CASE_SYMBOL, IN_SYMBOL, STOP)) { TABLE (SUB (q)) = s; preliminary_symbol_table_setup (SUB (q)); FORWARD (q); TABLE (SUB (q)) = new_symbol_table (s); preliminary_symbol_table_setup (SUB (q)); if ((FORWARD (q)) == NO_NODE) { not_a_for_range = A68_TRUE; } else { if (IS (q, OUT_SYMBOL)) { TABLE (SUB (q)) = new_symbol_table (s); preliminary_symbol_table_setup (SUB (q)); } if (IS (q, CASE_SYMBOL)) { TABLE (SUB (q)) = new_symbol_table (s); preliminary_symbol_table_setup (SUB (q)); } } } else { TABLE (SUB (q)) = new_symbol_table (s); preliminary_symbol_table_setup (SUB (q)); } } /* UNTIL ... OD is a range */ else if (IS (q, UNTIL_SYMBOL) && SUB (q) != NO_NODE) { TABLE (SUB (q)) = new_symbol_table (s); preliminary_symbol_table_setup (SUB (q)); /* WHILE ... DO ... OD are ranges */ } else if (IS (q, WHILE_SYMBOL)) { TABLE_T *u = new_symbol_table (s); TABLE (SUB (q)) = u; preliminary_symbol_table_setup (SUB (q)); if ((FORWARD (q)) == NO_NODE) { not_a_for_range = A68_TRUE; } else if (IS (q, ALT_DO_SYMBOL)) { TABLE (SUB (q)) = new_symbol_table (u); preliminary_symbol_table_setup (SUB (q)); } } else { TABLE (SUB (q)) = s; preliminary_symbol_table_setup (SUB (q)); } } } /* FOR identifiers will go to the DO ... OD range */ if (!not_a_for_range) { for (q = p; q != NO_NODE; FORWARD (q)) { if (IS (q, FOR_SYMBOL)) { NODE_T *r = q; TABLE (NEXT (q)) = NO_TABLE; for (; r != NO_NODE && TABLE (NEXT (q)) == NO_TABLE; FORWARD (r)) { if ((is_one_of (r, WHILE_SYMBOL, ALT_DO_SYMBOL, STOP)) && (NEXT (q) != NO_NODE && SUB (r) != NO_NODE)) { TABLE (NEXT (q)) = TABLE (SUB (r)); SEQUENCE (NEXT (q)) = SUB (r); } } } } } } /*! \brief mark a mode as in use \param m mode to mark **/ static void mark_mode (MOID_T * m) { if (m != NO_MOID && USE (m) == A68_FALSE) { PACK_T *p = PACK (m); USE (m) = A68_TRUE; for (; p != NO_PACK; FORWARD (p)) { mark_mode (MOID (p)); mark_mode (SUB (m)); mark_mode (SLICE (m)); } } } /*! \brief traverse tree and mark modes as used \param p position in tree **/ void mark_moids (NODE_T * p) { for (; p != NO_NODE; FORWARD (p)) { mark_moids (SUB (p)); if (MOID (p) != NO_MOID) { mark_mode (MOID (p)); } } } /*! \brief mark various tags as used \param p position in tree **/ void mark_auxilliary (NODE_T * p) { for (; p != NO_NODE; FORWARD (p)) { if (SUB (p) != NO_NODE) { /* You get no warnings on unused PROC parameters. That is ok since A68 has some parameters that you may not use at all - think of PROC (REF FILE) BOOL event routines in transput. */ mark_auxilliary (SUB (p)); } else if (IS (p, OPERATOR)) { TAG_T *z; if (TAX (p) != NO_TAG) { USE (TAX (p)) = A68_TRUE; } if ((z = find_tag_global (TABLE (p), PRIO_SYMBOL, NSYMBOL (p))) != NO_TAG) { USE (z) = A68_TRUE; } } else if (IS (p, INDICANT)) { TAG_T *z = find_tag_global (TABLE (p), INDICANT, NSYMBOL (p)); if (z != NO_TAG) { TAX (p) = z; USE (z) = A68_TRUE; } } else if (IS (p, IDENTIFIER)) { if (TAX (p) != NO_TAG) { USE (TAX (p)) = A68_TRUE; } } } } /*! \brief check a single tag \param s tag to check **/ static void unused (TAG_T * s) { for (; s != NO_TAG; FORWARD (s)) { if (LINE_NUMBER (NODE (s)) > 0 && !USE (s)) { diagnostic_node (A68_WARNING, NODE (s), WARNING_TAG_UNUSED, NODE (s)); } } } /*! \brief driver for traversing tree and warn for unused tags \param p position in tree **/ void warn_for_unused_tags (NODE_T * p) { for (; p != NO_NODE; FORWARD (p)) { if (SUB (p) != NO_NODE) { if (is_new_lexical_level (p) && ATTRIBUTE (TABLE (SUB (p))) != ENVIRON_SYMBOL) { unused (OPERATORS (TABLE (SUB (p)))); unused (PRIO (TABLE (SUB (p)))); unused (IDENTIFIERS (TABLE (SUB (p)))); unused (LABELS (TABLE (SUB (p)))); unused (INDICANTS (TABLE (SUB (p)))); } } warn_for_unused_tags (SUB (p)); } } /*! \brief mark jumps and procedured jumps \param p position in tree **/ void jumps_from_procs (NODE_T * p) { for (; p != NO_NODE; FORWARD (p)) { if (IS (p, PROCEDURING)) { NODE_T *u = SUB_SUB (p); if (IS (u, GOTO_SYMBOL)) { FORWARD (u); } USE (TAX (u)) = A68_TRUE; } else if (IS (p, JUMP)) { NODE_T *u = SUB (p); if (IS (u, GOTO_SYMBOL)) { FORWARD (u); } if ((TAX (u) == NO_TAG) && (MOID (u) == NO_MOID) && (find_tag_global (TABLE (u), LABEL, NSYMBOL (u)) == NO_TAG)) { (void) add_tag (TABLE (u), LABEL, u, NO_MOID, LOCAL_LABEL); diagnostic_node (A68_ERROR, u, ERROR_UNDECLARED_TAG); } else { USE (TAX (u)) = A68_TRUE; } } else { jumps_from_procs (SUB (p)); } } } /*! \brief assign offset tags \param t tag to start from \param base first (base) address \return end address **/ static ADDR_T assign_offset_tags (TAG_T * t, ADDR_T base) { ADDR_T sum = base; for (; t != NO_TAG; FORWARD (t)) { ABEND (MOID (t) == NO_MOID, "tag has no mode", NSYMBOL (NODE (t))); SIZE (t) = moid_size (MOID (t)); if (VALUE (t) == NO_TEXT) { OFFSET (t) = sum; sum += SIZE (t); } } return (sum); } /*! \brief assign offsets table \param c symbol table **/ void assign_offsets_table (TABLE_T * c) { AP_INCREMENT (c) = assign_offset_tags (IDENTIFIERS (c), 0); AP_INCREMENT (c) = assign_offset_tags (OPERATORS (c), AP_INCREMENT (c)); AP_INCREMENT (c) = assign_offset_tags (ANONYMOUS (c), AP_INCREMENT (c)); AP_INCREMENT (c) = A68_ALIGN (AP_INCREMENT (c)); } /*! \brief assign offsets \param p position in tree **/ void assign_offsets (NODE_T * p) { for (; p != NO_NODE; FORWARD (p)) { if (SUB (p) != NO_NODE && is_new_lexical_level (p)) { assign_offsets_table (TABLE (SUB (p))); } assign_offsets (SUB (p)); } } /*! \brief assign offsets packs in moid list \param q moid to start from **/ void assign_offsets_packs (MOID_T * q) { for (; q != NO_MOID; FORWARD (q)) { if (EQUIVALENT (q) == NO_MOID && IS (q, STRUCT_SYMBOL)) { PACK_T *p = PACK (q); ADDR_T offset = 0; for (; p != NO_PACK; FORWARD (p)) { SIZE (p) = moid_size (MOID (p)); OFFSET (p) = offset; offset += SIZE (p); } } } } /**************************************/ /* MODE checker and coercion inserter */ /**************************************/ /*! \brief give accurate error message \param p mode 1 \param q mode 2 \param context context \param deflex deflexing regime \param depth depth of recursion \return error text **/ static char *mode_error_text (NODE_T * n, MOID_T * p, MOID_T * q, int context, int deflex, int depth) { #define TAIL(z) (&(z)[strlen (z)]) static char txt[BUFFER_SIZE]; if (depth == 1) { txt[0] = NULL_CHAR; } if (IS (p, SERIES_MODE)) { PACK_T *u = PACK (p); if (u == NO_PACK) { ASSERT (snprintf (txt, SNPRINTF_SIZE, "empty mode-list") >= 0); } else { for (; u != NO_PACK; FORWARD (u)) { if (MOID (u) != NO_MOID) { if (IS (MOID (u), SERIES_MODE)) { (void) mode_error_text (n, MOID (u), q, context, deflex, depth + 1); } else if (!is_coercible (MOID (u), q, context, deflex)) { int len = (int) strlen (txt); if (len > BUFFER_SIZE / 2) { ASSERT (snprintf (TAIL (txt), SNPRINTF_SIZE, " etcetera") >= 0); } else { if (strlen (txt) > 0) { ASSERT (snprintf (TAIL (txt), SNPRINTF_SIZE, " and ") >= 0); } ASSERT (snprintf (TAIL (txt), SNPRINTF_SIZE, "%s", moid_to_string (MOID (u), MOID_ERROR_WIDTH, n)) >= 0); } } } } } if (depth == 1) { ASSERT (snprintf (TAIL (txt), SNPRINTF_SIZE, " cannot be coerced to %s", moid_to_string (q, MOID_ERROR_WIDTH, n)) >= 0); } } else if (IS (p, STOWED_MODE) && IS (q, FLEX_SYMBOL)) { PACK_T *u = PACK (p); if (u == NO_PACK) { ASSERT (snprintf (txt, SNPRINTF_SIZE, "empty mode-list") >= 0); } else { for (; u != NO_PACK; FORWARD (u)) { if (!is_coercible (MOID (u), SLICE (SUB (q)), context, deflex)) { int len = (int) strlen (txt); if (len > BUFFER_SIZE / 2) { ASSERT (snprintf (TAIL (txt), SNPRINTF_SIZE, " etcetera") >= 0); } else { if (strlen (txt) > 0) { ASSERT (snprintf (TAIL (txt), SNPRINTF_SIZE, " and ") >= 0); } ASSERT (snprintf (TAIL (txt), SNPRINTF_SIZE, "%s", moid_to_string (MOID (u), MOID_ERROR_WIDTH, n)) >= 0); } } } ASSERT (snprintf (TAIL (txt), SNPRINTF_SIZE, " cannot be coerced to %s", moid_to_string (SLICE (SUB (q)), MOID_ERROR_WIDTH, n)) >= 0); } } else if (IS (p, STOWED_MODE) && IS (q, ROW_SYMBOL)) { PACK_T *u = PACK (p); if (u == NO_PACK) { ASSERT (snprintf (txt, SNPRINTF_SIZE, "empty mode-list") >= 0); } else { for (; u != NO_PACK; FORWARD (u)) { if (!is_coercible (MOID (u), SLICE (q), context, deflex)) { int len = (int) strlen (txt); if (len > BUFFER_SIZE / 2) { ASSERT (snprintf (TAIL (txt), SNPRINTF_SIZE, " etcetera") >= 0); } else { if (strlen (txt) > 0) { ASSERT (snprintf (TAIL (txt), SNPRINTF_SIZE, " and ") >= 0); } ASSERT (snprintf (TAIL (txt), SNPRINTF_SIZE, "%s", moid_to_string (MOID (u), MOID_ERROR_WIDTH, n)) >= 0); } } } ASSERT (snprintf (TAIL (txt), SNPRINTF_SIZE, " cannot be coerced to %s", moid_to_string (SLICE (q), MOID_ERROR_WIDTH, n)) >= 0); } } else if (IS (p, STOWED_MODE) && (IS (q, PROC_SYMBOL) || IS (q, STRUCT_SYMBOL))) { PACK_T *u = PACK (p), *v = PACK (q); if (u == NO_PACK) { ASSERT (snprintf (txt, SNPRINTF_SIZE, "empty mode-list") >= 0); } else { for (; u != NO_PACK && v != NO_PACK; FORWARD (u), FORWARD (v)) { if (!is_coercible (MOID (u), MOID (v), context, deflex)) { int len = (int) strlen (txt); if (len > BUFFER_SIZE / 2) { ASSERT (snprintf (TAIL (txt), SNPRINTF_SIZE, " etcetera") >= 0); } else { if (strlen (txt) > 0) { ASSERT (snprintf (TAIL (txt), SNPRINTF_SIZE, " and ") >= 0); } ASSERT (snprintf (TAIL (txt), SNPRINTF_SIZE, "%s cannot be coerced to %s", moid_to_string (MOID (u), MOID_ERROR_WIDTH, n), moid_to_string (MOID (v), MOID_ERROR_WIDTH, n)) >= 0); } } } } } return (txt); #undef TAIL } /*! \brief cannot coerce error \param p position in tree \param from mode 1 \param to mode 2 \param context context \param deflex deflexing regime \param att attribute of context **/ static void cannot_coerce (NODE_T * p, MOID_T * from, MOID_T * to, int context, int deflex, int att) { char *txt = mode_error_text (p, from, to, context, deflex, 1); if (att == STOP) { if (strlen (txt) == 0) { diagnostic_node (A68_ERROR, p, "M cannot be coerced to M in C context", from, to, context); } else { diagnostic_node (A68_ERROR, p, "Y in C context", txt, context); } } else { if (strlen (txt) == 0) { diagnostic_node (A68_ERROR, p, "M cannot be coerced to M in C-A", from, to, context, att); } else { diagnostic_node (A68_ERROR, p, "Y in C-A", txt, context, att); } } } /*! \brief make SOID data structure \param s soid buffer \param sort sort \param type mode \param attribute attribute **/ static void make_soid (SOID_T * s, int sort, MOID_T * type, int attribute) { ATTRIBUTE (s) = attribute; SORT (s) = sort; MOID (s) = type; CAST (s) = A68_FALSE; } /*! \brief driver for mode checker \param p position in tree **/ void mode_checker (NODE_T * p) { if (IS (p, PARTICULAR_PROGRAM)) { SOID_T x, y; top_soid_list = NO_SOID; make_soid (&x, STRONG, MODE (VOID), 0); mode_check_enclosed (SUB (p), &x, &y); MOID (p) = MOID (&y); } } /*! \brief driver for coercion inserions \param p position in tree **/ void coercion_inserter (NODE_T * p) { if (IS (p, PARTICULAR_PROGRAM)) { SOID_T q; make_soid (&q, STRONG, MODE (VOID), 0); coerce_enclosed (SUB (p), &q); } } /*! \brief whether mode is not well defined \param p mode \return same **/ static BOOL_T is_mode_isnt_well (MOID_T * p) { if (p == NO_MOID) { return (A68_TRUE); } else if (!IF_MODE_IS_WELL (p)) { return (A68_TRUE); } else if (PACK (p) != NO_PACK) { PACK_T *q = PACK (p); for (; q != NO_PACK; FORWARD (q)) { if (!IF_MODE_IS_WELL (MOID (q))) { return (A68_TRUE); } } } return (A68_FALSE); } /*! \brief add SOID data to free chain \param root top soid list **/ void free_soid_list (SOID_T *root) { if (root != NO_SOID) { SOID_T *q; for (q = root; NEXT (q) != NO_SOID; FORWARD (q)) { /* skip */; } NEXT (q) = top_soid_list; top_soid_list = root; } } /*! \brief add SOID data structure to soid list \param root top soid list \param nwhere position in tree \param soid entry to add **/ static void add_to_soid_list (SOID_T ** root, NODE_T * where, SOID_T * soid) { if (*root != NO_SOID) { add_to_soid_list (&(NEXT (*root)), where, soid); } else { SOID_T *new_one; if (top_soid_list == NO_SOID) { new_one = (SOID_T *) get_temp_heap_space ((size_t) ALIGNED_SIZE_OF (SOID_T)); } else { new_one = top_soid_list; FORWARD (top_soid_list); } make_soid (new_one, SORT (soid), MOID (soid), 0); NODE (new_one) = where; NEXT (new_one) = NO_SOID; *root = new_one; } } /*! \brief pack soids in moid, gather resulting moids from terminators in a clause \param top_sl top soid list \param attribute mode attribute \return mode table entry **/ static MOID_T *pack_soids_in_moid (SOID_T * top_sl, int attribute) { MOID_T *x = new_moid (); PACK_T *t, **p; ATTRIBUTE (x) = attribute; DIM (x) = 0; SUB (x) = NO_MOID; EQUIVALENT (x) = NO_MOID; SLICE (x) = NO_MOID; DEFLEXED (x) = NO_MOID; NAME (x) = NO_MOID; NEXT (x) = NO_MOID; PACK (x) = NO_PACK; p = &(PACK (x)); for (; top_sl != NO_SOID; FORWARD (top_sl)) { t = new_pack (); MOID (t) = MOID (top_sl); TEXT (t) = NO_TEXT; NODE (t) = NODE (top_sl); NEXT (t) = NO_PACK; DIM (x)++; *p = t; p = &NEXT (t); } (void) register_extra_mode (&TOP_MOID (&program), x); return (x); } /*! \brief whether "p" is compatible with "q" \param p mode \param q mode \param deflex deflexing regime \return same **/ static BOOL_T is_equal_modes (MOID_T * p, MOID_T * q, int deflex) { if (deflex == FORCE_DEFLEXING) { return (DEFLEX (p) == DEFLEX (q)); } else if (deflex == ALIAS_DEFLEXING) { if (IS (p, REF_SYMBOL) && IS (q, REF_SYMBOL)) { return (p == q || DEFLEX (p) == q); } else if (ISNT (p, REF_SYMBOL) && ISNT (q, REF_SYMBOL)) { return (DEFLEX (p) == DEFLEX (q)); } } else if (deflex == SAFE_DEFLEXING) { if (ISNT (p, REF_SYMBOL) && ISNT (q, REF_SYMBOL)) { return (DEFLEX (p) == DEFLEX (q)); } } return (p == q); } /*! \brief whether mode is deprefable \param p mode \return same **/ BOOL_T is_deprefable (MOID_T * p) { if (IS (p, REF_SYMBOL)) { return (A68_TRUE); } else { return ((BOOL_T) (IS (p, PROC_SYMBOL) && PACK (p) == NO_PACK)); } } /*! \brief depref mode once \param p mode \return single-depreffed mode **/ static MOID_T *depref_once (MOID_T * p) { if (IS_REF_FLEX (p)) { return (SUB_SUB (p)); } else if (IS (p, REF_SYMBOL)) { return (SUB (p)); } else if (IS (p, PROC_SYMBOL) && PACK (p) == NO_PACK) { return (SUB (p)); } else { return (NO_MOID); } } /*! \brief depref mode completely \param p mode \return completely depreffed mode **/ MOID_T *depref_completely (MOID_T * p) { while (is_deprefable (p)) { p = depref_once (p); } return (p); } /*! \brief deproc_completely \param p mode \return completely deprocedured mode **/ static MOID_T *deproc_completely (MOID_T * p) { while (IS (p, PROC_SYMBOL) && PACK (p) == NO_PACK) { p = depref_once (p); } return (p); } /*! \brief depref rows \param p mode \param q mode \return possibly depreffed mode **/ static MOID_T *depref_rows (MOID_T * p, MOID_T * q) { if (q == MODE (ROWS)) { while (is_deprefable (p)) { p = depref_once (p); } return (p); } else { return (q); } } /*! \brief derow mode, strip FLEX and BOUNDS \param p mode \return same **/ static MOID_T *derow (MOID_T * p) { if (IS (p, ROW_SYMBOL) || IS (p, FLEX_SYMBOL)) { return (derow (SUB (p))); } else { return (p); } } /*! \brief whether rows type \param p mode \return same **/ static BOOL_T is_rows_type (MOID_T * p) { switch (ATTRIBUTE (p)) { case ROW_SYMBOL: case FLEX_SYMBOL: { return (A68_TRUE); } case UNION_SYMBOL: { PACK_T *t = PACK (p); BOOL_T go_on = A68_TRUE; while (t != NO_PACK && go_on) { go_on &= is_rows_type (MOID (t)); FORWARD (t); } return (go_on); } default: { return (A68_FALSE); } } } /*! \brief whether mode is PROC (REF FILE) VOID or FORMAT \param p mode \return same **/ static BOOL_T is_proc_ref_file_void_or_format (MOID_T * p) { if (p == MODE (PROC_REF_FILE_VOID)) { return (A68_TRUE); } else if (p == MODE (FORMAT)) { return (A68_TRUE); } else { return (A68_FALSE); } } /*! \brief whether mode can be transput \param p mode \return same **/ static BOOL_T is_transput_mode (MOID_T * p, char rw) { if (p == MODE (INT)) { return (A68_TRUE); } else if (p == MODE (LONG_INT)) { return (A68_TRUE); } else if (p == MODE (LONGLONG_INT)) { return (A68_TRUE); } else if (p == MODE (REAL)) { return (A68_TRUE); } else if (p == MODE (LONG_REAL)) { return (A68_TRUE); } else if (p == MODE (LONGLONG_REAL)) { return (A68_TRUE); } else if (p == MODE (BOOL)) { return (A68_TRUE); } else if (p == MODE (CHAR)) { return (A68_TRUE); } else if (p == MODE (BITS)) { return (A68_TRUE); } else if (p == MODE (LONG_BITS)) { return (A68_TRUE); } else if (p == MODE (LONGLONG_BITS)) { return (A68_TRUE); } else if (p == MODE (COMPLEX)) { return (A68_TRUE); } else if (p == MODE (LONG_COMPLEX)) { return (A68_TRUE); } else if (p == MODE (LONGLONG_COMPLEX)) { return (A68_TRUE); } else if (p == MODE (ROW_CHAR)) { return (A68_TRUE); } else if (p == MODE (STRING)) { return (A68_TRUE); } else if (p == MODE (SOUND)) { return (A68_TRUE); } else if (IS (p, UNION_SYMBOL) || IS (p, STRUCT_SYMBOL)) { PACK_T *q = PACK (p); BOOL_T k = A68_TRUE; for (; q != NO_PACK && k; FORWARD (q)) { k = (BOOL_T) (k & (is_transput_mode (MOID (q), rw) || is_proc_ref_file_void_or_format (MOID (q)))); } return (k); } else if (IS (p, FLEX_SYMBOL)) { if (SUB (p) == MODE (ROW_CHAR)) { return (A68_TRUE); } else { return ((BOOL_T) (rw == 'w' ? is_transput_mode (SUB (p), rw) : A68_FALSE)); } } else if (IS (p, ROW_SYMBOL)) { return ((BOOL_T) (is_transput_mode (SUB (p), rw) || is_proc_ref_file_void_or_format (SUB (p)))); } else { return (A68_FALSE); } } /*! \brief whether mode is printable \param p mode \return same **/ static BOOL_T is_printable_mode (MOID_T * p) { if (is_proc_ref_file_void_or_format (p)) { return (A68_TRUE); } else { return (is_transput_mode (p, 'w')); } } /*! \brief whether mode is readable \param p mode \return same **/ static BOOL_T is_readable_mode (MOID_T * p) { if (is_proc_ref_file_void_or_format (p)) { return (A68_TRUE); } else { return ((BOOL_T) (IS (p, REF_SYMBOL) ? is_transput_mode (SUB (p), 'r') : A68_FALSE)); } } /*! \brief whether name struct \param p mode \return same **/ static BOOL_T is_name_struct (MOID_T * p) { return ((BOOL_T) (NAME (p) != NO_MOID ? IS (DEFLEX (SUB (p)), STRUCT_SYMBOL) : A68_FALSE)); } /*! \brief yield mode to unite to \param m mode \param u united mode \return same **/ MOID_T *unites_to (MOID_T * m, MOID_T * u) { /* Uniting U (m) */ MOID_T *v = NO_MOID; PACK_T *p; if (u == MODE (SIMPLIN) || u == MODE (SIMPLOUT)) { return (m); } for (p = PACK (u); p != NO_PACK; FORWARD (p)) { /* Prefer []->[] over []->FLEX [] */ if (m == MOID (p)) { v = MOID (p); } else if (v == NO_MOID && DEFLEX (m) == DEFLEX (MOID (p))) { v = MOID (p); } } return (v); } /*! \brief whether moid in pack \param u mode \param v pack \param deflex deflexing regime \return same **/ static BOOL_T is_moid_in_pack (MOID_T * u, PACK_T * v, int deflex) { for (; v != NO_PACK; FORWARD (v)) { if (is_equal_modes (u, MOID (v), deflex)) { return (A68_TRUE); } } return (A68_FALSE); } /*! \brief whether "p" is a subset of "q" \param p mode \param q mode \param deflex deflexing regime \return same **/ BOOL_T is_subset (MOID_T * p, MOID_T * q, int deflex) { PACK_T *u = PACK (p); BOOL_T j = A68_TRUE; for (; u != NO_PACK && j; FORWARD (u)) { j = (BOOL_T) (j && is_moid_in_pack (MOID (u), PACK (q), deflex)); } return (j); } /*! \brief whether "p" can be united to UNION "q" \param p mode \param q mode \param deflex deflexing regime \return same **/ BOOL_T is_unitable (MOID_T * p, MOID_T * q, int deflex) { if (IS (q, UNION_SYMBOL)) { if (IS (p, UNION_SYMBOL)) { return (is_subset (p, q, deflex)); } else { return (is_moid_in_pack (p, PACK (q), deflex)); } } return (A68_FALSE); } /*! \brief whether all or some components of "u" can be firmly coerced to a component mode of "v". \param u mode \param v mode \param all all coercible \param some some coercible **/ static void investigate_firm_relations (PACK_T * u, PACK_T * v, BOOL_T * all, BOOL_T * some) { *all = A68_TRUE; *some = A68_FALSE; for (; v != NO_PACK; FORWARD (v)) { PACK_T *w; BOOL_T k = A68_FALSE; for (w = u; w != NO_PACK; FORWARD (w)) { k |= is_coercible (MOID (w), MOID (v), FIRM, FORCE_DEFLEXING); } *some |= k; *all &= k; } } /*! \brief whether there is a soft path from "p" to "q" \param p mode \param q mode \param deflex deflexing regime \return same **/ static BOOL_T is_softly_coercible (MOID_T * p, MOID_T * q, int deflex) { if (is_equal_modes (p, q, deflex)) { return (A68_TRUE); } else if (IS (p, PROC_SYMBOL) && PACK (p) == NO_PACK) { return (is_softly_coercible (SUB (p), q, deflex)); } else { return (A68_FALSE); } } /*! \brief whether there is a weak path from "p" to "q" \param p mode \param q mode \param deflex deflexing regime \return same **/ static BOOL_T is_weakly_coercible (MOID_T * p, MOID_T * q, int deflex) { if (is_equal_modes (p, q, deflex)) { return (A68_TRUE); } else if (is_deprefable (p)) { return (is_weakly_coercible (depref_once (p), q, deflex)); } else { return (A68_FALSE); } } /*! \brief whether there is a meek path from "p" to "q" \param p mode \param q mode \param deflex deflexing regime \return same **/ static BOOL_T is_meekly_coercible (MOID_T * p, MOID_T * q, int deflex) { if (is_equal_modes (p, q, deflex)) { return (A68_TRUE); } else if (is_deprefable (p)) { return (is_meekly_coercible (depref_once (p), q, deflex)); } else { return (A68_FALSE); } } /*! \brief whether there is a firm path from "p" to "q" \param p mode \param q mode \param deflex deflexing regime \return same **/ static BOOL_T is_firmly_coercible (MOID_T * p, MOID_T * q, int deflex) { if (is_equal_modes (p, q, deflex)) { return (A68_TRUE); } else if (q == MODE (ROWS) && is_rows_type (p)) { return (A68_TRUE); } else if (is_unitable (p, q, deflex)) { return (A68_TRUE); } else if (is_deprefable (p)) { return (is_firmly_coercible (depref_once (p), q, deflex)); } else { return (A68_FALSE); } } /*! \brief whether "p" widens to "q" \param p mode \param q mode \return same **/ static MOID_T *widens_to (MOID_T * p, MOID_T * q) { if (p == MODE (INT)) { if (q == MODE (LONG_INT) || q == MODE (LONGLONG_INT) || q == MODE (LONG_REAL) || q == MODE (LONGLONG_REAL) || q == MODE (LONG_COMPLEX) || q == MODE (LONGLONG_COMPLEX)) { return (MODE (LONG_INT)); } else if (q == MODE (REAL) || q == MODE (COMPLEX)) { return (MODE (REAL)); } else { return (NO_MOID); } } else if (p == MODE (LONG_INT)) { if (q == MODE (LONGLONG_INT)) { return (MODE (LONGLONG_INT)); } else if (q == MODE (LONG_REAL) || q == MODE (LONGLONG_REAL) || q == MODE (LONG_COMPLEX) || q == MODE (LONGLONG_COMPLEX)) { return (MODE (LONG_REAL)); } else { return (NO_MOID); } } else if (p == MODE (LONGLONG_INT)) { if (q == MODE (LONGLONG_REAL) || q == MODE (LONGLONG_COMPLEX)) { return (MODE (LONGLONG_REAL)); } else { return (NO_MOID); } } else if (p == MODE (REAL)) { if (q == MODE (LONG_REAL) || q == MODE (LONGLONG_REAL) || q == MODE (LONG_COMPLEX) || q == MODE (LONGLONG_COMPLEX)) { return (MODE (LONG_REAL)); } else if (q == MODE (COMPLEX)) { return (MODE (COMPLEX)); } else { return (NO_MOID); } } else if (p == MODE (COMPLEX)) { if (q == MODE (LONG_COMPLEX) || q == MODE (LONGLONG_COMPLEX)) { return (MODE (LONG_COMPLEX)); } else { return (NO_MOID); } } else if (p == MODE (LONG_REAL)) { if (q == MODE (LONGLONG_REAL) || q == MODE (LONGLONG_COMPLEX)) { return (MODE (LONGLONG_REAL)); } else if (q == MODE (LONG_COMPLEX)) { return (MODE (LONG_COMPLEX)); } else { return (NO_MOID); } } else if (p == MODE (LONG_COMPLEX)) { if (q == MODE (LONGLONG_COMPLEX)) { return (MODE (LONGLONG_COMPLEX)); } else { return (NO_MOID); } } else if (p == MODE (LONGLONG_REAL)) { if (q == MODE (LONGLONG_COMPLEX)) { return (MODE (LONGLONG_COMPLEX)); } else { return (NO_MOID); } } else if (p == MODE (BITS)) { if (q == MODE (LONG_BITS) || q == MODE (LONGLONG_BITS)) { return (MODE (LONG_BITS)); } else if (q == MODE (ROW_BOOL)) { return (MODE (ROW_BOOL)); } else { return (NO_MOID); } } else if (p == MODE (LONG_BITS)) { if (q == MODE (LONGLONG_BITS)) { return (MODE (LONGLONG_BITS)); } else if (q == MODE (ROW_BOOL)) { return (MODE (ROW_BOOL)); } else { return (NO_MOID); } } else if (p == MODE (LONGLONG_BITS)) { if (q == MODE (ROW_BOOL)) { return (MODE (ROW_BOOL)); } else { return (NO_MOID); } } else if (p == MODE (BYTES) && q == MODE (ROW_CHAR)) { return (MODE (ROW_CHAR)); } else if (p == MODE (LONG_BYTES) && q == MODE (ROW_CHAR)) { return (MODE (ROW_CHAR)); } else { return (NO_MOID); } } /*! \brief whether "p" widens to "q" \param p mode \param q mode \return same **/ static BOOL_T is_widenable (MOID_T * p, MOID_T * q) { MOID_T *z = widens_to (p, q); if (z != NO_MOID) { return ((BOOL_T) (z == q ? A68_TRUE : is_widenable (z, q))); } else { return (A68_FALSE); } } /*! \brief whether "p" is a REF ROW \param p mode \return same **/ static BOOL_T is_ref_row (MOID_T * p) { return ((BOOL_T) (NAME (p) != NO_MOID ? IS (DEFLEX (SUB (p)), ROW_SYMBOL) : A68_FALSE)); } /*! \brief whether strong name \param p mode \param q mode \return same **/ static BOOL_T is_strong_name (MOID_T * p, MOID_T * q) { if (p == q) { return (A68_TRUE); } else if (is_ref_row (q)) { return (is_strong_name (p, NAME (q))); } else { return (A68_FALSE); } } /*! \brief whether strong slice \param p mode \param q mode \return same **/ static BOOL_T is_strong_slice (MOID_T * p, MOID_T * q) { if (p == q || is_widenable (p, q)) { return (A68_TRUE); } else if (SLICE (q) != NO_MOID) { return (is_strong_slice (p, SLICE (q))); } else if (IS (q, FLEX_SYMBOL)) { return (is_strong_slice (p, SUB (q))); } else if (is_ref_row (q)) { return (is_strong_name (p, q)); } else { return (A68_FALSE); } } /*! \brief whether strongly coercible \param p mode \param q mode \param deflex deflexing regime \return same **/ static BOOL_T is_strongly_coercible (MOID_T * p, MOID_T * q, int deflex) { /* Keep this sequence of statements */ if (is_equal_modes (p, q, deflex)) { return (A68_TRUE); } else if (q == MODE (VOID)) { return (A68_TRUE); } else if ((q == MODE (SIMPLIN) || q == MODE (ROW_SIMPLIN)) && is_readable_mode (p)) { return (A68_TRUE); } else if (q == MODE (ROWS) && is_rows_type (p)) { return (A68_TRUE); } else if (is_unitable (p, derow (q), deflex)) { return (A68_TRUE); } if (is_ref_row (q) && is_strong_name (p, q)) { return (A68_TRUE); } else if (SLICE (q) != NO_MOID && is_strong_slice (p, q)) { return (A68_TRUE); } else if (IS (q, FLEX_SYMBOL) && is_strong_slice (p, q)) { return (A68_TRUE); } else if (is_widenable (p, q)) { return (A68_TRUE); } else if (is_deprefable (p)) { return (is_strongly_coercible (depref_once (p), q, deflex)); } else if (q == MODE (SIMPLOUT) || q == MODE (ROW_SIMPLOUT)) { return (is_printable_mode (p)); } else { return (A68_FALSE); } } /*! \brief whether firm \param p mode \param q mode \return same **/ BOOL_T is_firm (MOID_T * p, MOID_T * q) { return ((BOOL_T) (is_firmly_coercible (p, q, SAFE_DEFLEXING) || is_firmly_coercible (q, p, SAFE_DEFLEXING))); } /*! \brief whether coercible stowed \param p mode \param q mode \param c context \param deflex deflexing regime \return same **/ static BOOL_T is_coercible_stowed (MOID_T * p, MOID_T * q, int c, int deflex) { if (c == STRONG) { if (q == MODE (VOID)) { return (A68_TRUE); } else if (IS (q, FLEX_SYMBOL)) { PACK_T *u = PACK (p); BOOL_T j = A68_TRUE; for (; u != NO_PACK && j; FORWARD (u)) { j &= is_coercible (MOID (u), SLICE (SUB (q)), c, deflex); } return (j); } else if (IS (q, ROW_SYMBOL)) { PACK_T *u = PACK (p); BOOL_T j = A68_TRUE; for (; u != NO_PACK && j; FORWARD (u)) { j &= is_coercible (MOID (u), SLICE (q), c, deflex); } return (j); } else if (IS (q, PROC_SYMBOL) || IS (q, STRUCT_SYMBOL)) { PACK_T *u = PACK (p), *v = PACK (q); if (DIM (p) != DIM (q)) { return (A68_FALSE); } else { BOOL_T j = A68_TRUE; while (u != NO_PACK && v != NO_PACK && j) { j &= is_coercible (MOID (u), MOID (v), c, deflex); FORWARD (u); FORWARD (v); } return (j); } } else { return (A68_FALSE); } } else { return (A68_FALSE); } } /*! \brief whether coercible series \param p mode \param q mode \param c context \param deflex deflexing regime \return same **/ static BOOL_T is_coercible_series (MOID_T * p, MOID_T * q, int c, int deflex) { if (c != STRONG) { return (A68_FALSE); } else if (p == NO_MOID || q == NO_MOID) { return (A68_FALSE); } else if (IS (p, SERIES_MODE) && PACK (p) == NO_PACK) { return (A68_FALSE); } else if (IS (q, SERIES_MODE) && PACK (q) == NO_PACK) { return (A68_FALSE); } else if (PACK (p) == NO_PACK) { return (is_coercible (p, q, c, deflex)); } else { PACK_T *u = PACK (p); BOOL_T j = A68_TRUE; for (; u != NO_PACK && j; FORWARD (u)) { if (MOID (u) != NO_MOID) { j &= is_coercible (MOID (u), q, c, deflex); } } return (j); } } /*! \brief basic coercions \param p mode \param q mode \param c context \param deflex deflexing regime \return same **/ static BOOL_T basic_coercions (MOID_T * p, MOID_T * q, int c, int deflex) { if (is_equal_modes (p, q, deflex)) { return (A68_TRUE); } else if (c == NO_SORT) { return ((BOOL_T) (p == q)); } else if (c == SOFT) { return (is_softly_coercible (p, q, deflex)); } else if (c == WEAK) { return (is_weakly_coercible (p, q, deflex)); } else if (c == MEEK) { return (is_meekly_coercible (p, q, deflex)); } else if (c == FIRM) { return (is_firmly_coercible (p, q, deflex)); } else if (c == STRONG) { return (is_strongly_coercible (p, q, deflex)); } else { return (A68_FALSE); } } /*! \brief whether "p" can be coerced to "q" in a "c" context \param p mode \param q mode \param c context \param deflex deflexing regime \return same **/ BOOL_T is_coercible (MOID_T * p, MOID_T * q, int c, int deflex) { if (is_mode_isnt_well (p) || is_mode_isnt_well (q)) { return (A68_TRUE); } else if (is_equal_modes (p, q, deflex)) { return (A68_TRUE); } else if (p == MODE (HIP)) { return (A68_TRUE); } else if (IS (p, STOWED_MODE)) { return (is_coercible_stowed (p, q, c, deflex)); } else if (IS (p, SERIES_MODE)) { return (is_coercible_series (p, q, c, deflex)); } else if (p == MODE (VACUUM) && IS (DEFLEX (q), ROW_SYMBOL)) { return (A68_TRUE); } else { return (basic_coercions (p, q, c, deflex)); } } /*! \brief whether coercible in context \param p soid \param q soid \param deflex deflexing regime \return same **/ static BOOL_T is_coercible_in_context (SOID_T * p, SOID_T * q, int deflex) { if (SORT (p) != SORT (q)) { return (A68_FALSE); } else if (MOID (p) == MOID (q)) { return (A68_TRUE); } else { return (is_coercible (MOID (p), MOID (q), SORT (q), deflex)); } } /*! \brief whether list "y" is balanced \param n position in tree \param y soid list \param sort sort \return same **/ static BOOL_T is_balanced (NODE_T * n, SOID_T * y, int sort) { if (sort == STRONG) { return (A68_TRUE); } else { BOOL_T k = A68_FALSE; for (; y != NO_SOID && !k; FORWARD (y)) { k = (BOOL_T) (ISNT (MOID (y), STOWED_MODE)); } if (k == A68_FALSE) { diagnostic_node (A68_ERROR, n, ERROR_NO_UNIQUE_MODE); } return (k); } } /*! \brief a moid from "m" to which all other members can be coerced \param m mode \param sort sort \param return_depreffed whether to depref \param deflex deflexing regime \return same **/ MOID_T *get_balanced_mode (MOID_T * m, int sort, BOOL_T return_depreffed, int deflex) { MOID_T *common = NO_MOID; if (m != NO_MOID && !is_mode_isnt_well (m) && IS (m, UNION_SYMBOL)) { int depref_level; BOOL_T go_on = A68_TRUE; /* Test for increasing depreffing */ for (depref_level = 0; go_on; depref_level++) { PACK_T *p; go_on = A68_FALSE; /* Test the whole pack */ for (p = PACK (m); p != NO_PACK; FORWARD (p)) { /* HIPs are not eligible of course */ if (MOID (p) != MODE (HIP)) { MOID_T *candidate = MOID (p); int k; /* Depref as far as allowed */ for (k = depref_level; k > 0 && is_deprefable (candidate); k--) { candidate = depref_once (candidate); } /* Only need testing if all allowed deprefs succeeded */ if (k == 0) { PACK_T *q; MOID_T *to = (return_depreffed ? depref_completely (candidate) : candidate); BOOL_T all_coercible = A68_TRUE; go_on = A68_TRUE; for (q = PACK (m); q != NO_PACK && all_coercible; FORWARD (q)) { MOID_T *from = MOID (q); if (p != q && from != to) { all_coercible &= is_coercible (from, to, sort, deflex); } } /* If the pack is coercible to the candidate, we mark the candidate. We continue searching for longest series of REF REF PROC REF . */ if (all_coercible) { MOID_T *mark = (return_depreffed ? MOID (p) : candidate); if (common == NO_MOID) { common = mark; } else if (IS (candidate, FLEX_SYMBOL) && DEFLEX (candidate) == common) { /* We prefer FLEX */ common = mark; } } } } }/* for */ }/* for */ } return (common == NO_MOID ? m : common); } /*! \brief whether we can search a common mode from a clause or not \param att attribute \return same **/ static BOOL_T clause_allows_balancing (int att) { switch (att) { case CLOSED_CLAUSE: case CONDITIONAL_CLAUSE: case CASE_CLAUSE: case SERIAL_CLAUSE: case CONFORMITY_CLAUSE: { return (A68_TRUE); } } return (A68_FALSE); } /*! \brief a unique mode from "z" \param z soid \param deflex deflexing regime \return same **/ static MOID_T *determine_unique_mode (SOID_T * z, int deflex) { if (z == NO_SOID) { return (NO_MOID); } else { MOID_T *x = MOID (z); if (is_mode_isnt_well (x)) { return (MODE (ERROR)); } x = make_united_mode (x); if (clause_allows_balancing (ATTRIBUTE (z))) { return (get_balanced_mode (x, STRONG, NO_DEPREF, deflex)); } else { return (x); } } } /*! \brief give a warning when a value is silently discarded \param p position in tree \param x soid \param y soid \param c context **/ static void warn_for_voiding (NODE_T * p, SOID_T * x, SOID_T * y, int c) { (void) c; if (CAST (x) == A68_FALSE) { if (MOID (x) == MODE (VOID) && MOID (y) != MODE (ERROR) && !(MOID (y) == MODE (VOID) || !is_nonproc (MOID (y)))) { if (IS (p, FORMULA)) { diagnostic_node (A68_WARNING | A68_FORCE_DIAGNOSTICS, p, WARNING_VOIDED, MOID (y)); } else { diagnostic_node (A68_WARNING, p, WARNING_VOIDED, MOID (y)); } } } } /*! \brief warn for things that are likely unintended \param p position in tree \param m moid \param c context \param u attribute **/ static void semantic_pitfall (NODE_T * p, MOID_T * m, int c, int u) { /* semantic_pitfall: warn for things that are likely unintended, for instance REF INT i := LOC INT := 0, which should probably be REF INT i = LOC INT := 0. */ if (IS (p, u)) { diagnostic_node (A68_WARNING, p, WARNING_UNINTENDED, MOID (p), u, m, c); } else if (is_one_of (p, UNIT, TERTIARY, SECONDARY, PRIMARY, STOP)) { semantic_pitfall (SUB (p), m, c, u); } } /*! \brief insert coercion "a" in the tree \param l position in tree \param a attribute \param m (coerced) moid **/ static void make_coercion (NODE_T * l, int a, MOID_T * m) { make_sub (l, l, a); MOID (l) = depref_rows (MOID (l), m); } /*! \brief make widening coercion \param n position in tree \param p mode \param q mode **/ static void make_widening_coercion (NODE_T * n, MOID_T * p, MOID_T * q) { MOID_T *z = widens_to (p, q); make_coercion (n, WIDENING, z); if (z != q) { make_widening_coercion (n, z, q); } } /*! \brief make ref rowing coercion \param n position in tree \param p mode \param q mode **/ static void make_ref_rowing_coercion (NODE_T * n, MOID_T * p, MOID_T * q) { if (DEFLEX (p) != DEFLEX (q)) { if (is_widenable (p, q)) { make_widening_coercion (n, p, q); } else if (is_ref_row (q)) { make_ref_rowing_coercion (n, p, NAME (q)); make_coercion (n, ROWING, q); } } } /*! \brief make rowing coercion \param n position in tree \param p mode \param q mode **/ static void make_rowing_coercion (NODE_T * n, MOID_T * p, MOID_T * q) { if (DEFLEX (p) != DEFLEX (q)) { if (is_widenable (p, q)) { make_widening_coercion (n, p, q); } else if (SLICE (q) != NO_MOID) { make_rowing_coercion (n, p, SLICE (q)); make_coercion (n, ROWING, q); } else if (IS (q, FLEX_SYMBOL)) { make_rowing_coercion (n, p, SUB (q)); } else if (is_ref_row (q)) { make_ref_rowing_coercion (n, p, q); } } } /*! \brief make uniting coercion \param n position in tree \param q mode **/ static void make_uniting_coercion (NODE_T * n, MOID_T * q) { make_coercion (n, UNITING, derow (q)); if (IS (q, ROW_SYMBOL) || IS (q, FLEX_SYMBOL)) { make_rowing_coercion (n, derow (q), q); } } /*! \brief make depreffing coercion \param n position in tree \param p mode \param q mode **/ static void make_depreffing_coercion (NODE_T * n, MOID_T * p, MOID_T * q) { if (DEFLEX (p) == DEFLEX (q)) { return; } else if (q == MODE (SIMPLOUT) && is_printable_mode (p)) { make_coercion (n, UNITING, q); } else if (q == MODE (ROW_SIMPLOUT) && is_printable_mode (p)) { make_coercion (n, UNITING, MODE (SIMPLOUT)); make_coercion (n, ROWING, MODE (ROW_SIMPLOUT)); } else if (q == MODE (SIMPLIN) && is_readable_mode (p)) { make_coercion (n, UNITING, q); } else if (q == MODE (ROW_SIMPLIN) && is_readable_mode (p)) { make_coercion (n, UNITING, MODE (SIMPLIN)); make_coercion (n, ROWING, MODE (ROW_SIMPLIN)); } else if (q == MODE (ROWS) && is_rows_type (p)) { make_coercion (n, UNITING, MODE (ROWS)); MOID (n) = MODE (ROWS); } else if (is_widenable (p, q)) { make_widening_coercion (n, p, q); } else if (is_unitable (p, derow (q), SAFE_DEFLEXING)) { make_uniting_coercion (n, q); } else if (is_ref_row (q) && is_strong_name (p, q)) { make_ref_rowing_coercion (n, p, q); } else if (SLICE (q) != NO_MOID && is_strong_slice (p, q)) { make_rowing_coercion (n, p, q); } else if (IS (q, FLEX_SYMBOL) && is_strong_slice (p, q)) { make_rowing_coercion (n, p, q); } else if (IS (p, REF_SYMBOL)) { MOID_T *r = depref_once (p); make_coercion (n, DEREFERENCING, r); make_depreffing_coercion (n, r, q); } else if (IS (p, PROC_SYMBOL) && PACK (p) == NO_PACK) { MOID_T *r = SUB (p); make_coercion (n, DEPROCEDURING, r); make_depreffing_coercion (n, r, q); } else if (p != q) { cannot_coerce (n, p, q, NO_SORT, SKIP_DEFLEXING, 0); } } /*! \brief whether p is a nonproc mode (that is voided directly) \param p mode \return same **/ static BOOL_T is_nonproc (MOID_T * p) { if (IS (p, PROC_SYMBOL) && PACK (p) == NO_PACK) { return (A68_FALSE); } else if (IS (p, REF_SYMBOL)) { return (is_nonproc (SUB (p))); } else { return (A68_TRUE); } } /*! \brief make_void: voiden in an appropriate way \param p position in tree \param q mode **/ static void make_void (NODE_T * p, MOID_T * q) { switch (ATTRIBUTE (p)) { case ASSIGNATION: case IDENTITY_RELATION: case GENERATOR: case CAST: case DENOTATION: { make_coercion (p, VOIDING, MODE (VOID)); return; } } /* MORFs are an involved case */ switch (ATTRIBUTE (p)) { case SELECTION: case SLICE: case ROUTINE_TEXT: case FORMULA: case CALL: case IDENTIFIER: { /* A nonproc moid value is eliminated directly */ if (is_nonproc (q)) { make_coercion (p, VOIDING, MODE (VOID)); return; } else { /* Descend the chain of e.g. REF PROC .. until a nonproc moid remains */ MOID_T *z = q; while (!is_nonproc (z)) { if (IS (z, REF_SYMBOL)) { make_coercion (p, DEREFERENCING, SUB (z)); } if (IS (z, PROC_SYMBOL) && NODE_PACK (p) == NO_PACK) { make_coercion (p, DEPROCEDURING, SUB (z)); } z = SUB (z); } if (z != MODE (VOID)) { make_coercion (p, VOIDING, MODE (VOID)); } return; } } } /* All other is voided straight away */ make_coercion (p, VOIDING, MODE (VOID)); } /*! \brief make strong coercion \param n position in tree \param p mode \param q mode **/ static void make_strong (NODE_T * n, MOID_T * p, MOID_T * q) { if (q == MODE (VOID) && p != MODE (VOID)) { make_void (n, p); } else { make_depreffing_coercion (n, p, q); } } /*! \brief mode check on bounds \param p position in tree **/ static void mode_check_bounds (NODE_T * p) { if (p == NO_NODE) { return; } else if (IS (p, UNIT)) { SOID_T x, y; make_soid (&x, STRONG, MODE (INT), 0); mode_check_unit (p, &x, &y); if (!is_coercible_in_context (&y, &x, SAFE_DEFLEXING)) { cannot_coerce (p, MOID (&y), MODE (INT), MEEK, SAFE_DEFLEXING, UNIT); } mode_check_bounds (NEXT (p)); } else { mode_check_bounds (SUB (p)); mode_check_bounds (NEXT (p)); } } /*! \brief mode check declarer \param p position in tree **/ static void mode_check_declarer (NODE_T * p) { if (p == NO_NODE) { return; } else if (IS (p, BOUNDS)) { mode_check_bounds (SUB (p)); mode_check_declarer (NEXT (p)); } else { mode_check_declarer (SUB (p)); mode_check_declarer (NEXT (p)); } } /*! \brief mode check identity declaration \param p position in tree **/ static void mode_check_identity_declaration (NODE_T * p) { if (p != NO_NODE) { switch (ATTRIBUTE (p)) { case DECLARER: { mode_check_declarer (SUB (p)); mode_check_identity_declaration (NEXT (p)); break; } case DEFINING_IDENTIFIER: { SOID_T x, y; make_soid (&x, STRONG, MOID (p), 0); mode_check_unit (NEXT_NEXT (p), &x, &y); if (!is_coercible_in_context (&y, &x, SAFE_DEFLEXING)) { cannot_coerce (NEXT_NEXT (p), MOID (&y), MOID (&x), STRONG, SAFE_DEFLEXING, UNIT); } else if (MOID (&x) != MOID (&y)) { /* Check for instance, REF INT i = LOC REF INT */ semantic_pitfall (NEXT_NEXT (p), MOID (&x), IDENTITY_DECLARATION, GENERATOR); } break; } default: { mode_check_identity_declaration (SUB (p)); mode_check_identity_declaration (NEXT (p)); break; } } } } /*! \brief mode check variable declaration \param p position in tree **/ static void mode_check_variable_declaration (NODE_T * p) { if (p != NO_NODE) { switch (ATTRIBUTE (p)) { case DECLARER: { mode_check_declarer (SUB (p)); mode_check_variable_declaration (NEXT (p)); break; } case DEFINING_IDENTIFIER: { if (whether (p, DEFINING_IDENTIFIER, ASSIGN_SYMBOL, UNIT, STOP)) { SOID_T x, y; make_soid (&x, STRONG, SUB_MOID (p), 0); mode_check_unit (NEXT_NEXT (p), &x, &y); if (!is_coercible_in_context (&y, &x, FORCE_DEFLEXING)) { cannot_coerce (p, MOID (&y), MOID (&x), STRONG, FORCE_DEFLEXING, UNIT); } else if (SUB_MOID (&x) != MOID (&y)) { /* Check for instance, REF INT i = LOC REF INT */ semantic_pitfall (NEXT_NEXT (p), MOID (&x), VARIABLE_DECLARATION, GENERATOR); } } break; } default: { mode_check_variable_declaration (SUB (p)); mode_check_variable_declaration (NEXT (p)); break; } } } } /*! \brief mode check routine text \param p position in tree \param y resulting soid **/ static void mode_check_routine_text (NODE_T * p, SOID_T * y) { SOID_T w; if (IS (p, PARAMETER_PACK)) { mode_check_declarer (SUB (p)); FORWARD (p); } mode_check_declarer (SUB (p)); make_soid (&w, STRONG, MOID (p), 0); mode_check_unit (NEXT_NEXT (p), &w, y); if (!is_coercible_in_context (y, &w, FORCE_DEFLEXING)) { cannot_coerce (NEXT_NEXT (p), MOID (y), MOID (&w), STRONG, FORCE_DEFLEXING, UNIT); } } /*! \brief mode check proc declaration \param p position in tree **/ static void mode_check_proc_declaration (NODE_T * p) { if (p == NO_NODE) { return; } else if (IS (p, ROUTINE_TEXT)) { SOID_T x, y; make_soid (&x, STRONG, NO_MOID, 0); mode_check_routine_text (SUB (p), &y); } else { mode_check_proc_declaration (SUB (p)); mode_check_proc_declaration (NEXT (p)); } } /*! \brief mode check brief op declaration \param p position in tree **/ static void mode_check_brief_op_declaration (NODE_T * p) { if (p == NO_NODE) { return; } else if (IS (p, DEFINING_OPERATOR)) { SOID_T y; if (MOID (p) != MOID (NEXT_NEXT (p))) { SOID_T y2, x; make_soid (&y2, NO_SORT, MOID (NEXT_NEXT (p)), 0); make_soid (&x, NO_SORT, MOID (p), 0); cannot_coerce (NEXT_NEXT (p), MOID (&y2), MOID (&x), STRONG, SKIP_DEFLEXING, ROUTINE_TEXT); } mode_check_routine_text (SUB (NEXT_NEXT (p)), &y); } else { mode_check_brief_op_declaration (SUB (p)); mode_check_brief_op_declaration (NEXT (p)); } } /*! \brief mode check op declaration \param p position in tree **/ static void mode_check_op_declaration (NODE_T * p) { if (p == NO_NODE) { return; } else if (IS (p, DEFINING_OPERATOR)) { SOID_T y, x; make_soid (&x, STRONG, MOID (p), 0); mode_check_unit (NEXT_NEXT (p), &x, &y); if (!is_coercible_in_context (&y, &x, SAFE_DEFLEXING)) { cannot_coerce (NEXT_NEXT (p), MOID (&y), MOID (&x), STRONG, SAFE_DEFLEXING, UNIT); } } else { mode_check_op_declaration (SUB (p)); mode_check_op_declaration (NEXT (p)); } } /*! \brief mode check declaration list \param p position in tree **/ static void mode_check_declaration_list (NODE_T * p) { if (p != NO_NODE) { switch (ATTRIBUTE (p)) { case IDENTITY_DECLARATION: { mode_check_identity_declaration (SUB (p)); break; } case VARIABLE_DECLARATION: { mode_check_variable_declaration (SUB (p)); break; } case MODE_DECLARATION: { mode_check_declarer (SUB (p)); break; } case PROCEDURE_DECLARATION: case PROCEDURE_VARIABLE_DECLARATION: { mode_check_proc_declaration (SUB (p)); break; } case BRIEF_OPERATOR_DECLARATION: { mode_check_brief_op_declaration (SUB (p)); break; } case OPERATOR_DECLARATION: { mode_check_op_declaration (SUB (p)); break; } default: { mode_check_declaration_list (SUB (p)); mode_check_declaration_list (NEXT (p)); break; } } } } /*! \brief mode check serial clause \param r resulting soids \param p position in tree \param x expected soid \param k whether statement yields a value other than VOID **/ static void mode_check_serial (SOID_T ** r, NODE_T * p, SOID_T * x, BOOL_T k) { if (p == NO_NODE) { return; } else if (IS (p, INITIALISER_SERIES)) { mode_check_serial (r, SUB (p), x, A68_FALSE); mode_check_serial (r, NEXT (p), x, k); } else if (IS (p, DECLARATION_LIST)) { mode_check_declaration_list (SUB (p)); } else if (is_one_of (p, LABEL, SEMI_SYMBOL, EXIT_SYMBOL, STOP)) { mode_check_serial (r, NEXT (p), x, k); } else if (is_one_of (p, SERIAL_CLAUSE, ENQUIRY_CLAUSE, STOP)) { if (NEXT (p) != NO_NODE) { if (IS (NEXT (p), EXIT_SYMBOL) || IS (NEXT (p), END_SYMBOL) || IS (NEXT (p), CLOSE_SYMBOL)) { mode_check_serial (r, SUB (p), x, A68_TRUE); } else { mode_check_serial (r, SUB (p), x, A68_FALSE); } mode_check_serial (r, NEXT (p), x, k); } else { mode_check_serial (r, SUB (p), x, A68_TRUE); } } else if (IS (p, LABELED_UNIT)) { mode_check_serial (r, SUB (p), x, k); } else if (IS (p, UNIT)) { SOID_T y; if (k) { mode_check_unit (p, x, &y); } else { SOID_T w; make_soid (&w, STRONG, MODE (VOID), 0); mode_check_unit (p, &w, &y); } if (NEXT (p) != NO_NODE) { mode_check_serial (r, NEXT (p), x, k); } else { if (k) { add_to_soid_list (r, p, &y); } } } } /*! \brief mode check serial clause units \param p position in tree \param x expected soid \param y resulting soid \param att attribute (SERIAL or ENQUIRY) **/ static void mode_check_serial_units (NODE_T * p, SOID_T * x, SOID_T * y, int att) { SOID_T *top_sl = NO_SOID; (void) att; mode_check_serial (&top_sl, SUB (p), x, A68_TRUE); if (is_balanced (p, top_sl, SORT (x))) { MOID_T *result = pack_soids_in_moid (top_sl, SERIES_MODE); make_soid (y, SORT (x), result, SERIAL_CLAUSE); } else { make_soid (y, SORT (x), (MOID (x) != NO_MOID ? MOID (x) : MODE (ERROR)), 0); } free_soid_list (top_sl); } /*! \brief mode check unit list \param r resulting soids \param p position in tree \param x expected soid **/ static void mode_check_unit_list (SOID_T ** r, NODE_T * p, SOID_T * x) { if (p == NO_NODE) { return; } else if (IS (p, UNIT_LIST)) { mode_check_unit_list (r, SUB (p), x); mode_check_unit_list (r, NEXT (p), x); } else if (IS (p, COMMA_SYMBOL)) { mode_check_unit_list (r, NEXT (p), x); } else if (IS (p, UNIT)) { SOID_T y; mode_check_unit (p, x, &y); add_to_soid_list (r, p, &y); mode_check_unit_list (r, NEXT (p), x); } } /*! \brief mode check struct display \param r resulting soids \param p position in tree \param fields pack **/ static void mode_check_struct_display (SOID_T ** r, NODE_T * p, PACK_T ** fields) { if (p == NO_NODE) { return; } else if (IS (p, UNIT_LIST)) { mode_check_struct_display (r, SUB (p), fields); mode_check_struct_display (r, NEXT (p), fields); } else if (IS (p, COMMA_SYMBOL)) { mode_check_struct_display (r, NEXT (p), fields); } else if (IS (p, UNIT)) { SOID_T x, y; if (*fields != NO_PACK) { make_soid (&x, STRONG, MOID (*fields), 0); FORWARD (*fields); } else { make_soid (&x, STRONG, NO_MOID, 0); } mode_check_unit (p, &x, &y); add_to_soid_list (r, p, &y); mode_check_struct_display (r, NEXT (p), fields); } } /*! \brief mode check get specified moids \param p position in tree \param u united mode to add to **/ static void mode_check_get_specified_moids (NODE_T * p, MOID_T * u) { for (; p != NO_NODE; FORWARD (p)) { if (is_one_of (p, SPECIFIED_UNIT_LIST, SPECIFIED_UNIT, STOP)) { mode_check_get_specified_moids (SUB (p), u); } else if (IS (p, SPECIFIER)) { MOID_T *m = MOID (NEXT_SUB (p)); add_mode_to_pack (&(PACK (u)), m, NO_TEXT, NODE (m)); } } } /*! \brief mode check specified unit list \param r resulting soids \param p position in tree \param x expected soid \param u resulting united mode **/ static void mode_check_specified_unit_list (SOID_T ** r, NODE_T * p, SOID_T * x, MOID_T * u) { for (; p != NO_NODE; FORWARD (p)) { if (is_one_of (p, SPECIFIED_UNIT_LIST, SPECIFIED_UNIT, STOP)) { mode_check_specified_unit_list (r, SUB (p), x, u); } else if (IS (p, SPECIFIER)) { MOID_T *m = MOID (NEXT_SUB (p)); if (u != NO_MOID && !is_unitable (m, u, SAFE_DEFLEXING)) { diagnostic_node (A68_ERROR, p, ERROR_NO_COMPONENT, m, u); } } else if (IS (p, UNIT)) { SOID_T y; mode_check_unit (p, x, &y); add_to_soid_list (r, p, &y); } } } /*! \brief mode check united case parts \param ry resulting soids \param p position in tree \param x expected soid **/ static void mode_check_united_case_parts (SOID_T ** ry, NODE_T * p, SOID_T * x) { SOID_T enq_expct, enq_yield; MOID_T *u = NO_MOID, *v = NO_MOID, *w = NO_MOID; /* Check the CASE part and deduce the united mode */ make_soid (&enq_expct, STRONG, NO_MOID, 0); mode_check_serial_units (NEXT_SUB (p), &enq_expct, &enq_yield, ENQUIRY_CLAUSE); /* Deduce the united mode from the enquiry clause */ u = depref_completely (MOID (&enq_yield)); u = make_united_mode (u); u = depref_completely (u); /* Also deduce the united mode from the specifiers */ v = new_moid (); ATTRIBUTE (v) = SERIES_MODE; mode_check_get_specified_moids (NEXT_SUB (NEXT (p)), v); v = make_united_mode (v); /* Determine a resulting union */ if (u == MODE (HIP)) { w = v; } else { if (IS (u, UNION_SYMBOL)) { BOOL_T uv, vu, some; investigate_firm_relations (PACK (u), PACK (v), &uv, &some); investigate_firm_relations (PACK (v), PACK (u), &vu, &some); if (uv && vu) { /* Every component has a specifier */ w = u; } else if (!uv && !vu) { /* Hmmmm ... let the coercer sort it out */ w = u; } else { /* This is all the balancing we allow here for the moment. Firmly related subsets are not valid so we absorb them. If this doesn't solve it then we get a coercion-error later */ w = absorb_related_subsets (u); } } else { diagnostic_node (A68_ERROR, NEXT_SUB (p), ERROR_NO_UNION, u); return; } } MOID (SUB (p)) = w; FORWARD (p); /* Check the IN part */ mode_check_specified_unit_list (ry, NEXT_SUB (p), x, w); /* OUSE, OUT, ESAC */ if ((FORWARD (p)) != NO_NODE) { if (is_one_of (p, OUT_PART, CHOICE, STOP)) { mode_check_serial (ry, NEXT_SUB (p), x, A68_TRUE); } else if (is_one_of (p, CONFORMITY_OUSE_PART, BRIEF_CONFORMITY_OUSE_PART, STOP)) { mode_check_united_case_parts (ry, SUB (p), x); } } } /*! \brief mode check united case \param p position in tree \param x expected soid \param y resulting soid **/ static void mode_check_united_case (NODE_T * p, SOID_T * x, SOID_T * y) { SOID_T *top_sl = NO_SOID; MOID_T *z; mode_check_united_case_parts (&top_sl, p, x); if (!is_balanced (p, top_sl, SORT (x))) { if (MOID (x) != NO_MOID) { make_soid (y, SORT (x), MOID (x), CONFORMITY_CLAUSE); } else { make_soid (y, SORT (x), MODE (ERROR), 0); } } else { z = pack_soids_in_moid (top_sl, SERIES_MODE); make_soid (y, SORT (x), z, CONFORMITY_CLAUSE); } free_soid_list (top_sl); } /*! \brief mode check unit list 2 \param p position in tree \param x expected soid \param y resulting soid **/ static void mode_check_unit_list_2 (NODE_T * p, SOID_T * x, SOID_T * y) { SOID_T *top_sl = NO_SOID; if (MOID (x) != NO_MOID) { if (IS (MOID (x), FLEX_SYMBOL)) { SOID_T y2; make_soid (&y2, SORT (x), SLICE (SUB_MOID (x)), 0); mode_check_unit_list (&top_sl, SUB (p), &y2); } else if (IS (MOID (x), ROW_SYMBOL)) { SOID_T y2; make_soid (&y2, SORT (x), SLICE (MOID (x)), 0); mode_check_unit_list (&top_sl, SUB (p), &y2); } else if (IS (MOID (x), STRUCT_SYMBOL)) { PACK_T *y2 = PACK (MOID (x)); mode_check_struct_display (&top_sl, SUB (p), &y2); } else { mode_check_unit_list (&top_sl, SUB (p), x); } } else { mode_check_unit_list (&top_sl, SUB (p), x); } make_soid (y, STRONG, pack_soids_in_moid (top_sl, STOWED_MODE), 0); free_soid_list (top_sl); } /*! \brief mode check closed \param p position in tree \param x expected soid \param y resulting soid **/ static void mode_check_closed (NODE_T * p, SOID_T * x, SOID_T * y) { if (p == NO_NODE) { return; } else if (IS (p, SERIAL_CLAUSE)) { mode_check_serial_units (p, x, y, SERIAL_CLAUSE); } else if (is_one_of (p, OPEN_SYMBOL, BEGIN_SYMBOL, STOP)) { mode_check_closed (NEXT (p), x, y); } MOID (p) = MOID (y); } /*! \brief mode check collateral \param p position in tree \param x expected soid \param y resulting soid **/ static void mode_check_collateral (NODE_T * p, SOID_T * x, SOID_T * y) { if (p == NO_NODE) { return; } else if (whether (p, BEGIN_SYMBOL, END_SYMBOL, STOP) || whether (p, OPEN_SYMBOL, CLOSE_SYMBOL, STOP)) { if (SORT (x) == STRONG) { MOID_T *z = (IS (MOID (x), FLEX_SYMBOL) ? SUB_MOID (x) : MOID (x)); make_soid (y, STRONG, MODE (VACUUM), 0); if (SUB (z) != NO_MOID && HAS_ROWS (SUB (z))) { diagnostic_node (A68_ERROR, p, ERROR_VACUUM, "REF", MOID (x)); } } else { make_soid (y, STRONG, MODE (UNDEFINED), 0); } } else { if (IS (p, UNIT_LIST)) { mode_check_unit_list_2 (p, x, y); } else if (is_one_of (p, OPEN_SYMBOL, BEGIN_SYMBOL, STOP)) { mode_check_collateral (NEXT (p), x, y); } MOID (p) = MOID (y); } } /*! \brief mode check conditional 2 \param ry resulting soids \param p position in tree \param x expected soid **/ static void mode_check_conditional_2 (SOID_T ** ry, NODE_T * p, SOID_T * x) { SOID_T enq_expct, enq_yield; make_soid (&enq_expct, STRONG, MODE (BOOL), 0); mode_check_serial_units (NEXT_SUB (p), &enq_expct, &enq_yield, ENQUIRY_CLAUSE); if (!is_coercible_in_context (&enq_yield, &enq_expct, SAFE_DEFLEXING)) { cannot_coerce (p, MOID (&enq_yield), MOID (&enq_expct), MEEK, SAFE_DEFLEXING, ENQUIRY_CLAUSE); } FORWARD (p); mode_check_serial (ry, NEXT_SUB (p), x, A68_TRUE); if ((FORWARD (p)) != NO_NODE) { if (is_one_of (p, ELSE_PART, CHOICE, STOP)) { mode_check_serial (ry, NEXT_SUB (p), x, A68_TRUE); } else if (is_one_of (p, ELIF_PART, BRIEF_ELIF_PART, STOP)) { mode_check_conditional_2 (ry, SUB (p), x); } } } /*! \brief mode check conditional \param p position in tree \param x expected soid \param y resulting soid **/ static void mode_check_conditional (NODE_T * p, SOID_T * x, SOID_T * y) { SOID_T *top_sl = NO_SOID; MOID_T *z; mode_check_conditional_2 (&top_sl, p, x); if (!is_balanced (p, top_sl, SORT (x))) { if (MOID (x) != NO_MOID) { make_soid (y, SORT (x), MOID (x), CONDITIONAL_CLAUSE); } else { make_soid (y, SORT (x), MODE (ERROR), 0); } } else { z = pack_soids_in_moid (top_sl, SERIES_MODE); make_soid (y, SORT (x), z, CONDITIONAL_CLAUSE); } free_soid_list (top_sl); } /*! \brief mode check int case 2 \param ry resulting soids \param p position in tree \param x expected soid **/ static void mode_check_int_case_2 (SOID_T ** ry, NODE_T * p, SOID_T * x) { SOID_T enq_expct, enq_yield; make_soid (&enq_expct, STRONG, MODE (INT), 0); mode_check_serial_units (NEXT_SUB (p), &enq_expct, &enq_yield, ENQUIRY_CLAUSE); if (!is_coercible_in_context (&enq_yield, &enq_expct, SAFE_DEFLEXING)) { cannot_coerce (p, MOID (&enq_yield), MOID (&enq_expct), MEEK, SAFE_DEFLEXING, ENQUIRY_CLAUSE); } FORWARD (p); mode_check_unit_list (ry, NEXT_SUB (p), x); if ((FORWARD (p)) != NO_NODE) { if (is_one_of (p, OUT_PART, CHOICE, STOP)) { mode_check_serial (ry, NEXT_SUB (p), x, A68_TRUE); } else if (is_one_of (p, CASE_OUSE_PART, BRIEF_OUSE_PART, STOP)) { mode_check_int_case_2 (ry, SUB (p), x); } } } /*! \brief mode check int case \param p position in tree \param x expected soid \param y resulting soid **/ static void mode_check_int_case (NODE_T * p, SOID_T * x, SOID_T * y) { SOID_T *top_sl = NO_SOID; MOID_T *z; mode_check_int_case_2 (&top_sl, p, x); if (!is_balanced (p, top_sl, SORT (x))) { if (MOID (x) != NO_MOID) { make_soid (y, SORT (x), MOID (x), CASE_CLAUSE); } else { make_soid (y, SORT (x), MODE (ERROR), 0); } } else { z = pack_soids_in_moid (top_sl, SERIES_MODE); make_soid (y, SORT (x), z, CASE_CLAUSE); } free_soid_list (top_sl); } /*! \brief mode check loop 2 \param p position in tree \param y resulting soid **/ static void mode_check_loop_2 (NODE_T * p, SOID_T * y) { if (p == NO_NODE) { return; } else if (IS (p, FOR_PART)) { mode_check_loop_2 (NEXT (p), y); } else if (is_one_of (p, FROM_PART, BY_PART, TO_PART, STOP)) { SOID_T ix, iy; make_soid (&ix, STRONG, MODE (INT), 0); mode_check_unit (NEXT_SUB (p), &ix, &iy); if (!is_coercible_in_context (&iy, &ix, SAFE_DEFLEXING)) { cannot_coerce (NEXT_SUB (p), MOID (&iy), MODE (INT), MEEK, SAFE_DEFLEXING, ENQUIRY_CLAUSE); } mode_check_loop_2 (NEXT (p), y); } else if (IS (p, WHILE_PART)) { SOID_T enq_expct, enq_yield; make_soid (&enq_expct, STRONG, MODE (BOOL), 0); mode_check_serial_units (NEXT_SUB (p), &enq_expct, &enq_yield, ENQUIRY_CLAUSE); if (!is_coercible_in_context (&enq_yield, &enq_expct, SAFE_DEFLEXING)) { cannot_coerce (p, MOID (&enq_yield), MOID (&enq_expct), MEEK, SAFE_DEFLEXING, ENQUIRY_CLAUSE); } mode_check_loop_2 (NEXT (p), y); } else if (is_one_of (p, DO_PART, ALT_DO_PART, STOP)) { SOID_T *z = NO_SOID; SOID_T ix; NODE_T *do_p = NEXT_SUB (p), *un_p; make_soid (&ix, STRONG, MODE (VOID), 0); if (IS (do_p, SERIAL_CLAUSE)) { mode_check_serial (&z, do_p, &ix, A68_TRUE); un_p = NEXT (do_p); } else { un_p = do_p; } if (un_p != NO_NODE && IS (un_p, UNTIL_PART)) { SOID_T enq_expct, enq_yield; make_soid (&enq_expct, STRONG, MODE (BOOL), 0); mode_check_serial_units (NEXT_SUB (un_p), &enq_expct, &enq_yield, ENQUIRY_CLAUSE); if (!is_coercible_in_context (&enq_yield, &enq_expct, SAFE_DEFLEXING)) { cannot_coerce (un_p, MOID (&enq_yield), MOID (&enq_expct), MEEK, SAFE_DEFLEXING, ENQUIRY_CLAUSE); } } free_soid_list (z); } } /*! \brief mode check loop \param p position in tree \param y resulting soid **/ static void mode_check_loop (NODE_T * p, SOID_T * y) { SOID_T *z = NO_SOID; mode_check_loop_2 (p, /* y */ z); make_soid (y, STRONG, MODE (VOID), 0); } /*! \brief mode check enclosed \param p position in tree \param x expected soid \param y resulting soid **/ void mode_check_enclosed (NODE_T * p, SOID_T * x, SOID_T * y) { if (p == NO_NODE) { return; } else if (IS (p, ENCLOSED_CLAUSE)) { mode_check_enclosed (SUB (p), x, y); } else if (IS (p, CLOSED_CLAUSE)) { mode_check_closed (SUB (p), x, y); } else if (IS (p, PARALLEL_CLAUSE)) { mode_check_collateral (SUB (NEXT_SUB (p)), x, y); make_soid (y, STRONG, MODE (VOID), 0); MOID (NEXT_SUB (p)) = MODE (VOID); } else if (IS (p, COLLATERAL_CLAUSE)) { mode_check_collateral (SUB (p), x, y); } else if (IS (p, CONDITIONAL_CLAUSE)) { mode_check_conditional (SUB (p), x, y); } else if (IS (p, CASE_CLAUSE)) { mode_check_int_case (SUB (p), x, y); } else if (IS (p, CONFORMITY_CLAUSE)) { mode_check_united_case (SUB (p), x, y); } else if (IS (p, LOOP_CLAUSE)) { mode_check_loop (SUB (p), y); } MOID (p) = MOID (y); } /*! \brief search table for operator \param t tag chain to search \param n name of operator \param x lhs mode \param y rhs mode \return tag entry **/ static TAG_T *search_table_for_operator (TAG_T * t, char *n, MOID_T * x, MOID_T * y) { if (is_mode_isnt_well (x)) { return (error_tag); } else if (y != NO_MOID && is_mode_isnt_well (y)) { return (error_tag); } for (; t != NO_TAG; FORWARD (t)) { if (NSYMBOL (NODE (t)) == n) { PACK_T *p = PACK (MOID (t)); if (is_coercible (x, MOID (p), FIRM, ALIAS_DEFLEXING)) { FORWARD (p); if (p == NO_PACK && y == NO_MOID) { /* Matched in case of a monadic */ return (t); } else if (p != NO_PACK && y != NO_MOID && is_coercible (y, MOID (p), FIRM, ALIAS_DEFLEXING)) { /* Matched in case of a dyadic */ return (t); } } } } return (NO_TAG); } /*! \brief search chain of symbol tables and return matching operator "x n y" or "n x" \param s symbol table to start search \param n name of token \param x lhs mode \param y rhs mode \return tag entry **/ static TAG_T *search_table_chain_for_operator (TABLE_T * s, char * n, MOID_T * x, MOID_T * y) { if (is_mode_isnt_well (x)) { return (error_tag); } else if (y != NO_MOID && is_mode_isnt_well (y)) { return (error_tag); } while (s != NO_TABLE) { TAG_T *z = search_table_for_operator (OPERATORS (s), n, x, y); if (z != NO_TAG) { return (z); } BACKWARD (s); } return (NO_TAG); } /*! \brief return a matching operator "x n y" \param s symbol table to start search \param n name of token \param x lhs mode \param y rhs mode \return tag entry **/ static TAG_T *find_operator (TABLE_T * s, char *n, MOID_T * x, MOID_T * y) { /* Coercions to operand modes are FIRM */ TAG_T *z; MOID_T *u, *v; /* (A) Catch exceptions first */ if (x == NO_MOID && y == NO_MOID) { return (NO_TAG); } else if (is_mode_isnt_well (x)) { return (error_tag); } else if (y != NO_MOID && is_mode_isnt_well (y)) { return (error_tag); } /* (B) MONADs */ if (x != NO_MOID && y == NO_MOID) { z = search_table_chain_for_operator (s, n, x, NO_MOID); if (z != NO_TAG) { return (z); } else { /* (B.2) A little trick to allow - (0, 1) or ABS (1, long pi) */ if (is_coercible (x, MODE (COMPLEX), STRONG, SAFE_DEFLEXING)) { z = search_table_for_operator (OPERATORS (a68g_standenv), n, MODE (COMPLEX), NO_MOID); if (z != NO_TAG) { return (z); } } if (is_coercible (x, MODE (LONG_COMPLEX), STRONG, SAFE_DEFLEXING)) { z = search_table_for_operator (OPERATORS (a68g_standenv), n, MODE (LONG_COMPLEX), NO_MOID); if (z != NO_TAG) { return (z); } } if (is_coercible (x, MODE (LONGLONG_COMPLEX), STRONG, SAFE_DEFLEXING)) { z = search_table_for_operator (OPERATORS (a68g_standenv), n, MODE (LONGLONG_COMPLEX), NO_MOID); } } return (NO_TAG); } /* (C) DYADs */ z = search_table_chain_for_operator (s, n, x, y); if (z != NO_TAG) { return (z); } /* (C.2) Vector and matrix "strong coercions" in standard environ */ u = depref_completely (x); v = depref_completely (y); if ((u == MODE (ROW_REAL) || u == MODE (ROWROW_REAL)) || (v == MODE (ROW_REAL) || v == MODE (ROWROW_REAL)) || (u == MODE (ROW_COMPLEX) || u == MODE (ROWROW_COMPLEX)) || (v == MODE (ROW_COMPLEX) || v == MODE (ROWROW_COMPLEX))) { if (u == MODE (INT)) { z = search_table_for_operator (OPERATORS (a68g_standenv), n, MODE (REAL), y); if (z != NO_TAG) { return (z); } z = search_table_for_operator (OPERATORS (a68g_standenv), n, MODE (COMPLEX), y); if (z != NO_TAG) { return (z); } } else if (v == MODE (INT)) { z = search_table_for_operator (OPERATORS (a68g_standenv), n, x, MODE (REAL)); if (z != NO_TAG) { return (z); } z = search_table_for_operator (OPERATORS (a68g_standenv), n, x, MODE (COMPLEX)); if (z != NO_TAG) { return (z); } } else if (u == MODE (REAL)) { z = search_table_for_operator (OPERATORS (a68g_standenv), n, MODE (COMPLEX), y); if (z != NO_TAG) { return (z); } } else if (v == MODE (REAL)) { z = search_table_for_operator (OPERATORS (a68g_standenv), n, x, MODE (COMPLEX)); if (z != NO_TAG) { return (z); } } } /* (C.3) Look in standenv for an appropriate cross-term */ u = make_series_from_moids (x, y); u = make_united_mode (u); v = get_balanced_mode (u, STRONG, NO_DEPREF, SAFE_DEFLEXING); z = search_table_for_operator (OPERATORS (a68g_standenv), n, v, v); if (z != NO_TAG) { return (z); } if (is_coercible_series (u, MODE (REAL), STRONG, SAFE_DEFLEXING)) { z = search_table_for_operator (OPERATORS (a68g_standenv), n, MODE (REAL), MODE (REAL)); if (z != NO_TAG) { return (z); } } if (is_coercible_series (u, MODE (LONG_REAL), STRONG, SAFE_DEFLEXING)) { z = search_table_for_operator (OPERATORS (a68g_standenv), n, MODE (LONG_REAL), MODE (LONG_REAL)); if (z != NO_TAG) { return (z); } } if (is_coercible_series (u, MODE (LONGLONG_REAL), STRONG, SAFE_DEFLEXING)) { z = search_table_for_operator (OPERATORS (a68g_standenv), n, MODE (LONGLONG_REAL), MODE (LONGLONG_REAL)); if (z != NO_TAG) { return (z); } } if (is_coercible_series (u, MODE (COMPLEX), STRONG, SAFE_DEFLEXING)) { z = search_table_for_operator (OPERATORS (a68g_standenv), n, MODE (COMPLEX), MODE (COMPLEX)); if (z != NO_TAG) { return (z); } } if (is_coercible_series (u, MODE (LONG_COMPLEX), STRONG, SAFE_DEFLEXING)) { z = search_table_for_operator (OPERATORS (a68g_standenv), n, MODE (LONG_COMPLEX), MODE (LONG_COMPLEX)); if (z != NO_TAG) { return (z); } } if (is_coercible_series (u, MODE (LONGLONG_COMPLEX), STRONG, SAFE_DEFLEXING)) { z = search_table_for_operator (OPERATORS (a68g_standenv), n, MODE (LONGLONG_COMPLEX), MODE (LONGLONG_COMPLEX)); if (z != NO_TAG) { return (z); } } /* (C.4) Now allow for depreffing for REF REAL +:= INT and alike */ v = get_balanced_mode (u, STRONG, DEPREF, SAFE_DEFLEXING); z = search_table_for_operator (OPERATORS (a68g_standenv), n, v, v); if (z != NO_TAG) { return (z); } return (NO_TAG); } /*! \brief mode check monadic operator \param p position in tree \param x expected soid \param y resulting soid **/ static void mode_check_monadic_operator (NODE_T * p, SOID_T * x, SOID_T * y) { if (p != NO_NODE) { TAG_T *t; MOID_T *u; u = determine_unique_mode (y, SAFE_DEFLEXING); if (is_mode_isnt_well (u)) { make_soid (y, SORT (x), MODE (ERROR), 0); } else if (u == MODE (HIP)) { diagnostic_node (A68_ERROR, NEXT (p), ERROR_INVALID_OPERAND, u); make_soid (y, SORT (x), MODE (ERROR), 0); } else { if (a68g_strchr (NOMADS, *(NSYMBOL (p))) != NO_TEXT) { t = NO_TAG; diagnostic_node (A68_SYNTAX_ERROR, p, ERROR_OPERATOR_INVALID, NOMADS); make_soid (y, SORT (x), MODE (ERROR), 0); } else { t = find_operator (TABLE (p), NSYMBOL (p), u, NO_MOID); if (t == NO_TAG) { diagnostic_node (A68_ERROR, p, ERROR_NO_MONADIC, u); make_soid (y, SORT (x), MODE (ERROR), 0); } } if (t != NO_TAG) { MOID (p) = MOID (t); } TAX (p) = t; if (t != NO_TAG && t != error_tag) { MOID (p) = MOID (t); make_soid (y, SORT (x), SUB_MOID (t), 0); } else { MOID (p) = MODE (ERROR); make_soid (y, SORT (x), MODE (ERROR), 0); } } } } /*! \brief mode check monadic formula \param p position in tree \param x expected soid \param y resulting soid **/ static void mode_check_monadic_formula (NODE_T * p, SOID_T * x, SOID_T * y) { SOID_T e; make_soid (&e, FIRM, NO_MOID, 0); mode_check_formula (NEXT (p), &e, y); mode_check_monadic_operator (p, &e, y); make_soid (y, SORT (x), MOID (y), 0); } /*! \brief mode check formula \param p position in tree \param x expected soid \param y resulting soid **/ static void mode_check_formula (NODE_T * p, SOID_T * x, SOID_T * y) { SOID_T ls, rs; TAG_T *op; MOID_T *u, *v; if (IS (p, MONADIC_FORMULA)) { mode_check_monadic_formula (SUB (p), x, &ls); } else if (IS (p, FORMULA)) { mode_check_formula (SUB (p), x, &ls); } else if (IS (p, SECONDARY)) { SOID_T e; make_soid (&e, FIRM, NO_MOID, 0); mode_check_unit (SUB (p), &e, &ls); } u = determine_unique_mode (&ls, SAFE_DEFLEXING); MOID (p) = u; if (NEXT (p) == NO_NODE) { make_soid (y, SORT (x), u, 0); } else { NODE_T *q = NEXT_NEXT (p); if (IS (q, MONADIC_FORMULA)) { mode_check_monadic_formula (SUB (NEXT_NEXT (p)), x, &rs); } else if (IS (q, FORMULA)) { mode_check_formula (SUB (NEXT_NEXT (p)), x, &rs); } else if (IS (q, SECONDARY)) { SOID_T e; make_soid (&e, FIRM, NO_MOID, 0); mode_check_unit (SUB (q), &e, &rs); } v = determine_unique_mode (&rs, SAFE_DEFLEXING); MOID (q) = v; if (is_mode_isnt_well (u) || is_mode_isnt_well (v)) { make_soid (y, SORT (x), MODE (ERROR), 0); } else if (u == MODE (HIP)) { diagnostic_node (A68_ERROR, p, ERROR_INVALID_OPERAND, u); make_soid (y, SORT (x), MODE (ERROR), 0); } else if (v == MODE (HIP)) { diagnostic_node (A68_ERROR, q, ERROR_INVALID_OPERAND, u); make_soid (y, SORT (x), MODE (ERROR), 0); } else { op = find_operator (TABLE (NEXT (p)), NSYMBOL (NEXT (p)), u, v); if (op == NO_TAG) { diagnostic_node (A68_ERROR, NEXT (p), ERROR_NO_DYADIC, u, v); make_soid (y, SORT (x), MODE (ERROR), 0); } if (op != NO_TAG) { MOID (NEXT (p)) = MOID (op); } TAX (NEXT (p)) = op; if (op != NO_TAG && op != error_tag) { make_soid (y, SORT (x), SUB_MOID (op), 0); } else { make_soid (y, SORT (x), MODE (ERROR), 0); } } } } /*! \brief mode check assignation \param p position in tree \param x expected soid \param y resulting soid **/ static void mode_check_assignation (NODE_T * p, SOID_T * x, SOID_T * y) { SOID_T name, tmp, value; MOID_T *name_moid, *source_moid, *dest_moid, *ori; /* Get destination mode */ make_soid (&name, SOFT, NO_MOID, 0); mode_check_unit (SUB (p), &name, &tmp); dest_moid = MOID (&tmp); /* SOFT coercion */ ori = determine_unique_mode (&tmp, SAFE_DEFLEXING); name_moid = deproc_completely (ori); if (ATTRIBUTE (name_moid) != REF_SYMBOL) { if (IF_MODE_IS_WELL (name_moid)) { diagnostic_node (A68_ERROR, p, ERROR_NO_NAME, ori, ATTRIBUTE (SUB (p))); } make_soid (y, SORT (x), MODE (ERROR), 0); return; } MOID (p) = name_moid; /* Get source mode */ make_soid (&name, STRONG, SUB (name_moid), 0); mode_check_unit (NEXT_NEXT (p), &name, &value); if (!is_coercible_in_context (&value, &name, FORCE_DEFLEXING)) { source_moid = MOID (&value); cannot_coerce (p, MOID (&value), MOID (&name), STRONG, FORCE_DEFLEXING, UNIT); make_soid (y, SORT (x), MODE (ERROR), 0); } else { make_soid (y, SORT (x), name_moid, 0); } } /*! \brief mode check identity relation \param p position in tree \param x expected soid \param y resulting soid **/ static void mode_check_identity_relation (NODE_T * p, SOID_T * x, SOID_T * y) { SOID_T e, l, r; MOID_T *lhs, *rhs, *oril, *orir; NODE_T *ln = p, *rn = NEXT_NEXT (p); make_soid (&e, SOFT, NO_MOID, 0); mode_check_unit (SUB (ln), &e, &l); mode_check_unit (SUB (rn), &e, &r); /* SOFT coercion */ oril = determine_unique_mode (&l, SAFE_DEFLEXING); orir = determine_unique_mode (&r, SAFE_DEFLEXING); lhs = deproc_completely (oril); rhs = deproc_completely (orir); if (IF_MODE_IS_WELL (lhs) && lhs != MODE (HIP) && ATTRIBUTE (lhs) != REF_SYMBOL) { diagnostic_node (A68_ERROR, ln, ERROR_NO_NAME, oril, ATTRIBUTE (SUB (ln))); lhs = MODE (ERROR); } if (IF_MODE_IS_WELL (rhs) && rhs != MODE (HIP) && ATTRIBUTE (rhs) != REF_SYMBOL) { diagnostic_node (A68_ERROR, rn, ERROR_NO_NAME, orir, ATTRIBUTE (SUB (rn))); rhs = MODE (ERROR); } if (lhs == MODE (HIP) && rhs == MODE (HIP)) { diagnostic_node (A68_ERROR, p, ERROR_NO_UNIQUE_MODE); } if (is_coercible (lhs, rhs, STRONG, SAFE_DEFLEXING)) { lhs = rhs; } else if (is_coercible (rhs, lhs, STRONG, SAFE_DEFLEXING)) { rhs = lhs; } else { cannot_coerce (NEXT (p), rhs, lhs, SOFT, SKIP_DEFLEXING, TERTIARY); lhs = rhs = MODE (ERROR); } MOID (ln) = lhs; MOID (rn) = rhs; make_soid (y, SORT (x), MODE (BOOL), 0); } /*! \brief mode check bool functions ANDF and ORF \param p position in tree \param x expected soid \param y resulting soid **/ static void mode_check_bool_function (NODE_T * p, SOID_T * x, SOID_T * y) { SOID_T e, l, r; NODE_T *ln = p, *rn = NEXT_NEXT (p); make_soid (&e, STRONG, MODE (BOOL), 0); mode_check_unit (SUB (ln), &e, &l); if (!is_coercible_in_context (&l, &e, SAFE_DEFLEXING)) { cannot_coerce (ln, MOID (&l), MOID (&e), MEEK, SAFE_DEFLEXING, TERTIARY); } mode_check_unit (SUB (rn), &e, &r); if (!is_coercible_in_context (&r, &e, SAFE_DEFLEXING)) { cannot_coerce (rn, MOID (&r), MOID (&e), MEEK, SAFE_DEFLEXING, TERTIARY); } MOID (ln) = MODE (BOOL); MOID (rn) = MODE (BOOL); make_soid (y, SORT (x), MODE (BOOL), 0); } /*! \brief mode check cast \param p position in tree \param x expected soid \param y resulting soid **/ static void mode_check_cast (NODE_T * p, SOID_T * x, SOID_T * y) { SOID_T w; mode_check_declarer (p); make_soid (&w, STRONG, MOID (p), 0); CAST (&w) = A68_TRUE; mode_check_enclosed (SUB_NEXT (p), &w, y); if (!is_coercible_in_context (y, &w, SAFE_DEFLEXING)) { cannot_coerce (NEXT (p), MOID (y), MOID (&w), STRONG, SAFE_DEFLEXING, ENCLOSED_CLAUSE); } make_soid (y, SORT (x), MOID (p), 0); } /*! \brief mode check assertion \param p position in tree **/ static void mode_check_assertion (NODE_T * p) { SOID_T w, y; make_soid (&w, STRONG, MODE (BOOL), 0); mode_check_enclosed (SUB_NEXT (p), &w, &y); SORT (&y) = SORT (&w); /* Patch */ if (!is_coercible_in_context (&y, &w, NO_DEFLEXING)) { cannot_coerce (NEXT (p), MOID (&y), MOID (&w), MEEK, NO_DEFLEXING, ENCLOSED_CLAUSE); } } /*! \brief mode check argument list \param r resulting soids \param p position in tree \param x proc argument pack \param v partial locale pack \param w partial proc pack **/ static void mode_check_argument_list (SOID_T ** r, NODE_T * p, PACK_T ** x, PACK_T ** v, PACK_T ** w) { for (; p != NO_NODE; FORWARD (p)) { if (IS (p, GENERIC_ARGUMENT_LIST)) { ATTRIBUTE (p) = ARGUMENT_LIST; } if (IS (p, ARGUMENT_LIST)) { mode_check_argument_list (r, SUB (p), x, v, w); } else if (IS (p, UNIT)) { SOID_T y, z; if (*x != NO_PACK) { make_soid (&z, STRONG, MOID (*x), 0); add_mode_to_pack_end (v, MOID (*x), NO_TEXT, p); FORWARD (*x); } else { make_soid (&z, STRONG, NO_MOID, 0); } mode_check_unit (p, &z, &y); add_to_soid_list (r, p, &y); } else if (IS (p, TRIMMER)) { SOID_T z; if (SUB (p) != NO_NODE) { diagnostic_node (A68_SYNTAX_ERROR, p, ERROR_SYNTAX, ARGUMENT); make_soid (&z, STRONG, MODE (ERROR), 0); add_mode_to_pack_end (v, MODE (VOID), NO_TEXT, p); add_mode_to_pack_end (w, MOID (*x), NO_TEXT, p); FORWARD (*x); } else if (*x != NO_PACK) { make_soid (&z, STRONG, MOID (*x), 0); add_mode_to_pack_end (v, MODE (VOID), NO_TEXT, p); add_mode_to_pack_end (w, MOID (*x), NO_TEXT, p); FORWARD (*x); } else { make_soid (&z, STRONG, NO_MOID, 0); } add_to_soid_list (r, p, &z); } else if (IS (p, SUB_SYMBOL) && !OPTION_BRACKETS (&program)) { diagnostic_node (A68_SYNTAX_ERROR, p, ERROR_SYNTAX, CALL); } } } /*! \brief mode check argument list 2 \param p position in tree \param x proc argument pack \param y soid \param v partial locale pack \param w partial proc pack **/ static void mode_check_argument_list_2 (NODE_T * p, PACK_T * x, SOID_T * y, PACK_T ** v, PACK_T ** w) { SOID_T *top_sl = NO_SOID; mode_check_argument_list (&top_sl, SUB (p), &x, v, w); make_soid (y, STRONG, pack_soids_in_moid (top_sl, STOWED_MODE), 0); free_soid_list (top_sl); } /*! \brief mode check meek int \param p position in tree **/ static void mode_check_meek_int (NODE_T * p) { SOID_T x, y; make_soid (&x, STRONG, MODE (INT), 0); mode_check_unit (p, &x, &y); if (!is_coercible_in_context (&y, &x, SAFE_DEFLEXING)) { cannot_coerce (p, MOID (&y), MOID (&x), MEEK, SAFE_DEFLEXING, 0); } } /*! \brief mode check trimmer \param p position in tree **/ static void mode_check_trimmer (NODE_T * p) { if (p == NO_NODE) { return; } else if (IS (p, TRIMMER)) { mode_check_trimmer (SUB (p)); } else if (IS (p, UNIT)) { mode_check_meek_int (p); mode_check_trimmer (NEXT (p)); } else { mode_check_trimmer (NEXT (p)); } } /*! \brief mode check indexer \param p position in tree \param subs subscript counter \param trims trimmer counter **/ static void mode_check_indexer (NODE_T * p, int *subs, int *trims) { if (p == NO_NODE) { return; } else if (IS (p, TRIMMER)) { (*trims)++; mode_check_trimmer (SUB (p)); } else if (IS (p, UNIT)) { (*subs)++; mode_check_meek_int (p); } else { mode_check_indexer (SUB (p), subs, trims); mode_check_indexer (NEXT (p), subs, trims); } } /*! \brief mode check call \param p position in tree \param n mode \param x expected soid \param y resulting soid **/ static void mode_check_call (NODE_T * p, MOID_T * n, SOID_T * x, SOID_T * y) { SOID_T d; MOID (p) = n; /* "partial_locale" is the mode of the locale */ PARTIAL_LOCALE (GINFO (p)) = new_moid (); ATTRIBUTE (PARTIAL_LOCALE (GINFO (p))) = PROC_SYMBOL; PACK (PARTIAL_LOCALE (GINFO (p))) = NO_PACK; SUB (PARTIAL_LOCALE (GINFO (p))) = SUB (n); /* "partial_proc" is the mode of the resulting proc */ PARTIAL_PROC (GINFO (p)) = new_moid (); ATTRIBUTE (PARTIAL_PROC (GINFO (p))) = PROC_SYMBOL; PACK (PARTIAL_PROC (GINFO (p))) = NO_PACK; SUB (PARTIAL_PROC (GINFO (p))) = SUB (n); /* Check arguments and construct modes */ mode_check_argument_list_2 (NEXT (p), PACK (n), &d, &PACK (PARTIAL_LOCALE (GINFO (p))), &PACK (PARTIAL_PROC (GINFO (p)))); DIM (PARTIAL_PROC (GINFO (p))) = count_pack_members (PACK (PARTIAL_PROC (GINFO (p)))); DIM (PARTIAL_LOCALE (GINFO (p))) = count_pack_members (PACK (PARTIAL_LOCALE (GINFO (p)))); PARTIAL_PROC (GINFO (p)) = register_extra_mode (&TOP_MOID (&program), PARTIAL_PROC (GINFO (p))); PARTIAL_LOCALE (GINFO (p)) = register_extra_mode (&TOP_MOID (&program), PARTIAL_LOCALE (GINFO (p))); if (DIM (MOID (&d)) != DIM (n)) { diagnostic_node (A68_ERROR, p, ERROR_ARGUMENT_NUMBER, n); make_soid (y, SORT (x), SUB (n), 0); /* make_soid (y, SORT (x), MODE (ERROR), 0); */ } else { if (!is_coercible (MOID (&d), n, STRONG, ALIAS_DEFLEXING)) { cannot_coerce (p, MOID (&d), n, STRONG, ALIAS_DEFLEXING, ARGUMENT); } if (DIM (PARTIAL_PROC (GINFO (p))) == 0) { make_soid (y, SORT (x), SUB (n), 0); } else { if (OPTION_PORTCHECK (&program)) { diagnostic_node (A68_WARNING | A68_FORCE_DIAGNOSTICS, NEXT (p), WARNING_EXTENSION); } make_soid (y, SORT (x), PARTIAL_PROC (GINFO (p)), 0); } } } /*! \brief mode check slice \param p position in tree \param x expected soid \param y resulting soid \return whether construct is a CALL or a SLICE **/ static void mode_check_slice (NODE_T * p, MOID_T * ori, SOID_T * x, SOID_T * y) { BOOL_T is_ref; int rowdim, subs, trims; MOID_T *m = depref_completely (ori), *n = ori; /* WEAK coercion */ while ((IS (n, REF_SYMBOL) && !is_ref_row (n)) || (IS (n, PROC_SYMBOL) && PACK (n) == NO_PACK)) { n = depref_once (n); } if (n == NO_MOID || !(SLICE (DEFLEX (n)) != NO_MOID || is_ref_row (n))) { if (IF_MODE_IS_WELL (n)) { diagnostic_node (A68_ERROR, p, ERROR_NO_ROW_OR_PROC, n, ATTRIBUTE (SUB (p))); } make_soid (y, SORT (x), MODE (ERROR), 0); } MOID (p) = n; subs = trims = 0; mode_check_indexer (SUB_NEXT (p), &subs, &trims); if ((is_ref = is_ref_row (n)) != 0) { rowdim = DIM (DEFLEX (SUB (n))); } else { rowdim = DIM (DEFLEX (n)); } if ((subs + trims) != rowdim) { diagnostic_node (A68_ERROR, p, ERROR_INDEXER_NUMBER, n); make_soid (y, SORT (x), MODE (ERROR), 0); } else { if (subs > 0 && trims == 0) { ANNOTATION (NEXT (p)) = SLICE; m = n; } else { ANNOTATION (NEXT (p)) = TRIMMER; m = n; } while (subs > 0) { if (is_ref) { m = NAME (m); } else { if (IS (m, FLEX_SYMBOL)) { m = SUB (m); } m = SLICE (m); } ABEND (m == NO_MOID, "No mode in mode_check_slice", NO_TEXT); subs--; } /* A trim cannot be but deflexed */ if (ANNOTATION (NEXT (p)) == TRIMMER && TRIM (m) != NO_MOID) { ABEND (TRIM (m) == NO_MOID, ERROR_INTERNAL_CONSISTENCY, NO_TEXT); make_soid (y, SORT (x), TRIM (m), 0); } else { make_soid (y, SORT (x), m, 0); } } } /*! \brief mode check specification \param p position in tree \param x expected soid \param y resulting soid \return whether construct is a CALL or SLICE **/ static int mode_check_specification (NODE_T * p, SOID_T * x, SOID_T * y) { SOID_T w, d; MOID_T *m, *ori; make_soid (&w, WEAK, NO_MOID, 0); mode_check_unit (SUB (p), &w, &d); ori = determine_unique_mode (&d, SAFE_DEFLEXING); m = depref_completely (ori); if (IS (m, PROC_SYMBOL)) { /* Assume CALL */ mode_check_call (p, m, x, y); return (CALL); } else if (IS (m, ROW_SYMBOL) || IS (m, FLEX_SYMBOL)) { /* Assume SLICE */ mode_check_slice (p, ori, x, y); return (SLICE); } else { if (m != MODE (ERROR)) { diagnostic_node (A68_SYNTAX_ERROR, p, ERROR_MODE_SPECIFICATION, m); } make_soid (y, SORT (x), MODE (ERROR), 0); return (PRIMARY); } } /*! \brief mode check selection \param p position in tree \param x expected soid \param y resulting soid **/ static void mode_check_selection (NODE_T * p, SOID_T * x, SOID_T * y) { SOID_T w, d; BOOL_T coerce; MOID_T *n, *str, *ori; PACK_T *t, *t_2; char *fs; BOOL_T deflex = A68_FALSE; NODE_T *secondary = SUB_NEXT (p); make_soid (&w, WEAK, NO_MOID, 0); mode_check_unit (secondary, &w, &d); n = ori = determine_unique_mode (&d, SAFE_DEFLEXING); coerce = A68_TRUE; while (coerce) { if (IS (n, STRUCT_SYMBOL)) { coerce = A68_FALSE; t = PACK (n); } else if (IS (n, REF_SYMBOL) && (IS (SUB (n), ROW_SYMBOL) || IS (SUB (n), FLEX_SYMBOL)) && MULTIPLE (n) != NO_MOID) { coerce = A68_FALSE; deflex = A68_TRUE; t = PACK (MULTIPLE (n)); } else if ((IS (n, ROW_SYMBOL) || IS (n, FLEX_SYMBOL)) && MULTIPLE (n) != NO_MOID) { coerce = A68_FALSE; deflex = A68_TRUE; t = PACK (MULTIPLE (n)); } else if (IS (n, REF_SYMBOL) && is_name_struct (n)) { coerce = A68_FALSE; t = PACK (NAME (n)); } else if (is_deprefable (n)) { coerce = A68_TRUE; n = SUB (n); t = NO_PACK; } else { coerce = A68_FALSE; t = NO_PACK; } } if (t == NO_PACK) { if (IF_MODE_IS_WELL (MOID (&d))) { diagnostic_node (A68_ERROR, secondary, ERROR_NO_STRUCT, ori, ATTRIBUTE (secondary)); } make_soid (y, SORT (x), MODE (ERROR), 0); return; } MOID (NEXT (p)) = n; fs = NSYMBOL (SUB (p)); str = n; while (IS (str, REF_SYMBOL)) { str = SUB (str); } if (IS (str, FLEX_SYMBOL)) { str = SUB (str); } if (IS (str, ROW_SYMBOL)) { str = SUB (str); } t_2 = PACK (str); while (t != NO_PACK && t_2 != NO_PACK) { if (TEXT (t) == fs) { MOID_T *ret = MOID (t); if (deflex && TRIM (ret) != NO_MOID) { ret = TRIM (ret); } make_soid (y, SORT (x), ret, 0); MOID (p) = ret; NODE_PACK (SUB (p)) = t_2; return; } FORWARD (t); FORWARD (t_2); } make_soid (&d, NO_SORT, n, 0); diagnostic_node (A68_ERROR, p, ERROR_NO_FIELD, str, fs); make_soid (y, SORT (x), MODE (ERROR), 0); } /*! \brief mode check diagonal \param p position in tree \param x expected soid \param y resulting soid **/ static void mode_check_diagonal (NODE_T * p, SOID_T * x, SOID_T * y) { SOID_T w, d; NODE_T *tert; MOID_T *n, *ori; int rowdim; BOOL_T is_ref; if (IS (p, TERTIARY)) { make_soid (&w, STRONG, MODE (INT), 0); mode_check_unit (p, &w, &d); if (!is_coercible_in_context (&d, &w, SAFE_DEFLEXING)) { cannot_coerce (p, MOID (&d), MOID (&w), MEEK, SAFE_DEFLEXING, 0); } tert = NEXT_NEXT (p); } else { tert = NEXT (p); } make_soid (&w, WEAK, NO_MOID, 0); mode_check_unit (tert, &w, &d); n = ori = determine_unique_mode (&d, SAFE_DEFLEXING); while (IS (n, REF_SYMBOL) && !is_ref_row (n)) { n = depref_once (n); } if (n != NO_MOID && (IS (n, FLEX_SYMBOL) || IS_REF_FLEX (n))) { if (IF_MODE_IS_WELL (n)) { diagnostic_node (A68_ERROR, p, ERROR_NO_FLEX_ARGUMENT, ori, TERTIARY); } make_soid (y, SORT (x), MODE (ERROR), 0); return; } if (n == NO_MOID || !(SLICE (DEFLEX (n)) != NO_MOID || is_ref_row (n))) { if (IF_MODE_IS_WELL (n)) { diagnostic_node (A68_ERROR, p, ERROR_NO_MATRIX, ori, TERTIARY); } make_soid (y, SORT (x), MODE (ERROR), 0); return; } if ((is_ref = is_ref_row (n)) != A68_FALSE) { rowdim = DIM (DEFLEX (SUB (n))); } else { rowdim = DIM (DEFLEX (n)); } if (rowdim != 2) { diagnostic_node (A68_ERROR, p, ERROR_NO_MATRIX, ori, TERTIARY); make_soid (y, SORT (x), MODE (ERROR), 0); return; } MOID (tert) = n; if (is_ref) { n = NAME (n); ABEND (ISNT (n, REF_SYMBOL), "mode table error", PM (n)); } else { n = SLICE (n); } ABEND (n == NO_MOID, "No mode in mode_check_diagonal", NO_TEXT); make_soid (y, SORT (x), n, 0); } /*! \brief mode check transpose \param p position in tree \param x expected soid \param y resulting soid **/ static void mode_check_transpose (NODE_T * p, SOID_T * x, SOID_T * y) { SOID_T w, d; NODE_T *tert = NEXT (p); MOID_T *n, *ori; int rowdim; BOOL_T is_ref; make_soid (&w, WEAK, NO_MOID, 0); mode_check_unit (tert, &w, &d); n = ori = determine_unique_mode (&d, SAFE_DEFLEXING); while (IS (n, REF_SYMBOL) && !is_ref_row (n)) { n = depref_once (n); } if (n != NO_MOID && (IS (n, FLEX_SYMBOL) || IS_REF_FLEX (n))) { if (IF_MODE_IS_WELL (n)) { diagnostic_node (A68_ERROR, p, ERROR_NO_FLEX_ARGUMENT, ori, TERTIARY); } make_soid (y, SORT (x), MODE (ERROR), 0); return; } if (n == NO_MOID || !(SLICE (DEFLEX (n)) != NO_MOID || is_ref_row (n))) { if (IF_MODE_IS_WELL (n)) { diagnostic_node (A68_ERROR, p, ERROR_NO_MATRIX, ori, TERTIARY); } make_soid (y, SORT (x), MODE (ERROR), 0); return; } if ((is_ref = is_ref_row (n)) != A68_FALSE) { rowdim = DIM (DEFLEX (SUB (n))); } else { rowdim = DIM (DEFLEX (n)); } if (rowdim != 2) { diagnostic_node (A68_ERROR, p, ERROR_NO_MATRIX, ori, TERTIARY); make_soid (y, SORT (x), MODE (ERROR), 0); return; } MOID (tert) = n; ABEND (n == NO_MOID, "No mode in mode_check_transpose", NO_TEXT); make_soid (y, SORT (x), n, 0); } /*! \brief mode check row or column function \param p position in tree \param x expected soid \param y resulting soid **/ static void mode_check_row_column_function (NODE_T * p, SOID_T * x, SOID_T * y) { SOID_T w, d; NODE_T *tert; MOID_T *n, *ori; int rowdim; BOOL_T is_ref; if (IS (p, TERTIARY)) { make_soid (&w, STRONG, MODE (INT), 0); mode_check_unit (p, &w, &d); if (!is_coercible_in_context (&d, &w, SAFE_DEFLEXING)) { cannot_coerce (p, MOID (&d), MOID (&w), MEEK, SAFE_DEFLEXING, 0); } tert = NEXT_NEXT (p); } else { tert = NEXT (p); } make_soid (&w, WEAK, NO_MOID, 0); mode_check_unit (tert, &w, &d); n = ori = determine_unique_mode (&d, SAFE_DEFLEXING); while (IS (n, REF_SYMBOL) && !is_ref_row (n)) { n = depref_once (n); } if (n != NO_MOID && (IS (n, FLEX_SYMBOL) || IS_REF_FLEX (n))) { if (IF_MODE_IS_WELL (n)) { diagnostic_node (A68_ERROR, p, ERROR_NO_FLEX_ARGUMENT, ori, TERTIARY); } make_soid (y, SORT (x), MODE (ERROR), 0); return; } if (n == NO_MOID || !(SLICE (DEFLEX (n)) != NO_MOID || is_ref_row (n))) { if (IF_MODE_IS_WELL (n)) { diagnostic_node (A68_ERROR, p, ERROR_NO_VECTOR, ori, TERTIARY); } make_soid (y, SORT (x), MODE (ERROR), 0); return; } if ((is_ref = is_ref_row (n)) != A68_FALSE) { rowdim = DIM (DEFLEX (SUB (n))); } else { rowdim = DIM (DEFLEX (n)); } if (rowdim != 1) { diagnostic_node (A68_ERROR, p, ERROR_NO_VECTOR, ori, TERTIARY); make_soid (y, SORT (x), MODE (ERROR), 0); return; } MOID (tert) = n; ABEND (n == NO_MOID, "No mode in mode_check_diagonal", NO_TEXT); make_soid (y, SORT (x), ROWED (n), 0); } /*! \brief mode check format text \param p position in tree **/ static void mode_check_format_text (NODE_T * p) { for (; p != NO_NODE; FORWARD (p)) { mode_check_format_text (SUB (p)); if (IS (p, FORMAT_PATTERN)) { SOID_T x, y; make_soid (&x, STRONG, MODE (FORMAT), 0); mode_check_enclosed (SUB (NEXT_SUB (p)), &x, &y); if (!is_coercible_in_context (&y, &x, SAFE_DEFLEXING)) { cannot_coerce (p, MOID (&y), MOID (&x), STRONG, SAFE_DEFLEXING, ENCLOSED_CLAUSE); } } else if (IS (p, GENERAL_PATTERN) && NEXT_SUB (p) != NO_NODE) { SOID_T x, y; make_soid (&x, STRONG, MODE (ROW_INT), 0); mode_check_enclosed (SUB (NEXT_SUB (p)), &x, &y); if (!is_coercible_in_context (&y, &x, SAFE_DEFLEXING)) { cannot_coerce (p, MOID (&y), MOID (&x), STRONG, SAFE_DEFLEXING, ENCLOSED_CLAUSE); } } else if (IS (p, DYNAMIC_REPLICATOR)) { SOID_T x, y; make_soid (&x, STRONG, MODE (INT), 0); mode_check_enclosed (SUB (NEXT_SUB (p)), &x, &y); if (!is_coercible_in_context (&y, &x, SAFE_DEFLEXING)) { cannot_coerce (p, MOID (&y), MOID (&x), STRONG, SAFE_DEFLEXING, ENCLOSED_CLAUSE); } } } } /*! \brief mode check unit \param p position in tree \param x expected soid \param y resulting soid **/ static void mode_check_unit (NODE_T * p, SOID_T * x, SOID_T * y) { if (p == NO_NODE) { return; } else if (is_one_of (p, UNIT, TERTIARY, SECONDARY, PRIMARY, STOP)) { mode_check_unit (SUB (p), x, y); /* Ex primary */ } else if (IS (p, SPECIFICATION)) { ATTRIBUTE (p) = mode_check_specification (SUB (p), x, y); warn_for_voiding (p, x, y, ATTRIBUTE (p)); } else if (IS (p, CAST)) { mode_check_cast (SUB (p), x, y); warn_for_voiding (p, x, y, CAST); } else if (IS (p, DENOTATION)) { make_soid (y, SORT (x), MOID (SUB (p)), 0); warn_for_voiding (p, x, y, DENOTATION); } else if (IS (p, IDENTIFIER)) { if ((TAX (p) == NO_TAG) && (MOID (p) == NO_MOID)) { int att = first_tag_global (TABLE (p), NSYMBOL (p)); if (att == STOP) { (void) add_tag (TABLE (p), IDENTIFIER, p, MODE (ERROR), NORMAL_IDENTIFIER); diagnostic_node (A68_ERROR, p, ERROR_UNDECLARED_TAG); MOID (p) = MODE (ERROR); } else { TAG_T *z = find_tag_global (TABLE (p), att, NSYMBOL (p)); if (att == IDENTIFIER && z != NO_TAG) { MOID (p) = MOID (z); } else { (void) add_tag (TABLE (p), IDENTIFIER, p, MODE (ERROR), NORMAL_IDENTIFIER); diagnostic_node (A68_ERROR, p, ERROR_UNDECLARED_TAG); MOID (p) = MODE (ERROR); } } } make_soid (y, SORT (x), MOID (p), 0); warn_for_voiding (p, x, y, IDENTIFIER); } else if (IS (p, ENCLOSED_CLAUSE)) { mode_check_enclosed (SUB (p), x, y); } else if (IS (p, FORMAT_TEXT)) { mode_check_format_text (p); make_soid (y, SORT (x), MODE (FORMAT), 0); warn_for_voiding (p, x, y, FORMAT_TEXT); /* Ex secondary */ } else if (IS (p, GENERATOR)) { mode_check_declarer (SUB (p)); make_soid (y, SORT (x), MOID (SUB (p)), 0); warn_for_voiding (p, x, y, GENERATOR); } else if (IS (p, SELECTION)) { mode_check_selection (SUB (p), x, y); warn_for_voiding (p, x, y, SELECTION); /* Ex tertiary */ } else if (IS (p, NIHIL)) { make_soid (y, STRONG, MODE (HIP), 0); } else if (IS (p, FORMULA)) { mode_check_formula (p, x, y); if (ISNT (MOID (y), REF_SYMBOL)) { warn_for_voiding (p, x, y, FORMULA); } } else if (IS (p, DIAGONAL_FUNCTION)) { mode_check_diagonal (SUB (p), x, y); warn_for_voiding (p, x, y, DIAGONAL_FUNCTION); } else if (IS (p, TRANSPOSE_FUNCTION)) { mode_check_transpose (SUB (p), x, y); warn_for_voiding (p, x, y, TRANSPOSE_FUNCTION); } else if (IS (p, ROW_FUNCTION)) { mode_check_row_column_function (SUB (p), x, y); warn_for_voiding (p, x, y, ROW_FUNCTION); } else if (IS (p, COLUMN_FUNCTION)) { mode_check_row_column_function (SUB (p), x, y); warn_for_voiding (p, x, y, COLUMN_FUNCTION); /* Ex unit */ } else if (is_one_of (p, JUMP, SKIP, STOP)) { make_soid (y, STRONG, MODE (HIP), 0); } else if (IS (p, ASSIGNATION)) { mode_check_assignation (SUB (p), x, y); } else if (IS (p, IDENTITY_RELATION)) { mode_check_identity_relation (SUB (p), x, y); warn_for_voiding (p, x, y, IDENTITY_RELATION); } else if (IS (p, ROUTINE_TEXT)) { mode_check_routine_text (SUB (p), y); make_soid (y, SORT (x), MOID (p), 0); warn_for_voiding (p, x, y, ROUTINE_TEXT); } else if (IS (p, ASSERTION)) { mode_check_assertion (SUB (p)); make_soid (y, STRONG, MODE (VOID), 0); } else if (IS (p, AND_FUNCTION)) { mode_check_bool_function (SUB (p), x, y); warn_for_voiding (p, x, y, AND_FUNCTION); } else if (IS (p, OR_FUNCTION)) { mode_check_bool_function (SUB (p), x, y); warn_for_voiding (p, x, y, OR_FUNCTION); } else if (IS (p, CODE_CLAUSE)) { make_soid (y, STRONG, MODE (HIP), 0); } MOID (p) = MOID (y); } /*! \brief coerce bounds \param p position in tree **/ static void coerce_bounds (NODE_T * p) { for (; p != NO_NODE; FORWARD (p)) { if (IS (p, UNIT)) { SOID_T q; make_soid (&q, MEEK, MODE (INT), 0); coerce_unit (p, &q); } else { coerce_bounds (SUB (p)); } } } /*! \brief coerce declarer \param p position in tree **/ static void coerce_declarer (NODE_T * p) { for (; p != NO_NODE; FORWARD (p)) { if (IS (p, BOUNDS)) { coerce_bounds (SUB (p)); } else { coerce_declarer (SUB (p)); } } } /*! \brief coerce identity declaration \param p position in tree **/ static void coerce_identity_declaration (NODE_T * p) { if (p != NO_NODE) { switch (ATTRIBUTE (p)) { case DECLARER: { coerce_declarer (SUB (p)); coerce_identity_declaration (NEXT (p)); break; } case DEFINING_IDENTIFIER: { SOID_T q; make_soid (&q, STRONG, MOID (p), 0); coerce_unit (NEXT_NEXT (p), &q); break; } default: { coerce_identity_declaration (SUB (p)); coerce_identity_declaration (NEXT (p)); break; } } } } /*! \brief coerce variable declaration \param p position in tree **/ static void coerce_variable_declaration (NODE_T * p) { if (p != NO_NODE) { switch (ATTRIBUTE (p)) { case DECLARER: { coerce_declarer (SUB (p)); coerce_variable_declaration (NEXT (p)); break; } case DEFINING_IDENTIFIER: { if (whether (p, DEFINING_IDENTIFIER, ASSIGN_SYMBOL, UNIT, STOP)) { SOID_T q; make_soid (&q, STRONG, SUB_MOID (p), 0); coerce_unit (NEXT_NEXT (p), &q); break; } } default: { coerce_variable_declaration (SUB (p)); coerce_variable_declaration (NEXT (p)); break; } } } } /*! \brief coerce routine text \param p position in tree **/ static void coerce_routine_text (NODE_T * p) { SOID_T w; if (IS (p, PARAMETER_PACK)) { FORWARD (p); } make_soid (&w, STRONG, MOID (p), 0); coerce_unit (NEXT_NEXT (p), &w); } /*! \brief coerce proc declaration \param p position in tree **/ static void coerce_proc_declaration (NODE_T * p) { if (p == NO_NODE) { return; } else if (IS (p, ROUTINE_TEXT)) { coerce_routine_text (SUB (p)); } else { coerce_proc_declaration (SUB (p)); coerce_proc_declaration (NEXT (p)); } } /*! \brief coerce_op_declaration \param p position in tree **/ static void coerce_op_declaration (NODE_T * p) { if (p == NO_NODE) { return; } else if (IS (p, DEFINING_OPERATOR)) { SOID_T q; make_soid (&q, STRONG, MOID (p), 0); coerce_unit (NEXT_NEXT (p), &q); } else { coerce_op_declaration (SUB (p)); coerce_op_declaration (NEXT (p)); } } /*! \brief coerce brief op declaration \param p position in tree **/ static void coerce_brief_op_declaration (NODE_T * p) { if (p == NO_NODE) { return; } else if (IS (p, DEFINING_OPERATOR)) { coerce_routine_text (SUB (NEXT_NEXT (p))); } else { coerce_brief_op_declaration (SUB (p)); coerce_brief_op_declaration (NEXT (p)); } } /*! \brief coerce declaration list \param p position in tree **/ static void coerce_declaration_list (NODE_T * p) { if (p != NO_NODE) { switch (ATTRIBUTE (p)) { case IDENTITY_DECLARATION: { coerce_identity_declaration (SUB (p)); break; } case VARIABLE_DECLARATION: { coerce_variable_declaration (SUB (p)); break; } case MODE_DECLARATION: { coerce_declarer (SUB (p)); break; } case PROCEDURE_DECLARATION: case PROCEDURE_VARIABLE_DECLARATION: { coerce_proc_declaration (SUB (p)); break; } case BRIEF_OPERATOR_DECLARATION: { coerce_brief_op_declaration (SUB (p)); break; } case OPERATOR_DECLARATION: { coerce_op_declaration (SUB (p)); break; } default: { coerce_declaration_list (SUB (p)); coerce_declaration_list (NEXT (p)); break; } } } } /*! \brief coerce serial \param p position in tree \param q soid \param k whether k yields value other than VOID **/ static void coerce_serial (NODE_T * p, SOID_T * q, BOOL_T k) { if (p == NO_NODE) { return; } else if (IS (p, INITIALISER_SERIES)) { coerce_serial (SUB (p), q, A68_FALSE); coerce_serial (NEXT (p), q, k); } else if (IS (p, DECLARATION_LIST)) { coerce_declaration_list (SUB (p)); } else if (is_one_of (p, LABEL, SEMI_SYMBOL, EXIT_SYMBOL, STOP)) { coerce_serial (NEXT (p), q, k); } else if (is_one_of (p, SERIAL_CLAUSE, ENQUIRY_CLAUSE, STOP)) { NODE_T *z = NEXT (p); if (z != NO_NODE) { if (IS (z, EXIT_SYMBOL) || IS (z, END_SYMBOL) || IS (z, CLOSE_SYMBOL) || IS (z, OCCA_SYMBOL)) { coerce_serial (SUB (p), q, A68_TRUE); } else { coerce_serial (SUB (p), q, A68_FALSE); } } else { coerce_serial (SUB (p), q, A68_TRUE); } coerce_serial (NEXT (p), q, k); } else if (IS (p, LABELED_UNIT)) { coerce_serial (SUB (p), q, k); } else if (IS (p, UNIT)) { if (k) { coerce_unit (p, q); } else { SOID_T strongvoid; make_soid (&strongvoid, STRONG, MODE (VOID), 0); coerce_unit (p, &strongvoid); } } } /*! \brief coerce closed \param p position in tree \param q soid **/ static void coerce_closed (NODE_T * p, SOID_T * q) { if (IS (p, SERIAL_CLAUSE)) { coerce_serial (p, q, A68_TRUE); } else if (is_one_of (p, OPEN_SYMBOL, BEGIN_SYMBOL, STOP)) { coerce_closed (NEXT (p), q); } } /*! \brief coerce conditional \param p position in tree \param q soid **/ static void coerce_conditional (NODE_T * p, SOID_T * q) { SOID_T w; make_soid (&w, MEEK, MODE (BOOL), 0); coerce_serial (NEXT_SUB (p), &w, A68_TRUE); FORWARD (p); coerce_serial (NEXT_SUB (p), q, A68_TRUE); if ((FORWARD (p)) != NO_NODE) { if (is_one_of (p, ELSE_PART, CHOICE, STOP)) { coerce_serial (NEXT_SUB (p), q, A68_TRUE); } else if (is_one_of (p, ELIF_PART, BRIEF_ELIF_PART, STOP)) { coerce_conditional (SUB (p), q); } } } /*! \brief coerce unit list \param p position in tree \param q soid **/ static void coerce_unit_list (NODE_T * p, SOID_T * q) { if (p == NO_NODE) { return; } else if (IS (p, UNIT_LIST)) { coerce_unit_list (SUB (p), q); coerce_unit_list (NEXT (p), q); } else if (is_one_of (p, OPEN_SYMBOL, BEGIN_SYMBOL, COMMA_SYMBOL, STOP)) { coerce_unit_list (NEXT (p), q); } else if (IS (p, UNIT)) { coerce_unit (p, q); coerce_unit_list (NEXT (p), q); } } /*! \brief coerce int case \param p position in tree \param q soid **/ static void coerce_int_case (NODE_T * p, SOID_T * q) { SOID_T w; make_soid (&w, MEEK, MODE (INT), 0); coerce_serial (NEXT_SUB (p), &w, A68_TRUE); FORWARD (p); coerce_unit_list (NEXT_SUB (p), q); if ((FORWARD (p)) != NO_NODE) { if (is_one_of (p, OUT_PART, CHOICE, STOP)) { coerce_serial (NEXT_SUB (p), q, A68_TRUE); } else if (is_one_of (p, CASE_OUSE_PART, BRIEF_OUSE_PART, STOP)) { coerce_int_case (SUB (p), q); } } } /*! \brief coerce spec unit list \param p position in tree \param q soid **/ static void coerce_spec_unit_list (NODE_T * p, SOID_T * q) { for (; p != NO_NODE; FORWARD (p)) { if (is_one_of (p, SPECIFIED_UNIT_LIST, SPECIFIED_UNIT, STOP)) { coerce_spec_unit_list (SUB (p), q); } else if (IS (p, UNIT)) { coerce_unit (p, q); } } } /*! \brief coerce united case \param p position in tree \param q soid **/ static void coerce_united_case (NODE_T * p, SOID_T * q) { SOID_T w; make_soid (&w, MEEK, MOID (SUB (p)), 0); coerce_serial (NEXT_SUB (p), &w, A68_TRUE); FORWARD (p); coerce_spec_unit_list (NEXT_SUB (p), q); if ((FORWARD (p)) != NO_NODE) { if (is_one_of (p, OUT_PART, CHOICE, STOP)) { coerce_serial (NEXT_SUB (p), q, A68_TRUE); } else if (is_one_of (p, CONFORMITY_OUSE_PART, BRIEF_CONFORMITY_OUSE_PART, STOP)) { coerce_united_case (SUB (p), q); } } } /*! \brief coerce loop \param p position in tree **/ static void coerce_loop (NODE_T * p) { if (IS (p, FOR_PART)) { coerce_loop (NEXT (p)); } else if (is_one_of (p, FROM_PART, BY_PART, TO_PART, STOP)) { SOID_T w; make_soid (&w, MEEK, MODE (INT), 0); coerce_unit (NEXT_SUB (p), &w); coerce_loop (NEXT (p)); } else if (IS (p, WHILE_PART)) { SOID_T w; make_soid (&w, MEEK, MODE (BOOL), 0); coerce_serial (NEXT_SUB (p), &w, A68_TRUE); coerce_loop (NEXT (p)); } else if (is_one_of (p, DO_PART, ALT_DO_PART, STOP)) { SOID_T w; NODE_T *do_p = NEXT_SUB (p), *un_p; make_soid (&w, STRONG, MODE (VOID), 0); coerce_serial (do_p, &w, A68_TRUE); if (IS (do_p, SERIAL_CLAUSE)) { un_p = NEXT (do_p); } else { un_p = do_p; } if (un_p != NO_NODE && IS (un_p, UNTIL_PART)) { SOID_T sw; make_soid (&sw, MEEK, MODE (BOOL), 0); coerce_serial (NEXT_SUB (un_p), &sw, A68_TRUE); } } } /*! \brief coerce struct display \param r pack \param p position in tree **/ static void coerce_struct_display (PACK_T ** r, NODE_T * p) { if (p == NO_NODE) { return; } else if (IS (p, UNIT_LIST)) { coerce_struct_display (r, SUB (p)); coerce_struct_display (r, NEXT (p)); } else if (is_one_of (p, OPEN_SYMBOL, BEGIN_SYMBOL, COMMA_SYMBOL, STOP)) { coerce_struct_display (r, NEXT (p)); } else if (IS (p, UNIT)) { SOID_T s; make_soid (&s, STRONG, MOID (*r), 0); coerce_unit (p, &s); FORWARD (*r); coerce_struct_display (r, NEXT (p)); } } /*! \brief coerce collateral \param p position in tree \param q soid **/ static void coerce_collateral (NODE_T * p, SOID_T * q) { if (!(whether (p, BEGIN_SYMBOL, END_SYMBOL, STOP) || whether (p, OPEN_SYMBOL, CLOSE_SYMBOL, STOP))) { if (IS (MOID (q), STRUCT_SYMBOL)) { PACK_T *t = PACK (MOID (q)); coerce_struct_display (&t, p); } else if (IS (MOID (q), FLEX_SYMBOL)) { SOID_T w; make_soid (&w, STRONG, SLICE (SUB_MOID (q)), 0); coerce_unit_list (p, &w); } else if (IS (MOID (q), ROW_SYMBOL)) { SOID_T w; make_soid (&w, STRONG, SLICE (MOID (q)), 0); coerce_unit_list (p, &w); } else { /* if (MOID (q) != MODE (VOID)) */ coerce_unit_list (p, q); } } } /*! \brief coerce_enclosed \param p position in tree \param q soid **/ void coerce_enclosed (NODE_T * p, SOID_T * q) { if (IS (p, ENCLOSED_CLAUSE)) { coerce_enclosed (SUB (p), q); } else if (IS (p, CLOSED_CLAUSE)) { coerce_closed (SUB (p), q); } else if (IS (p, COLLATERAL_CLAUSE)) { coerce_collateral (SUB (p), q); } else if (IS (p, PARALLEL_CLAUSE)) { coerce_collateral (SUB (NEXT_SUB (p)), q); } else if (IS (p, CONDITIONAL_CLAUSE)) { coerce_conditional (SUB (p), q); } else if (IS (p, CASE_CLAUSE)) { coerce_int_case (SUB (p), q); } else if (IS (p, CONFORMITY_CLAUSE)) { coerce_united_case (SUB (p), q); } else if (IS (p, LOOP_CLAUSE)) { coerce_loop (SUB (p)); } MOID (p) = depref_rows (MOID (p), MOID (q)); } /*! \brief get monad moid \param p position in tree **/ static MOID_T *get_monad_moid (NODE_T * p) { if (TAX (p) != NO_TAG && TAX (p) != error_tag) { MOID (p) = MOID (TAX (p)); return (MOID (PACK (MOID (p)))); } else { return (MODE (ERROR)); } } /*! \brief coerce monad oper \param p position in tree \param q soid **/ static void coerce_monad_oper (NODE_T * p, SOID_T * q) { if (p != NO_NODE) { SOID_T z; make_soid (&z, FIRM, MOID (PACK (MOID (TAX (p)))), 0); INSERT_COERCIONS (NEXT (p), MOID (q), &z); } } /*! \brief coerce monad formula \param p position in tree **/ static void coerce_monad_formula (NODE_T * p) { SOID_T e; make_soid (&e, STRONG, get_monad_moid (p), 0); coerce_operand (NEXT (p), &e); coerce_monad_oper (p, &e); } /*! \brief coerce operand \param p position in tree \param q soid **/ static void coerce_operand (NODE_T * p, SOID_T * q) { if (IS (p, MONADIC_FORMULA)) { coerce_monad_formula (SUB (p)); if (MOID (p) != MOID (q)) { make_sub (p, p, FORMULA); INSERT_COERCIONS (p, MOID (p), q); make_sub (p, p, TERTIARY); } MOID (p) = depref_rows (MOID (p), MOID (q)); } else if (IS (p, FORMULA)) { coerce_formula (SUB (p), q); INSERT_COERCIONS (p, MOID (p), q); MOID (p) = depref_rows (MOID (p), MOID (q)); } else if (IS (p, SECONDARY)) { coerce_unit (SUB (p), q); MOID (p) = MOID (SUB (p)); } } /*! \brief coerce formula \param p position in tree \param q soid **/ static void coerce_formula (NODE_T * p, SOID_T * q) { (void) q; if (IS (p, MONADIC_FORMULA) && NEXT (p) == NO_NODE) { coerce_monad_formula (SUB (p)); } else { if (TAX (NEXT (p)) != NO_TAG && TAX (NEXT (p)) != error_tag) { SOID_T s; NODE_T *op = NEXT (p), *nq = NEXT_NEXT (p); MOID_T *w = MOID (op); MOID_T *u = MOID (PACK (w)), *v = MOID (NEXT (PACK (w))); make_soid (&s, STRONG, u, 0); coerce_operand (p, &s); make_soid (&s, STRONG, v, 0); coerce_operand (nq, &s); } } } /*! \brief coerce assignation \param p position in tree **/ static void coerce_assignation (NODE_T * p) { SOID_T w; make_soid (&w, SOFT, MOID (p), 0); coerce_unit (SUB (p), &w); make_soid (&w, STRONG, SUB_MOID (p), 0); coerce_unit (NEXT_NEXT (p), &w); } /*! \brief coerce relation \param p position in tree **/ static void coerce_relation (NODE_T * p) { SOID_T w; make_soid (&w, STRONG, MOID (p), 0); coerce_unit (SUB (p), &w); make_soid (&w, STRONG, MOID (NEXT_NEXT (p)), 0); coerce_unit (SUB (NEXT_NEXT (p)), &w); } /*! \brief coerce bool function \param p position in tree **/ static void coerce_bool_function (NODE_T * p) { SOID_T w; make_soid (&w, STRONG, MODE (BOOL), 0); coerce_unit (SUB (p), &w); coerce_unit (SUB (NEXT_NEXT (p)), &w); } /*! \brief coerce assertion \param p position in tree **/ static void coerce_assertion (NODE_T * p) { SOID_T w; make_soid (&w, MEEK, MODE (BOOL), 0); coerce_enclosed (SUB_NEXT (p), &w); } /*! \brief coerce selection \param p position in tree **/ static void coerce_selection (NODE_T * p) { SOID_T w; make_soid (&w, /* WEAK */ STRONG, MOID (NEXT (p)), 0); coerce_unit (SUB_NEXT (p), &w); } /*! \brief coerce cast \param p position in tree **/ static void coerce_cast (NODE_T * p) { SOID_T w; coerce_declarer (p); make_soid (&w, STRONG, MOID (p), 0); coerce_enclosed (NEXT (p), &w); } /*! \brief coerce argument list \param r pack \param p position in tree **/ static void coerce_argument_list (PACK_T ** r, NODE_T * p) { for (; p != NO_NODE; FORWARD (p)) { if (IS (p, ARGUMENT_LIST)) { coerce_argument_list (r, SUB (p)); } else if (IS (p, UNIT)) { SOID_T s; make_soid (&s, STRONG, MOID (*r), 0); coerce_unit (p, &s); FORWARD (*r); } else if (IS (p, TRIMMER)) { FORWARD (*r); } } } /*! \brief coerce call \param p position in tree **/ static void coerce_call (NODE_T * p) { MOID_T *proc = MOID (p); SOID_T w; PACK_T *t; make_soid (&w, MEEK, proc, 0); coerce_unit (SUB (p), &w); FORWARD (p); t = PACK (proc); coerce_argument_list (&t, SUB (p)); } /*! \brief coerce meek int \param p position in tree **/ static void coerce_meek_int (NODE_T * p) { SOID_T x; make_soid (&x, MEEK, MODE (INT), 0); coerce_unit (p, &x); } /*! \brief coerce trimmer \param p position in tree **/ static void coerce_trimmer (NODE_T * p) { if (p != NO_NODE) { if (IS (p, UNIT)) { coerce_meek_int (p); coerce_trimmer (NEXT (p)); } else { coerce_trimmer (NEXT (p)); } } } /*! \brief coerce indexer \param p position in tree **/ static void coerce_indexer (NODE_T * p) { if (p != NO_NODE) { if (IS (p, TRIMMER)) { coerce_trimmer (SUB (p)); } else if (IS (p, UNIT)) { coerce_meek_int (p); } else { coerce_indexer (SUB (p)); coerce_indexer (NEXT (p)); } } } /*! \brief coerce_slice \param p position in tree **/ static void coerce_slice (NODE_T * p) { SOID_T w; MOID_T *row; row = MOID (p); make_soid (&w, /* WEAK */ STRONG, row, 0); coerce_unit (SUB (p), &w); coerce_indexer (SUB_NEXT (p)); } /*! \brief mode coerce diagonal \param p position in tree **/ static void coerce_diagonal (NODE_T * p) { SOID_T w; if (IS (p, TERTIARY)) { make_soid (&w, MEEK, MODE (INT), 0); coerce_unit (SUB (p), &w); FORWARD (p); } make_soid (&w, /* WEAK */ STRONG, MOID (NEXT (p)), 0); coerce_unit (SUB_NEXT (p), &w); } /*! \brief mode coerce transpose \param p position in tree **/ static void coerce_transpose (NODE_T * p) { SOID_T w; make_soid (&w, /* WEAK */ STRONG, MOID (NEXT (p)), 0); coerce_unit (SUB_NEXT (p), &w); } /*! \brief mode coerce row or column function \param p position in tree **/ static void coerce_row_column_function (NODE_T * p) { SOID_T w; if (IS (p, TERTIARY)) { make_soid (&w, MEEK, MODE (INT), 0); coerce_unit (SUB (p), &w); FORWARD (p); } make_soid (&w, /* WEAK */ STRONG, MOID (NEXT (p)), 0); coerce_unit (SUB_NEXT (p), &w); } /*! \brief coerce format text \param p position in tree **/ static void coerce_format_text (NODE_T * p) { for (; p != NO_NODE; FORWARD (p)) { coerce_format_text (SUB (p)); if (IS (p, FORMAT_PATTERN)) { SOID_T x; make_soid (&x, STRONG, MODE (FORMAT), 0); coerce_enclosed (SUB (NEXT_SUB (p)), &x); } else if (IS (p, GENERAL_PATTERN) && NEXT_SUB (p) != NO_NODE) { SOID_T x; make_soid (&x, STRONG, MODE (ROW_INT), 0); coerce_enclosed (SUB (NEXT_SUB (p)), &x); } else if (IS (p, DYNAMIC_REPLICATOR)) { SOID_T x; make_soid (&x, STRONG, MODE (INT), 0); coerce_enclosed (SUB (NEXT_SUB (p)), &x); } } } /*! \brief coerce unit \param p position in tree \param q soid **/ static void coerce_unit (NODE_T * p, SOID_T * q) { if (p == NO_NODE) { return; } else if (is_one_of (p, UNIT, TERTIARY, SECONDARY, PRIMARY, STOP)) { coerce_unit (SUB (p), q); MOID (p) = MOID (SUB (p)); /* Ex primary */ } else if (IS (p, CALL)) { coerce_call (SUB (p)); INSERT_COERCIONS (p, MOID (p), q); } else if (IS (p, SLICE)) { coerce_slice (SUB (p)); INSERT_COERCIONS (p, MOID (p), q); } else if (IS (p, CAST)) { coerce_cast (SUB (p)); INSERT_COERCIONS (p, MOID (p), q); } else if (is_one_of (p, DENOTATION, IDENTIFIER, STOP)) { INSERT_COERCIONS (p, MOID (p), q); } else if (IS (p, FORMAT_TEXT)) { coerce_format_text (SUB (p)); INSERT_COERCIONS (p, MOID (p), q); } else if (IS (p, ENCLOSED_CLAUSE)) { coerce_enclosed (p, q); /* Ex secondary */ } else if (IS (p, SELECTION)) { coerce_selection (SUB (p)); INSERT_COERCIONS (p, MOID (p), q); } else if (IS (p, GENERATOR)) { coerce_declarer (SUB (p)); INSERT_COERCIONS (p, MOID (p), q); /* Ex tertiary */ } else if (IS (p, NIHIL)) { if (ATTRIBUTE (MOID (q)) != REF_SYMBOL && MOID (q) != MODE (VOID)) { diagnostic_node (A68_ERROR, p, ERROR_NO_NAME_REQUIRED); } MOID (p) = depref_rows (MOID (p), MOID (q)); } else if (IS (p, FORMULA)) { coerce_formula (SUB (p), q); INSERT_COERCIONS (p, MOID (p), q); } else if (IS (p, DIAGONAL_FUNCTION)) { coerce_diagonal (SUB (p)); INSERT_COERCIONS (p, MOID (p), q); } else if (IS (p, TRANSPOSE_FUNCTION)) { coerce_transpose (SUB (p)); INSERT_COERCIONS (p, MOID (p), q); } else if (IS (p, ROW_FUNCTION)) { coerce_row_column_function (SUB (p)); INSERT_COERCIONS (p, MOID (p), q); } else if (IS (p, COLUMN_FUNCTION)) { coerce_row_column_function (SUB (p)); INSERT_COERCIONS (p, MOID (p), q); /* Ex unit */ } else if (IS (p, JUMP)) { if (MOID (q) == MODE (PROC_VOID)) { make_sub (p, p, PROCEDURING); } MOID (p) = depref_rows (MOID (p), MOID (q)); } else if (IS (p, SKIP)) { MOID (p) = depref_rows (MOID (p), MOID (q)); } else if (IS (p, ASSIGNATION)) { coerce_assignation (SUB (p)); INSERT_COERCIONS (p, MOID (p), q); MOID (p) = depref_rows (MOID (p), MOID (q)); } else if (IS (p, IDENTITY_RELATION)) { coerce_relation (SUB (p)); INSERT_COERCIONS (p, MOID (p), q); } else if (IS (p, ROUTINE_TEXT)) { coerce_routine_text (SUB (p)); INSERT_COERCIONS (p, MOID (p), q); } else if (is_one_of (p, AND_FUNCTION, OR_FUNCTION, STOP)) { coerce_bool_function (SUB (p)); INSERT_COERCIONS (p, MOID (p), q); } else if (IS (p, ASSERTION)) { coerce_assertion (SUB (p)); INSERT_COERCIONS (p, MOID (p), q); } } /*! \brief widen denotation depending on mode required, this is an extension to A68 \param p position in tree **/ void widen_denotation (NODE_T * p) { #define WIDEN {\ *q = *(SUB (q));\ ATTRIBUTE (q) = DENOTATION;\ MOID (q) = lm;\ STATUS_SET (q, OPTIMAL_MASK);\ } #define WARN_WIDENING\ if (OPTION_PORTCHECK (&program) && !(STATUS_TEST (SUB (q), OPTIMAL_MASK))) {\ diagnostic_node (A68_WARNING | A68_FORCE_DIAGNOSTICS, q, WARNING_WIDENING_NOT_PORTABLE);\ } NODE_T *q; for (q = p; q != NO_NODE; FORWARD (q)) { widen_denotation (SUB (q)); if (IS (q, WIDENING) && IS (SUB (q), DENOTATION)) { MOID_T *lm = MOID (q), *m = MOID (SUB (q)); if (lm == MODE (LONGLONG_INT) && m == MODE (LONG_INT)) { WARN_WIDENING; WIDEN; } if (lm == MODE (LONG_INT) && m == MODE (INT)) { WARN_WIDENING; WIDEN; } if (lm == MODE (LONGLONG_REAL) && m == MODE (LONG_REAL)) { WARN_WIDENING; WIDEN; } if (lm == MODE (LONG_REAL) && m == MODE (REAL)) { WARN_WIDENING; WIDEN; } if (lm == MODE (LONG_REAL) && m == MODE (LONG_INT)) { WIDEN; } if (lm == MODE (REAL) && m == MODE (INT)) { WIDEN; } if (lm == MODE (LONGLONG_BITS) && m == MODE (LONG_BITS)) { WARN_WIDENING; WIDEN; } if (lm == MODE (LONG_BITS) && m == MODE (BITS)) { WARN_WIDENING; WIDEN; } return; } } #undef WIDEN #undef WARN_WIDENING } /********************************************************************/ /* Static scope checker, at run time we check dynamic scope as well */ /********************************************************************/ /* Static scope checker. Also a little preparation for the monitor: - indicates UNITs that can be interrupted. */ /*! \brief scope_make_tuple \param e level \param t whether transient \return tuple (e, t) **/ static TUPLE_T scope_make_tuple (int e, int t) { static TUPLE_T z; LEVEL (&z) = e; TRANSIENT (&z) = (BOOL_T) t; return (z); } /*! \brief link scope information into the list \param sl chain to link into \param p position in tree \param tup tuple to link **/ static void scope_add (SCOPE_T ** sl, NODE_T * p, TUPLE_T tup) { if (sl != NO_VAR) { SCOPE_T *ns = (SCOPE_T *) get_temp_heap_space ((unsigned) ALIGNED_SIZE_OF (SCOPE_T)); WHERE (ns) = p; TUPLE (ns) = tup; NEXT (ns) = *sl; *sl = ns; } } /*! \brief scope_check \param top top of scope chain \param mask what to check \param dest level to check against \return whether errors were detected **/ static BOOL_T scope_check (SCOPE_T * top, int mask, int dest) { SCOPE_T *s; int errors = 0; /* Transient names cannot be stored */ if (mask & TRANSIENT) { for (s = top; s != NO_SCOPE; FORWARD (s)) { if (TRANSIENT (&TUPLE (s)) & TRANSIENT) { diagnostic_node (A68_ERROR, WHERE (s), ERROR_TRANSIENT_NAME); STATUS_SET (WHERE (s), SCOPE_ERROR_MASK); errors++; } } } for (s = top; s != NO_SCOPE; FORWARD (s)) { if (dest < LEVEL (&TUPLE (s)) && ! STATUS_TEST (WHERE (s), SCOPE_ERROR_MASK)) { /* Potential scope violations */ MOID_T *sw = MOID (WHERE (s)); if (sw != NO_MOID) { if (IS (sw, REF_SYMBOL) || IS (sw, PROC_SYMBOL) || IS (sw, FORMAT_SYMBOL) || IS (sw, UNION_SYMBOL)) { diagnostic_node (A68_WARNING, WHERE (s), WARNING_SCOPE_STATIC, MOID (WHERE (s)), ATTRIBUTE (WHERE (s))); } } STATUS_SET (WHERE (s), SCOPE_ERROR_MASK); errors++; } } return ((BOOL_T) (errors == 0)); } /*! \brief scope_check_multiple \param top top of scope chain \param mask what to check \param dest level to check against \return whether error **/ static BOOL_T scope_check_multiple (SCOPE_T * top, int mask, SCOPE_T * dest) { BOOL_T no_err = A68_TRUE; for (; dest != NO_SCOPE; FORWARD (dest)) { no_err &= scope_check (top, mask, LEVEL (&TUPLE (dest))); } return (no_err); } /*! \brief check_identifier_usage \param t tag \param p position in tree **/ static void check_identifier_usage (TAG_T * t, NODE_T * p) { for (; p != NO_NODE; FORWARD (p)) { if (IS (p, IDENTIFIER) && TAX (p) == t && ATTRIBUTE (MOID (t)) != PROC_SYMBOL) { diagnostic_node (A68_WARNING, p, WARNING_UNINITIALISED); } check_identifier_usage (t, SUB (p)); } } /*! \brief scope_find_youngest_outside \param s chain to link into \param treshold threshold level \return youngest tuple outside **/ static TUPLE_T scope_find_youngest_outside (SCOPE_T * s, int treshold) { TUPLE_T z = scope_make_tuple (PRIMAL_SCOPE, NOT_TRANSIENT); for (; s != NO_SCOPE; FORWARD (s)) { if (LEVEL (&TUPLE (s)) > LEVEL (&z) && LEVEL (&TUPLE (s)) <= treshold) { z = TUPLE (s); } } return (z); } /*! \brief scope_find_youngest \param s chain to link into \return youngest tuple outside **/ static TUPLE_T scope_find_youngest (SCOPE_T * s) { return (scope_find_youngest_outside (s, A68_MAX_INT)); } /* Routines for determining scope of ROUTINE TEXT or FORMAT TEXT */ /*! \brief get_declarer_elements \param p position in tree \param r chain to link into \param no_ref whether no REF seen yet **/ static void get_declarer_elements (NODE_T * p, SCOPE_T ** r, BOOL_T no_ref) { if (p != NO_NODE) { if (IS (p, BOUNDS)) { gather_scopes_for_youngest (SUB (p), r); } else if (IS (p, INDICANT)) { if (MOID (p) != NO_MOID && TAX (p) != NO_TAG && HAS_ROWS (MOID (p)) && no_ref) { scope_add (r, p, scope_make_tuple (TAG_LEX_LEVEL (TAX (p)), NOT_TRANSIENT)); } } else if (IS (p, REF_SYMBOL)) { get_declarer_elements (NEXT (p), r, A68_FALSE); } else if (is_one_of (p, PROC_SYMBOL, UNION_SYMBOL, STOP)) { ; } else { get_declarer_elements (SUB (p), r, no_ref); get_declarer_elements (NEXT (p), r, no_ref); } } } /*! \brief gather_scopes_for_youngest \param p position in tree \param s chain to link into **/ static void gather_scopes_for_youngest (NODE_T * p, SCOPE_T ** s) { for (; p != NO_NODE; FORWARD (p)) { if ((is_one_of (p, ROUTINE_TEXT, FORMAT_TEXT, STOP)) && (YOUNGEST_ENVIRON (TAX (p)) == PRIMAL_SCOPE)) { SCOPE_T *t = NO_SCOPE; TUPLE_T tup; gather_scopes_for_youngest (SUB (p), &t); tup = scope_find_youngest_outside (t, LEX_LEVEL (p)); YOUNGEST_ENVIRON (TAX (p)) = LEVEL (&tup); /* Direct link into list iso "gather_scopes_for_youngest (SUB (p), s);" */ if (t != NO_SCOPE) { SCOPE_T *u = t; while (NEXT (u) != NO_SCOPE) { FORWARD (u); } NEXT (u) = *s; (*s) = t; } } else if (is_one_of (p, IDENTIFIER, OPERATOR, STOP)) { if (TAX (p) != NO_TAG && TAG_LEX_LEVEL (TAX (p)) != PRIMAL_SCOPE) { scope_add (s, p, scope_make_tuple (TAG_LEX_LEVEL (TAX (p)), NOT_TRANSIENT)); } } else if (IS (p, DECLARER)) { get_declarer_elements (p, s, A68_TRUE); } else { gather_scopes_for_youngest (SUB (p), s); } } } /*! \brief get_youngest_environs \param p position in tree **/ static void get_youngest_environs (NODE_T * p) { for (; p != NO_NODE; FORWARD (p)) { if (is_one_of (p, ROUTINE_TEXT, FORMAT_TEXT, STOP)) { SCOPE_T *s = NO_SCOPE; TUPLE_T tup; gather_scopes_for_youngest (SUB (p), &s); tup = scope_find_youngest_outside (s, LEX_LEVEL (p)); YOUNGEST_ENVIRON (TAX (p)) = LEVEL (&tup); } else { get_youngest_environs (SUB (p)); } } } /*! \brief bind_scope_to_tag \param p position in tree **/ static void bind_scope_to_tag (NODE_T * p) { for (; p != NO_NODE; FORWARD (p)) { if (IS (p, DEFINING_IDENTIFIER) && MOID (p) == MODE (FORMAT)) { if (IS (NEXT_NEXT (p), FORMAT_TEXT)) { SCOPE (TAX (p)) = YOUNGEST_ENVIRON (TAX (NEXT_NEXT (p))); SCOPE_ASSIGNED (TAX (p)) = A68_TRUE; } return; } else if (IS (p, DEFINING_IDENTIFIER)) { if (IS (NEXT_NEXT (p), ROUTINE_TEXT)) { SCOPE (TAX (p)) = YOUNGEST_ENVIRON (TAX (NEXT_NEXT (p))); SCOPE_ASSIGNED (TAX (p)) = A68_TRUE; } return; } else { bind_scope_to_tag (SUB (p)); } } } /*! \brief bind_scope_to_tags \param p position in tree **/ static void bind_scope_to_tags (NODE_T * p) { for (; p != NO_NODE; FORWARD (p)) { if (is_one_of (p, PROCEDURE_DECLARATION, IDENTITY_DECLARATION, STOP)) { bind_scope_to_tag (SUB (p)); } else { bind_scope_to_tags (SUB (p)); } } } /*! \brief scope_bounds \param p position in tree **/ static void scope_bounds (NODE_T * p) { for (; p != NO_NODE; FORWARD (p)) { if (IS (p, UNIT)) { scope_statement (p, NO_VAR); } else { scope_bounds (SUB (p)); } } } /*! \brief scope_declarer \param p position in tree **/ static void scope_declarer (NODE_T * p) { if (p != NO_NODE) { if (IS (p, BOUNDS)) { scope_bounds (SUB (p)); } else if (IS (p, INDICANT)) { ; } else if (IS (p, REF_SYMBOL)) { scope_declarer (NEXT (p)); } else if (is_one_of (p, PROC_SYMBOL, UNION_SYMBOL, STOP)) { ; } else { scope_declarer (SUB (p)); scope_declarer (NEXT (p)); } } } /*! \brief scope_identity_declaration \param p position in tree **/ static void scope_identity_declaration (NODE_T * p) { for (; p != NO_NODE; FORWARD (p)) { scope_identity_declaration (SUB (p)); if (IS (p, DEFINING_IDENTIFIER)) { NODE_T *unit = NEXT_NEXT (p); SCOPE_T *s = NO_SCOPE; TUPLE_T tup; int z = PRIMAL_SCOPE; if (ATTRIBUTE (MOID (TAX (p))) != PROC_SYMBOL) { check_identifier_usage (TAX (p), unit); } scope_statement (unit, &s); (void) scope_check (s, TRANSIENT, LEX_LEVEL (p)); tup = scope_find_youngest (s); z = LEVEL (&tup); if (z < LEX_LEVEL (p)) { SCOPE (TAX (p)) = z; SCOPE_ASSIGNED (TAX (p)) = A68_TRUE; } STATUS_SET (unit, INTERRUPTIBLE_MASK); return; } } } /*! \brief scope_variable_declaration \param p position in tree **/ static void scope_variable_declaration (NODE_T * p) { for (; p != NO_NODE; FORWARD (p)) { scope_variable_declaration (SUB (p)); if (IS (p, DECLARER)) { scope_declarer (SUB (p)); } else if (IS (p, DEFINING_IDENTIFIER)) { if (whether (p, DEFINING_IDENTIFIER, ASSIGN_SYMBOL, UNIT, STOP)) { NODE_T *unit = NEXT_NEXT (p); SCOPE_T *s = NO_SCOPE; check_identifier_usage (TAX (p), unit); scope_statement (unit, &s); (void) scope_check (s, TRANSIENT, LEX_LEVEL (p)); STATUS_SET (unit, INTERRUPTIBLE_MASK); return; } } } } /*! \brief scope_procedure_declaration \param p position in tree **/ static void scope_procedure_declaration (NODE_T * p) { for (; p != NO_NODE; FORWARD (p)) { scope_procedure_declaration (SUB (p)); if (is_one_of (p, DEFINING_IDENTIFIER, DEFINING_OPERATOR, STOP)) { NODE_T *unit = NEXT_NEXT (p); SCOPE_T *s = NO_SCOPE; scope_statement (unit, &s); (void) scope_check (s, NOT_TRANSIENT, LEX_LEVEL (p)); STATUS_SET (unit, INTERRUPTIBLE_MASK); return; } } } /*! \brief scope_declaration_list \param p position in tree **/ static void scope_declaration_list (NODE_T * p) { if (p != NO_NODE) { if (IS (p, IDENTITY_DECLARATION)) { scope_identity_declaration (SUB (p)); } else if (IS (p, VARIABLE_DECLARATION)) { scope_variable_declaration (SUB (p)); } else if (IS (p, MODE_DECLARATION)) { scope_declarer (SUB (p)); } else if (IS (p, PRIORITY_DECLARATION)) { ; } else if (IS (p, PROCEDURE_DECLARATION)) { scope_procedure_declaration (SUB (p)); } else if (IS (p, PROCEDURE_VARIABLE_DECLARATION)) { scope_procedure_declaration (SUB (p)); } else if (is_one_of (p, BRIEF_OPERATOR_DECLARATION, OPERATOR_DECLARATION, STOP)) { scope_procedure_declaration (SUB (p)); } else { scope_declaration_list (SUB (p)); scope_declaration_list (NEXT (p)); } } } /*! \brief scope_arguments \param p position in tree **/ static void scope_arguments (NODE_T * p) { for (; p != NO_NODE; FORWARD (p)) { if (IS (p, UNIT)) { SCOPE_T *s = NO_SCOPE; scope_statement (p, &s); (void) scope_check (s, TRANSIENT, LEX_LEVEL (p)); } else { scope_arguments (SUB (p)); } } } /*! \brief is_coercion \param p position in tree **/ BOOL_T is_coercion (NODE_T * p) { if (p != NO_NODE) { switch (ATTRIBUTE (p)) { case DEPROCEDURING: case DEREFERENCING: case UNITING: case ROWING: case WIDENING: case VOIDING: case PROCEDURING: { return (A68_TRUE); } default: { return (A68_FALSE); } } } else { return (A68_FALSE); } } /*! \brief scope_coercion \param p position in tree \param s chain to link into **/ static void scope_coercion (NODE_T * p, SCOPE_T ** s) { if (is_coercion (p)) { if (IS (p, VOIDING)) { scope_coercion (SUB (p), NO_VAR); } else if (IS (p, DEREFERENCING)) { /* Leave this to the dynamic scope checker */ scope_coercion (SUB (p), NO_VAR); } else if (IS (p, DEPROCEDURING)) { scope_coercion (SUB (p), NO_VAR); } else if (IS (p, ROWING)) { SCOPE_T *z = NO_SCOPE; scope_coercion (SUB (p), &z); (void) scope_check (z, TRANSIENT, LEX_LEVEL (p)); if (IS_REF_FLEX (MOID (SUB (p)))) { scope_add (s, p, scope_make_tuple (LEX_LEVEL (p), TRANSIENT)); } else { scope_add (s, p, scope_make_tuple (LEX_LEVEL (p), NOT_TRANSIENT)); } } else if (IS (p, PROCEDURING)) { /* Can only be a JUMP */ NODE_T *q = SUB_SUB (p); if (IS (q, GOTO_SYMBOL)) { FORWARD (q); } scope_add (s, q, scope_make_tuple (TAG_LEX_LEVEL (TAX (q)), NOT_TRANSIENT)); } else if (IS (p, UNITING)) { SCOPE_T *z = NO_SCOPE; scope_coercion (SUB (p), &z); (void) scope_check (z, TRANSIENT, LEX_LEVEL (p)); scope_add (s, p, scope_make_tuple (LEX_LEVEL (p), NOT_TRANSIENT)); } else { scope_coercion (SUB (p), s); } } else { scope_statement (p, s); } } /*! \brief scope_format_text \param p position in tree \param s chain to link into **/ static void scope_format_text (NODE_T * p, SCOPE_T ** s) { for (; p != NO_NODE; FORWARD (p)) { if (IS (p, FORMAT_PATTERN)) { scope_enclosed_clause (SUB (NEXT_SUB (p)), s); } else if (IS (p, FORMAT_ITEM_G) && NEXT (p) != NO_NODE) { scope_enclosed_clause (SUB_NEXT (p), s); } else if (IS (p, DYNAMIC_REPLICATOR)) { scope_enclosed_clause (SUB (NEXT_SUB (p)), s); } else { scope_format_text (SUB (p), s); } } } /*! \brief scope_operand \param p position in tree \param s chain to link into **/ static void scope_operand (NODE_T * p, SCOPE_T ** s) { if (IS (p, MONADIC_FORMULA)) { scope_operand (NEXT_SUB (p), s); } else if (IS (p, FORMULA)) { scope_formula (p, s); } else if (IS (p, SECONDARY)) { scope_statement (SUB (p), s); } } /*! \brief scope_formula \param p position in tree \param s chain to link into **/ static void scope_formula (NODE_T * p, SCOPE_T ** s) { NODE_T *q = SUB (p); SCOPE_T *s2 = NO_SCOPE; scope_operand (q, &s2); (void) scope_check (s2, TRANSIENT, LEX_LEVEL (p)); if (NEXT (q) != NO_NODE) { SCOPE_T *s3 = NO_SCOPE; scope_operand (NEXT_NEXT (q), &s3); (void) scope_check (s3, TRANSIENT, LEX_LEVEL (p)); } (void) s; } /*! \brief scope_routine_text \param p position in tree \param s chain to link into **/ static void scope_routine_text (NODE_T * p, SCOPE_T ** s) { NODE_T *q = SUB (p), *routine = (IS (q, PARAMETER_PACK) ? NEXT (q) : q); SCOPE_T *x = NO_SCOPE; TUPLE_T routine_tuple; scope_statement (NEXT_NEXT (routine), &x); (void) scope_check (x, TRANSIENT, LEX_LEVEL (p)); routine_tuple = scope_make_tuple (YOUNGEST_ENVIRON (TAX (p)), NOT_TRANSIENT); scope_add (s, p, routine_tuple); } /*! \brief scope_statement \param p position in tree \param s chain to link into **/ static void scope_statement (NODE_T * p, SCOPE_T ** s) { if (is_coercion (p)) { scope_coercion (p, s); } else if (is_one_of (p, PRIMARY, SECONDARY, TERTIARY, UNIT, STOP)) { scope_statement (SUB (p), s); } else if (is_one_of (p, DENOTATION, NIHIL, STOP)) { scope_add (s, p, scope_make_tuple (PRIMAL_SCOPE, NOT_TRANSIENT)); } else if (IS (p, IDENTIFIER)) { if (IS (MOID (p), REF_SYMBOL)) { if (PRIO (TAX (p)) == PARAMETER_IDENTIFIER) { scope_add (s, p, scope_make_tuple (TAG_LEX_LEVEL (TAX (p)) - 1, NOT_TRANSIENT)); } else { if (HEAP (TAX (p)) == HEAP_SYMBOL) { scope_add (s, p, scope_make_tuple (PRIMAL_SCOPE, NOT_TRANSIENT)); } else if (SCOPE_ASSIGNED (TAX (p))) { scope_add (s, p, scope_make_tuple (SCOPE (TAX (p)), NOT_TRANSIENT)); } else { scope_add (s, p, scope_make_tuple (TAG_LEX_LEVEL (TAX (p)), NOT_TRANSIENT)); } } } else if (ATTRIBUTE (MOID (p)) == PROC_SYMBOL && SCOPE_ASSIGNED (TAX (p)) == A68_TRUE) { scope_add (s, p, scope_make_tuple (SCOPE (TAX (p)), NOT_TRANSIENT)); } else if (MOID (p) == MODE (FORMAT) && SCOPE_ASSIGNED (TAX (p)) == A68_TRUE) { scope_add (s, p, scope_make_tuple (SCOPE (TAX (p)), NOT_TRANSIENT)); } } else if (IS (p, ENCLOSED_CLAUSE)) { scope_enclosed_clause (SUB (p), s); } else if (IS (p, CALL)) { SCOPE_T *x = NO_SCOPE; scope_statement (SUB (p), &x); (void) scope_check (x, NOT_TRANSIENT, LEX_LEVEL (p)); scope_arguments (NEXT_SUB (p)); } else if (IS (p, SLICE)) { SCOPE_T *x = NO_SCOPE; MOID_T *m = MOID (SUB (p)); if (IS (m, REF_SYMBOL)) { if (ATTRIBUTE (SUB (p)) == PRIMARY && ATTRIBUTE (SUB_SUB (p)) == SLICE) { scope_statement (SUB (p), s); } else { scope_statement (SUB (p), &x); (void) scope_check (x, NOT_TRANSIENT, LEX_LEVEL (p)); } if (IS (SUB (m), FLEX_SYMBOL)) { scope_add (s, SUB (p), scope_make_tuple (LEX_LEVEL (p), TRANSIENT)); } scope_bounds (SUB (NEXT_SUB (p))); } if (IS (MOID (p), REF_SYMBOL)) { scope_add (s, p, scope_find_youngest (x)); } } else if (IS (p, FORMAT_TEXT)) { SCOPE_T *x = NO_SCOPE; scope_format_text (SUB (p), &x); scope_add (s, p, scope_find_youngest (x)); } else if (IS (p, CAST)) { SCOPE_T *x = NO_SCOPE; scope_enclosed_clause (SUB (NEXT_SUB (p)), &x); (void) scope_check (x, NOT_TRANSIENT, LEX_LEVEL (p)); scope_add (s, p, scope_find_youngest (x)); } else if (IS (p, SELECTION)) { SCOPE_T *ns = NO_SCOPE; scope_statement (NEXT_SUB (p), &ns); (void) scope_check (ns, NOT_TRANSIENT, LEX_LEVEL (p)); if (is_ref_refety_flex (MOID (NEXT_SUB (p)))) { scope_add (s, p, scope_make_tuple (LEX_LEVEL (p), TRANSIENT)); } scope_add (s, p, scope_find_youngest (ns)); } else if (IS (p, GENERATOR)) { if (IS (SUB (p), LOC_SYMBOL)) { if (NON_LOCAL (p) != NO_TABLE) { scope_add (s, p, scope_make_tuple (LEVEL (NON_LOCAL (p)), NOT_TRANSIENT)); } else { scope_add (s, p, scope_make_tuple (LEX_LEVEL (p), NOT_TRANSIENT)); } } else { scope_add (s, p, scope_make_tuple (PRIMAL_SCOPE, NOT_TRANSIENT)); } scope_declarer (SUB (NEXT_SUB (p))); } else if (IS (p, DIAGONAL_FUNCTION)) { NODE_T *q = SUB (p); SCOPE_T *ns = NO_SCOPE; if (IS (q, TERTIARY)) { scope_statement (SUB (q), &ns); (void) scope_check (ns, NOT_TRANSIENT, LEX_LEVEL (q)); ns = NO_SCOPE; FORWARD (q); } scope_statement (SUB_NEXT (q), &ns); (void) scope_check (ns, NOT_TRANSIENT, LEX_LEVEL (q)); scope_add (s, p, scope_find_youngest (ns)); } else if (IS (p, TRANSPOSE_FUNCTION)) { NODE_T *q = SUB (p); SCOPE_T *ns = NO_SCOPE; scope_statement (SUB_NEXT (q), &ns); (void) scope_check (ns, NOT_TRANSIENT, LEX_LEVEL (q)); scope_add (s, p, scope_find_youngest (ns)); } else if (IS (p, ROW_FUNCTION)) { NODE_T *q = SUB (p); SCOPE_T *ns = NO_SCOPE; if (IS (q, TERTIARY)) { scope_statement (SUB (q), &ns); (void) scope_check (ns, NOT_TRANSIENT, LEX_LEVEL (q)); ns = NO_SCOPE; FORWARD (q); } scope_statement (SUB_NEXT (q), &ns); (void) scope_check (ns, NOT_TRANSIENT, LEX_LEVEL (q)); scope_add (s, p, scope_find_youngest (ns)); } else if (IS (p, COLUMN_FUNCTION)) { NODE_T *q = SUB (p); SCOPE_T *ns = NO_SCOPE; if (IS (q, TERTIARY)) { scope_statement (SUB (q), &ns); (void) scope_check (ns, NOT_TRANSIENT, LEX_LEVEL (q)); ns = NO_SCOPE; FORWARD (q); } scope_statement (SUB_NEXT (q), &ns); (void) scope_check (ns, NOT_TRANSIENT, LEX_LEVEL (q)); scope_add (s, p, scope_find_youngest (ns)); } else if (IS (p, FORMULA)) { scope_formula (p, s); } else if (IS (p, ASSIGNATION)) { NODE_T *unit = NEXT (NEXT_SUB (p)); SCOPE_T *ns = NO_SCOPE, *nd = NO_SCOPE; TUPLE_T tup; scope_statement (SUB_SUB (p), &nd); scope_statement (unit, &ns); (void) scope_check_multiple (ns, TRANSIENT, nd); tup = scope_find_youngest (nd); scope_add (s, p, scope_make_tuple (LEVEL (&tup), NOT_TRANSIENT)); } else if (IS (p, ROUTINE_TEXT)) { scope_routine_text (p, s); } else if (is_one_of (p, IDENTITY_RELATION, AND_FUNCTION, OR_FUNCTION, STOP)) { SCOPE_T *n = NO_SCOPE; scope_statement (SUB (p), &n); scope_statement (NEXT (NEXT_SUB (p)), &n); (void) scope_check (n, NOT_TRANSIENT, LEX_LEVEL (p)); } else if (IS (p, ASSERTION)) { SCOPE_T *n = NO_SCOPE; scope_enclosed_clause (SUB (NEXT_SUB (p)), &n); (void) scope_check (n, NOT_TRANSIENT, LEX_LEVEL (p)); } else if (is_one_of (p, JUMP, SKIP, STOP)) { ; } } /*! \brief scope_statement_list \param p position in tree \param s chain to link into **/ static void scope_statement_list (NODE_T * p, SCOPE_T ** s) { for (; p != NO_NODE; FORWARD (p)) { if (IS (p, UNIT)) { STATUS_SET (p, INTERRUPTIBLE_MASK); scope_statement (p, s); } else { scope_statement_list (SUB (p), s); } } } /*! \brief scope_serial_clause \param p position in tree \param s chain to link into \param terminator whether unit terminates clause **/ static void scope_serial_clause (NODE_T * p, SCOPE_T ** s, BOOL_T terminator) { if (p != NO_NODE) { if (IS (p, INITIALISER_SERIES)) { scope_serial_clause (SUB (p), s, A68_FALSE); scope_serial_clause (NEXT (p), s, terminator); } else if (IS (p, DECLARATION_LIST)) { scope_declaration_list (SUB (p)); } else if (is_one_of (p, LABEL, SEMI_SYMBOL, EXIT_SYMBOL, STOP)) { scope_serial_clause (NEXT (p), s, terminator); } else if (is_one_of (p, SERIAL_CLAUSE, ENQUIRY_CLAUSE, STOP)) { if (NEXT (p) != NO_NODE) { int j = ATTRIBUTE (NEXT (p)); if (j == EXIT_SYMBOL || j == END_SYMBOL || j == CLOSE_SYMBOL) { scope_serial_clause (SUB (p), s, A68_TRUE); } else { scope_serial_clause (SUB (p), s, A68_FALSE); } } else { scope_serial_clause (SUB (p), s, A68_TRUE); } scope_serial_clause (NEXT (p), s, terminator); } else if (IS (p, LABELED_UNIT)) { scope_serial_clause (SUB (p), s, terminator); } else if (IS (p, UNIT)) { STATUS_SET (p, INTERRUPTIBLE_MASK); if (terminator) { scope_statement (p, s); } else { scope_statement (p, NO_VAR); } } } } /*! \brief scope_closed_clause \param p position in tree \param s chain to link into **/ static void scope_closed_clause (NODE_T * p, SCOPE_T ** s) { if (p != NO_NODE) { if (IS (p, SERIAL_CLAUSE)) { scope_serial_clause (p, s, A68_TRUE); } else if (is_one_of (p, OPEN_SYMBOL, BEGIN_SYMBOL, STOP)) { scope_closed_clause (NEXT (p), s); } } } /*! \brief scope_collateral_clause \param p position in tree \param s chain to link into **/ static void scope_collateral_clause (NODE_T * p, SCOPE_T ** s) { if (p != NO_NODE) { if (!(whether (p, BEGIN_SYMBOL, END_SYMBOL, STOP) || whether (p, OPEN_SYMBOL, CLOSE_SYMBOL, STOP))) { scope_statement_list (p, s); } } } /*! \brief scope_conditional_clause \param p position in tree \param s chain to link into **/ static void scope_conditional_clause (NODE_T * p, SCOPE_T ** s) { scope_serial_clause (NEXT_SUB (p), NO_VAR, A68_TRUE); FORWARD (p); scope_serial_clause (NEXT_SUB (p), s, A68_TRUE); if ((FORWARD (p)) != NO_NODE) { if (is_one_of (p, ELSE_PART, CHOICE, STOP)) { scope_serial_clause (NEXT_SUB (p), s, A68_TRUE); } else if (is_one_of (p, ELIF_PART, BRIEF_ELIF_PART, STOP)) { scope_conditional_clause (SUB (p), s); } } } /*! \brief scope_case_clause \param p position in tree \param s chain to link into **/ static void scope_case_clause (NODE_T * p, SCOPE_T ** s) { SCOPE_T *n = NO_SCOPE; scope_serial_clause (NEXT_SUB (p), &n, A68_TRUE); (void) scope_check (n, NOT_TRANSIENT, LEX_LEVEL (p)); FORWARD (p); scope_statement_list (NEXT_SUB (p), s); if ((FORWARD (p)) != NO_NODE) { if (is_one_of (p, OUT_PART, CHOICE, STOP)) { scope_serial_clause (NEXT_SUB (p), s, A68_TRUE); } else if (is_one_of (p, CASE_OUSE_PART, BRIEF_OUSE_PART, STOP)) { scope_case_clause (SUB (p), s); } else if (is_one_of (p, CONFORMITY_OUSE_PART, BRIEF_CONFORMITY_OUSE_PART, STOP)) { scope_case_clause (SUB (p), s); } } } /*! \brief scope_loop_clause \param p position in tree **/ static void scope_loop_clause (NODE_T * p) { if (p != NO_NODE) { if (IS (p, FOR_PART)) { scope_loop_clause (NEXT (p)); } else if (is_one_of (p, FROM_PART, BY_PART, TO_PART, STOP)) { scope_statement (NEXT_SUB (p), NO_VAR); scope_loop_clause (NEXT (p)); } else if (IS (p, WHILE_PART)) { scope_serial_clause (NEXT_SUB (p), NO_VAR, A68_TRUE); scope_loop_clause (NEXT (p)); } else if (is_one_of (p, DO_PART, ALT_DO_PART, STOP)) { NODE_T *do_p = NEXT_SUB (p), *un_p; if (IS (do_p, SERIAL_CLAUSE)) { scope_serial_clause (do_p, NO_VAR, A68_TRUE); un_p = NEXT (do_p); } else { un_p = do_p; } if (un_p != NO_NODE && IS (un_p, UNTIL_PART)) { scope_serial_clause (NEXT_SUB (un_p), NO_VAR, A68_TRUE); } } } } /*! \brief scope_enclosed_clause \param p position in tree \param s chain to link into **/ static void scope_enclosed_clause (NODE_T * p, SCOPE_T ** s) { if (IS (p, ENCLOSED_CLAUSE)) { scope_enclosed_clause (SUB (p), s); } else if (IS (p, CLOSED_CLAUSE)) { scope_closed_clause (SUB (p), s); } else if (is_one_of (p, COLLATERAL_CLAUSE, PARALLEL_CLAUSE, STOP)) { scope_collateral_clause (SUB (p), s); } else if (IS (p, CONDITIONAL_CLAUSE)) { scope_conditional_clause (SUB (p), s); } else if (is_one_of (p, CASE_CLAUSE, CONFORMITY_CLAUSE, STOP)) { scope_case_clause (SUB (p), s); } else if (IS (p, LOOP_CLAUSE)) { scope_loop_clause (SUB (p)); } } /*! \brief whether a symbol table contains no (anonymous) definition \param t symbol table \return TRUE or FALSE **/ static BOOL_T empty_table (TABLE_T * t) { if (IDENTIFIERS (t) == NO_TAG) { return ((BOOL_T) (OPERATORS (t) == NO_TAG && INDICANTS (t) == NO_TAG)); } else if (PRIO (IDENTIFIERS (t)) == LOOP_IDENTIFIER && NEXT (IDENTIFIERS (t)) == NO_TAG) { return ((BOOL_T) (OPERATORS (t) == NO_TAG && INDICANTS (t) == NO_TAG)); } else if (PRIO (IDENTIFIERS (t)) == SPECIFIER_IDENTIFIER && NEXT (IDENTIFIERS (t)) == NO_TAG) { return ((BOOL_T) (OPERATORS (t) == NO_TAG && INDICANTS (t) == NO_TAG)); } else { return (A68_FALSE); } } /*! \brief indicate non-local environs \param p position in tree \param max lex level threshold **/ static void get_non_local_environs (NODE_T * p, int max) { for (; p != NO_NODE; FORWARD (p)) { if (IS (p, ROUTINE_TEXT)) { get_non_local_environs (SUB (p), LEX_LEVEL (SUB (p))); } else if (IS (p, FORMAT_TEXT)) { get_non_local_environs (SUB (p), LEX_LEVEL (SUB (p))); } else { get_non_local_environs (SUB (p), max); NON_LOCAL (p) = NO_TABLE; if (TABLE (p) != NO_TABLE) { TABLE_T *q = TABLE (p); while (q != NO_TABLE && empty_table (q) && PREVIOUS (q) != NO_TABLE && LEVEL (PREVIOUS (q)) >= max) { NON_LOCAL (p) = PREVIOUS (q); q = PREVIOUS (q); } } } } } /*! \brief scope_checker \param p position in tree **/ void scope_checker (NODE_T * p) { /* Establish scopes of routine texts and format texts */ get_youngest_environs (p); /* Find non-local environs */ get_non_local_environs (p, PRIMAL_SCOPE); /* PROC and FORMAT identities can now be assigned a scope */ bind_scope_to_tags (p); /* Now check evertyhing else */ scope_enclosed_clause (SUB (p), NO_VAR); } /* syntax.c*/ algol68g-2.4.1/source/a68g.c0000644000175000001440000056326711770440411012311 00000000000000/*! \file algol68g.c \brief driver routines for the compiler-interpreter. */ /* This file is part of Algol68G - an Algol 68 interpreter. Copyright (C) 2001-2012 J. Marcel van der Veer . 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 . */ /* Algol68G is an Algol 68 compiler-interpreter. Please refer to the documentation that comes with this distribution for a detailed description of Algol68G. */ #if defined HAVE_CONFIG_H #include "a68g-config.h" #endif #include "a68g.h" int global_argc; /* Keep argc and argv for reference from A68 */ char **global_argv; BOOL_T in_execution; BYTE_T *system_stack_offset; MODES_T a68_modes; MODULE_T program; NODE_T **node_register = NO_VAR; char a68g_cmd_name[BUFFER_SIZE]; clock_t clock_res; int new_nodes, new_modes, new_postulates, new_node_infos, new_genie_infos; int stack_size; int symbol_table_count, mode_count; int term_heigth, term_width; static int max_simplout_size; static POSTULATE_T *postulates; #define EXTENSIONS 11 static char * extensions[EXTENSIONS] = { NO_TEXT, ".a68", ".A68", ".a68g", ".A68G", ".algol", ".ALGOL", ".algol68", ".ALGOL68", ".algol68g", ".ALGOL68G" }; static void announce_phase (char *); static void compiler_interpreter (void); static void default_mem_sizes (int); static void moid_to_string_2 (char *, MOID_T *, int *, NODE_T *); #if defined HAVE_COMPILER static void build_script (void); static void load_script (void); static void rewrite_script_source (void); #endif #if ! defined HAVE_SNPRINTF /* Apparently some systems do not support snprintf. This stub looks unsafe but should work with a68g. */ /* \brief print in a fixed-length buffer \param buf buffer to use \param size size of buffer \param fmt format string \return characters printed */ int a68g_snprintf (char *buf, size_t size, char *fmt, ...) { va_list p; int len; va_start (p, fmt); (void) vsprintf (buf, fmt, p); len = (int) strlen (buf); ABEND (len >= (int) size, "snprintf overflow", NO_TEXT); va_end (p); return (len); } #endif /*! \brief return error test from errno \return same */ char *error_specification (void) { static char txt[BUFFER_SIZE]; if (errno == 0) { ASSERT (snprintf (txt, SNPRINTF_SIZE, "no information") >= 0); } else { ASSERT (snprintf (txt, SNPRINTF_SIZE, "%s", strerror (errno)) >= 0); } if (strlen (txt) > 0) { txt[0] = TO_LOWER (txt[0]); } return (txt); } /*! \brief open a file in ~/.a68g, if possible \param fn file name \param mode mode \return pointer to descriptor */ FILE *a68g_fopen (char *fn, char *mode, char *new_fn) { #if defined HAVE_WIN32 || ! defined HAVE_DIRENT_H ASSERT (snprintf (new_fn, SNPRINTF_SIZE, "%s", fn) >= 0); return (fopen (new_fn, mode)); #else char dn[BUFFER_SIZE]; int rc; RESET_ERRNO; ASSERT (snprintf (dn, SNPRINTF_SIZE, "%s/%s", getenv ("HOME"), A68_DIR) >= 0); rc = mkdir (dn, (mode_t) (S_IRUSR | S_IWUSR | S_IXUSR)); if (rc == 0 || (rc == -1 && errno == EEXIST)) { struct stat status; if (stat (dn, &status) == 0 && S_ISDIR (ST_MODE (&status)) != 0) { FILE *f; ASSERT (snprintf (new_fn, SNPRINTF_SIZE, "%s/%s", dn, fn) >= 0); f = fopen (new_fn, mode); if (f != NO_FILE) { return (f); } } } ASSERT (snprintf (new_fn, SNPRINTF_SIZE, "%s", fn) >= 0); return (fopen (new_fn, mode)); #endif } /*! \brief print k bytes from z; debugging routine \param z byte string \param k length **/ void print_bytes (BYTE_T *z, int k) { int j; for (j = 0; j < k; j ++) { printf ("%02x ", z[j]); } printf ("\n"); ASSERT (fflush (stdout) == 0); /* print_bytes */ } /*! \brief unformatted write of z to stdout \param str prompt \param z mp number to print \param digits precision in mp-digits **/ void raw_write_mp (char *str, MP_T * z, int digits) { int i; printf ("\n%s", str); for (i = 1; i <= digits; i++) { printf (" %07d", (int) MP_DIGIT (z, i)); } printf (" ^ %d", (int) MP_EXPONENT (z)); printf (" status=%d", (int) MP_STATUS (z)); ASSERT (fflush (stdout) == 0); /* raw_write_mp */ } /*! \brief state license of running a68g image \param f file number to write to **/ void state_license (FILE_T f) { #define PR(s)\ ASSERT (snprintf(output_line, SNPRINTF_SIZE, "%s\n", (s)) >= 0);\ WRITE (f, output_line); if (f == STDOUT_FILENO) { io_close_tty_line (); } ASSERT (snprintf (output_line, SNPRINTF_SIZE, "Algol 68 Genie %s\n", PACKAGE_VERSION) >= 0); WRITE (f, output_line); ASSERT (snprintf (output_line, SNPRINTF_SIZE, "Copyright (c) 2012 %s.\n", PACKAGE_BUGREPORT) >= 0); WRITE (f, output_line); PR (""); ASSERT (snprintf (output_line, SNPRINTF_SIZE, "This is free software covered by the GNU General Public License.\n") >= 0); WRITE (f, output_line); ASSERT (snprintf (output_line, SNPRINTF_SIZE, "There is ABSOLUTELY NO WARRANTY for Algol 68 Genie;\n") >= 0); WRITE (f, output_line); ASSERT (snprintf (output_line, SNPRINTF_SIZE, "not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.\n") >= 0); WRITE (f, output_line); PR ("See the GNU General Public License for more details."); PR (""); ASSERT (snprintf (output_line, SNPRINTF_SIZE, "Please report bugs to %s.\n", PACKAGE_BUGREPORT) >= 0); WRITE (f, output_line); PR (""); #undef PR } /*! \brief state version of running a68g image \param f file number to write to **/ void state_version (FILE_T f) { if (f == STDOUT_FILENO) { io_close_tty_line (); } state_license (f); WRITELN (f, ""); #if defined HAVE_WIN32 ASSERT (snprintf (output_line, SNPRINTF_SIZE, "This is a WIN32 executable.\n") >= 0); WRITE (f, output_line); #endif #if defined HAVE_COMPILER ASSERT (snprintf (output_line, SNPRINTF_SIZE, "Compilation is supported.\n") >= 0); #else ASSERT (snprintf (output_line, SNPRINTF_SIZE, "Compilation is not supported.\n") >= 0); #endif WRITE (f, output_line); #if defined HAVE_EDITOR ASSERT (snprintf (output_line, SNPRINTF_SIZE, "Editor is supported.\n") >= 0); #else ASSERT (snprintf (output_line, SNPRINTF_SIZE, "Editor is not supported.\n") >= 0); #endif WRITE (f, output_line); #if defined HAVE_PARALLEL_CLAUSE ASSERT (snprintf (output_line, SNPRINTF_SIZE, "Parallel-clause is supported.\n") >= 0); #else ASSERT (snprintf (output_line, SNPRINTF_SIZE, "Parallel-clause is not supported.\n") >= 0); #endif WRITE (f, output_line); #if defined HAVE_CURSES ASSERT (snprintf (output_line, SNPRINTF_SIZE, "Curses is supported.\n") >= 0); #else ASSERT (snprintf (output_line, SNPRINTF_SIZE, "Curses is not supported.\n") >= 0); #endif WRITE (f, output_line); #if defined HAVE_REGEX_H ASSERT (snprintf (output_line, SNPRINTF_SIZE, "Regular expressions are supported.\n") >= 0); #else ASSERT (snprintf (output_line, SNPRINTF_SIZE, "Regular expressions are not supported.\n") >= 0); #endif WRITE (f, output_line); #if defined HAVE_HTTP ASSERT (snprintf (output_line, SNPRINTF_SIZE, "TCP/IP is supported.\n") >= 0); #else ASSERT (snprintf (output_line, SNPRINTF_SIZE, "TCP/IP is not supported.\n") >= 0); #endif WRITE (f, output_line); #if defined HAVE_GNU_PLOTUTILS ASSERT (snprintf (output_line, SNPRINTF_SIZE, "GNU libplot is supported.\n") >= 0); #else ASSERT (snprintf (output_line, SNPRINTF_SIZE, "GNU libplot is not supported.\n") >= 0); #endif WRITE (f, output_line); #if defined HAVE_GNU_GSL ASSERT (snprintf (output_line, SNPRINTF_SIZE, "GNU Scientific Library is supported.\n") >= 0); #else ASSERT (snprintf (output_line, SNPRINTF_SIZE, "GNU Scientific Library is not supported.\n") >= 0); #endif WRITE (f, output_line); #if defined HAVE_POSTGRESQL ASSERT (snprintf (output_line, SNPRINTF_SIZE, "PostgreSQL is supported.\n") >= 0); #else ASSERT (snprintf (output_line, SNPRINTF_SIZE, "PostgreSQL is not supported.\n") >= 0); #endif WRITE (f, output_line); #if defined _CS_GNU_LIBC_VERSION && ! defined HAVE_WIN32 if (confstr (_CS_GNU_LIBC_VERSION, input_line, BUFFER_SIZE) > (size_t) 0) { ASSERT (snprintf (output_line, SNPRINTF_SIZE, "GNU libc version %s.\n", input_line) >= 0); WRITE (f, output_line); } #if (defined HAVE_PARALLEL_CLAUSE && defined _CS_GNU_LIBPTHREAD_VERSION) if (confstr (_CS_GNU_LIBPTHREAD_VERSION, input_line, BUFFER_SIZE) > (size_t) 0) { ASSERT (snprintf (output_line, SNPRINTF_SIZE, "GNU libpthread version %s.\n", input_line) >= 0); WRITE (f, output_line); } #endif #endif } /*! \brief give brief help if someone types 'a68g --help' \param f file number **/ void online_help (FILE_T f) { if (f == STDOUT_FILENO) { io_close_tty_line (); } state_license (f); ASSERT (snprintf (output_line, SNPRINTF_SIZE, "Usage: %s [options | filename]", a68g_cmd_name) >= 0); WRITELN (f, output_line); ASSERT (snprintf (output_line, SNPRINTF_SIZE, "For help: %s --apropos [keyword]", a68g_cmd_name) >= 0); WRITELN (f, output_line); } /*! \brief first initialisations **/ static void init_before_tokeniser (void) { /* Heap management set-up */ init_heap (); top_keyword = NO_KEYWORD; top_token = NO_TOKEN; TOP_NODE (&program) = NO_NODE; TOP_MOID (&program) = NO_MOID; TOP_LINE (&program) = NO_LINE; STANDENV_MOID (&program) = NO_MOID; set_up_tables (); /* Various initialisations */ ERROR_COUNT (&program) = WARNING_COUNT (&program) = 0; RESET_ERRNO; } /*! \brief main entry point \param argc arg count \param argv arg string \return exit code **/ int main (int argc, char *argv[]) { BYTE_T stack_offset; int argcc, k; global_argc = argc; global_argv = argv; FILE_DIAGS_FD (&program) = -1; /* Get command name and discard path */ bufcpy (a68g_cmd_name, argv[0], BUFFER_SIZE); for (k = (int) strlen (a68g_cmd_name) - 1; k >= 0; k--) { #if defined WIN32 char delim = '\\'; #else char delim = '/'; #endif if (a68g_cmd_name[k] == delim) { MOVE (&a68g_cmd_name[0], &a68g_cmd_name[k + 1], (int) strlen (a68g_cmd_name) - k + 1); k = -1; } } /* Try to read maximum line width on the terminal, used to pretty print diagnostics to same. */ a68g_getty (&term_heigth, &term_width); /* Determine clock resolution */ { clock_t t0 = clock (), t1; do { t1 = clock (); } while (t1 == t0); clock_res = (t1 - t0) / (clock_t) CLOCKS_PER_SEC; } /* Set the main thread id */ #if defined HAVE_PARALLEL_CLAUSE main_thread_id = pthread_self (); #endif heap_is_fluid = A68_TRUE; system_stack_offset = &stack_offset; init_file_entries (); if (!setjmp (RENDEZ_VOUS (&program))) { init_tty (); /* Initialise option handling */ init_options (); SOURCE_SCAN (&program) = 1; default_options (&program); default_mem_sizes (1); /* Initialise core */ stack_segment = NO_BYTE; heap_segment = NO_BYTE; handle_segment = NO_BYTE; get_stack_size (); /* Well, let's start */ TOP_REFINEMENT (&program) = NO_REFINEMENT; FILE_INITIAL_NAME (&program) = NO_TEXT; FILE_GENERIC_NAME (&program) = NO_TEXT; FILE_SOURCE_NAME (&program) = NO_TEXT; FILE_LISTING_NAME (&program) = NO_TEXT; FILE_OBJECT_NAME (&program) = NO_TEXT; FILE_LIBRARY_NAME (&program) = NO_TEXT; FILE_BINARY_NAME (&program) = NO_TEXT; FILE_PRETTY_NAME (&program) = NO_TEXT; FILE_SCRIPT_NAME (&program) = NO_TEXT; FILE_DIAGS_NAME (&program) = NO_TEXT; /* Options are processed here */ read_rc_options (); read_env_options (); /* Posix copies arguments from the command line */ if (argc <= 1) { online_help (STDOUT_FILENO); a68g_exit (EXIT_FAILURE); } for (argcc = 1; argcc < argc; argcc++) { add_option_list (&(OPTION_LIST (&program)), argv[argcc], NO_LINE); } if (!set_options (OPTION_LIST (&program), A68_TRUE)) { a68g_exit (EXIT_FAILURE); } if (OPTION_REGRESSION_TEST (&program)) { bufcpy (a68g_cmd_name, "a68g", BUFFER_SIZE); } /* Attention for --version */ if (OPTION_VERSION (&program)) { state_version (STDOUT_FILENO); } /* Start the UI */ init_before_tokeniser (); if (OPTION_EDIT (&program)) { #if defined HAVE_CURSES ASSERT (snprintf (output_line, SNPRINTF_SIZE, "Algol 68 Genie %s\n", PACKAGE_VERSION) >= 0); edit (output_line); #else errno = ENOTSUP; SCAN_ERROR (A68_TRUE, NO_LINE, NO_TEXT, "editor requires the ncurses library"); #endif } /* Running a script */ #if defined HAVE_COMPILER if (OPTION_RUN_SCRIPT (&program)) { load_script (); } #endif /* We translate the program */ if (FILE_INITIAL_NAME (&program) == NO_TEXT || strlen (FILE_INITIAL_NAME (&program)) == 0) { SCAN_ERROR (!OPTION_VERSION (&program), NO_LINE, NO_TEXT, ERROR_NO_SOURCE_FILE); } else { compiler_interpreter (); } a68g_exit (ERROR_COUNT (&program) == 0 ? EXIT_SUCCESS : EXIT_FAILURE); return (EXIT_SUCCESS); } else { diagnostics_to_terminal (TOP_LINE (&program), A68_ALL_DIAGNOSTICS); a68g_exit (EXIT_FAILURE); return (EXIT_FAILURE); } } /*! \brief test extension and strip \param ext extension to try \return whether stripped **/ static BOOL_T strip_extension (char * ext) { int nlen, xlen; if (ext == NO_TEXT) { return (A68_FALSE); } nlen = (int) strlen (FILE_SOURCE_NAME (&program)); xlen = (int) strlen (ext); if (nlen > xlen && strcmp (&(FILE_SOURCE_NAME (&program)[nlen - xlen]), ext) == 0) { char *fn = (char *) get_heap_space ((size_t) (nlen + 1)); bufcpy (fn, FILE_SOURCE_NAME (&program), nlen); fn[nlen - xlen] = NULL_CHAR; FILE_GENERIC_NAME (&program) = new_string (fn, NO_TEXT); return (A68_TRUE); } else { return (A68_FALSE); } } /*! \brief try opening with an extension **/ static void open_with_extensions (void) { int k; FILE_SOURCE_FD (&program) = -1; for (k = 0; k < EXTENSIONS && FILE_SOURCE_FD (&program) == -1; k ++) { int len; char * fn; if (extensions[k] == NO_TEXT) { len = (int) strlen (FILE_INITIAL_NAME (&program)) + 1; fn = (char *) get_heap_space ((size_t) len); bufcpy (fn, FILE_INITIAL_NAME (&program), len); } else { len = (int) strlen (FILE_INITIAL_NAME (&program)) + (int) strlen (extensions[k]) + 1; fn = (char *) get_heap_space ((size_t) len); bufcpy (fn, FILE_INITIAL_NAME (&program), len); bufcat (fn, extensions[k], len); } FILE_SOURCE_FD (&program) = open (fn, O_RDONLY | O_BINARY); if (FILE_SOURCE_FD (&program) != -1) { int l; BOOL_T cont = A68_TRUE; FILE_SOURCE_NAME (&program) = new_string (fn, NO_TEXT); FILE_GENERIC_NAME (&program) = new_string (fn, NO_TEXT); for (l = 0; l < EXTENSIONS && cont; l ++) { if (strip_extension (extensions[l])) { cont = A68_FALSE; } } } } } /*! \brief pretty print memory size **/ char *pretty_size (int k) { if (k >= 10 * MEGABYTE) { ASSERT (snprintf (edit_line, SNPRINTF_SIZE, "%dM", k / MEGABYTE) >= 0); } else if (k >= 10 * KILOBYTE) { ASSERT (snprintf (edit_line, SNPRINTF_SIZE, "%dk", k / KILOBYTE) >= 0); } else { ASSERT (snprintf (edit_line, SNPRINTF_SIZE, "%d", k) >= 0); } return (edit_line); } /*! \brief verbose statistics, only useful when debugging a68g **/ static void verbosity (void) { ; } /*! \brief drives compilation and interpretation **/ static void compiler_interpreter (void) { int k, len, num; BOOL_T path_set = A68_FALSE; BOOL_T emitted = A68_FALSE; TREE_LISTING_SAFE (&program) = A68_FALSE; CROSS_REFERENCE_SAFE (&program) = A68_FALSE; in_execution = A68_FALSE; new_nodes = 0; new_modes = 0; new_postulates = 0; new_node_infos = 0; new_genie_infos = 0; init_postulates (); /* File set-up */ SCAN_ERROR (FILE_INITIAL_NAME (&program) == NO_TEXT, NO_LINE, NO_TEXT, ERROR_NO_SOURCE_FILE); FILE_BINARY_OPENED (&program) = A68_FALSE; FILE_BINARY_WRITEMOOD (&program) = A68_TRUE; FILE_LIBRARY_OPENED (&program) = A68_FALSE; FILE_LIBRARY_WRITEMOOD (&program) = A68_TRUE; FILE_LISTING_OPENED (&program) = A68_FALSE; FILE_LISTING_WRITEMOOD (&program) = A68_TRUE; FILE_OBJECT_OPENED (&program) = A68_FALSE; FILE_OBJECT_WRITEMOOD (&program) = A68_TRUE; FILE_PRETTY_OPENED (&program) = A68_FALSE; FILE_SCRIPT_OPENED (&program) = A68_FALSE; FILE_SCRIPT_WRITEMOOD (&program) = A68_FALSE; FILE_SOURCE_OPENED (&program) = A68_FALSE; FILE_SOURCE_WRITEMOOD (&program) = A68_FALSE; FILE_DIAGS_OPENED (&program) = A68_FALSE; FILE_DIAGS_WRITEMOOD (&program) = A68_TRUE; /* Open the source file. Open it for binary reading for systems that require so (Win32). Accept various silent extensions. */ errno = 0; FILE_SOURCE_NAME (&program) = NO_TEXT; FILE_GENERIC_NAME (&program) = NO_TEXT; open_with_extensions (); if (FILE_SOURCE_FD (&program) == -1) { scan_error (NO_LINE, NO_TEXT, ERROR_SOURCE_FILE_OPEN); } ABEND (FILE_SOURCE_NAME (&program) == NO_TEXT, "no source file name", NO_TEXT); ABEND (FILE_GENERIC_NAME (&program) == NO_TEXT, "no generic file name", NO_TEXT); /* Isolate the path name */ FILE_PATH (&program) = new_string (FILE_GENERIC_NAME (&program), NO_TEXT); path_set = A68_FALSE; for (k = (int) strlen (FILE_PATH (&program)); k >= 0 && path_set == A68_FALSE; k--) { #if defined WIN32 char delim = '\\'; #else char delim = '/'; #endif if (FILE_PATH (&program)[k] == delim) { FILE_PATH (&program)[k + 1] = NULL_CHAR; path_set = A68_TRUE; } } if (path_set == A68_FALSE) { FILE_PATH (&program)[0] = NULL_CHAR; } /* Object file */ len = 1 + (int) strlen (FILE_GENERIC_NAME (&program)) + (int) strlen (OBJECT_EXTENSION); FILE_OBJECT_NAME (&program) = (char *) get_heap_space ((size_t) len); bufcpy (FILE_OBJECT_NAME (&program), FILE_GENERIC_NAME (&program), len); bufcat (FILE_OBJECT_NAME (&program), OBJECT_EXTENSION, len); /* Binary */ len = 1 + (int) strlen (FILE_GENERIC_NAME (&program)) + (int) strlen (LIBRARY_EXTENSION); FILE_BINARY_NAME (&program) = (char *) get_heap_space ((size_t) len); bufcpy (FILE_BINARY_NAME (&program), FILE_GENERIC_NAME (&program), len); bufcat (FILE_BINARY_NAME (&program), BINARY_EXTENSION, len); /* Library file */ len = 1 + (int) strlen (FILE_GENERIC_NAME (&program)) + (int) strlen (LIBRARY_EXTENSION); FILE_LIBRARY_NAME (&program) = (char *) get_heap_space ((size_t) len); bufcpy (FILE_LIBRARY_NAME (&program), FILE_GENERIC_NAME (&program), len); bufcat (FILE_LIBRARY_NAME (&program), LIBRARY_EXTENSION, len); /* Listing file */ len = 1 + (int) strlen (FILE_GENERIC_NAME (&program)) + (int) strlen (LISTING_EXTENSION); FILE_LISTING_NAME (&program) = (char *) get_heap_space ((size_t) len); bufcpy (FILE_LISTING_NAME (&program), FILE_GENERIC_NAME (&program), len); bufcat (FILE_LISTING_NAME (&program), LISTING_EXTENSION, len); /* Pretty file */ len = 1 + (int) strlen (FILE_GENERIC_NAME (&program)) + (int) strlen (PRETTY_EXTENSION); FILE_PRETTY_NAME (&program) = (char *) get_heap_space ((size_t) len); bufcpy (FILE_PRETTY_NAME (&program), FILE_GENERIC_NAME (&program), len); bufcat (FILE_PRETTY_NAME (&program), PRETTY_EXTENSION, len); /* Script file */ len = 1 + (int) strlen (FILE_GENERIC_NAME (&program)) + (int) strlen (SCRIPT_EXTENSION); FILE_SCRIPT_NAME (&program) = (char *) get_heap_space ((size_t) len); bufcpy (FILE_SCRIPT_NAME (&program), FILE_GENERIC_NAME (&program), len); bufcat (FILE_SCRIPT_NAME (&program), SCRIPT_EXTENSION, len); /* Tokeniser */ FILE_SOURCE_OPENED (&program) = A68_TRUE; announce_phase ("initialiser"); error_tag = (TAG_T *) new_tag (); if (ERROR_COUNT (&program) == 0) { int frame_stack_size_2 = frame_stack_size; int expr_stack_size_2 = expr_stack_size; int heap_size_2 = heap_size; int handle_pool_size_2 = handle_pool_size; BOOL_T ok; announce_phase ("tokeniser"); ok = lexical_analyser (); if (!ok || errno != 0) { diagnostics_to_terminal (TOP_LINE (&program), A68_ALL_DIAGNOSTICS); return; } /* Maybe the program asks for more memory through a PRAGMAT. We restart */ if (frame_stack_size_2 != frame_stack_size || expr_stack_size_2 != expr_stack_size || heap_size_2 != heap_size || handle_pool_size_2 != handle_pool_size) { discard_heap (); init_before_tokeniser (); SOURCE_SCAN (&program) ++; ok = lexical_analyser (); verbosity (); } if (!ok || errno != 0) { diagnostics_to_terminal (TOP_LINE (&program), A68_ALL_DIAGNOSTICS); return; } ASSERT (close (FILE_SOURCE_FD (&program)) == 0); FILE_SOURCE_OPENED (&program) = A68_FALSE; prune_echoes (OPTION_LIST (&program)); TREE_LISTING_SAFE (&program) = A68_TRUE; num = 0; renumber_nodes (TOP_NODE (&program), &num); } /* Final initialisations */ if (ERROR_COUNT (&program) == 0) { a68g_standenv = NO_TABLE; init_postulates (); mode_count = 0; make_special_mode (&MODE (HIP), mode_count++); make_special_mode (&MODE (UNDEFINED), mode_count++); make_special_mode (&MODE (ERROR), mode_count++); make_special_mode (&MODE (VACUUM), mode_count++); make_special_mode (&MODE (C_STRING), mode_count++); make_special_mode (&MODE (COLLITEM), mode_count++); make_special_mode (&MODE (SOUND_DATA), mode_count++); } /* Refinement preprocessor */ if (ERROR_COUNT (&program) == 0) { announce_phase ("preprocessor"); get_refinements (); if (ERROR_COUNT (&program) == 0) { put_refinements (); } num = 0; renumber_nodes (TOP_NODE (&program), &num); verbosity (); } /* Top-down parser */ if (ERROR_COUNT (&program) == 0) { announce_phase ("parser phase 1"); check_parenthesis (TOP_NODE (&program)); if (ERROR_COUNT (&program) == 0) { if (OPTION_BRACKETS (&program)) { substitute_brackets (TOP_NODE (&program)); } symbol_table_count = 0; a68g_standenv = new_symbol_table (NO_TABLE); LEVEL (a68g_standenv) = 0; top_down_parser (TOP_NODE (&program)); } num = 0; renumber_nodes (TOP_NODE (&program), &num); verbosity (); } /* Standard environment builder */ if (ERROR_COUNT (&program) == 0) { announce_phase ("standard environ builder"); TABLE (TOP_NODE (&program)) = new_symbol_table (a68g_standenv); make_standard_environ (); STANDENV_MOID (&program) = TOP_MOID (&program); verbosity (); } /* Bottom-up parser */ if (ERROR_COUNT (&program) == 0) { announce_phase ("parser phase 2"); preliminary_symbol_table_setup (TOP_NODE (&program)); bottom_up_parser (TOP_NODE (&program)); num = 0; renumber_nodes (TOP_NODE (&program), &num); verbosity (); } if (ERROR_COUNT (&program) == 0) { announce_phase ("parser phase 3"); bottom_up_error_check (TOP_NODE (&program)); victal_checker (TOP_NODE (&program)); if (ERROR_COUNT (&program) == 0) { finalise_symbol_table_setup (TOP_NODE (&program), 2); NEST (TABLE (TOP_NODE (&program))) = symbol_table_count = 3; reset_symbol_table_nest_count (TOP_NODE (&program)); fill_symbol_table_outer (TOP_NODE (&program), TABLE (TOP_NODE (&program))); #if defined HAVE_PARALLEL_CLAUSE set_par_level (TOP_NODE (&program), 0); #endif set_nest (TOP_NODE (&program), NO_NODE); set_proc_level (TOP_NODE (&program), 1); } num = 0; renumber_nodes (TOP_NODE (&program), &num); verbosity (); } /* Mode table builder */ if (ERROR_COUNT (&program) == 0) { announce_phase ("mode table builder"); make_moid_list (&program); verbosity (); } CROSS_REFERENCE_SAFE (&program) = A68_TRUE; /* Symbol table builder */ if (ERROR_COUNT (&program) == 0) { announce_phase ("symbol table builder"); collect_taxes (TOP_NODE (&program)); verbosity (); } /* Post parser */ if (ERROR_COUNT (&program) == 0) { announce_phase ("parser phase 4"); rearrange_goto_less_jumps (TOP_NODE (&program)); num = 0; /* renumber_nodes (TOP_NODE (&program), &num); */ verbosity (); } /* Mode checker */ if (ERROR_COUNT (&program) == 0) { announce_phase ("mode checker"); mode_checker (TOP_NODE (&program)); /* renumber_moids (TOP_MOID (&program), 0); */ verbosity (); } /* Coercion inserter */ if (ERROR_COUNT (&program) == 0) { announce_phase ("coercion enforcer"); coercion_inserter (TOP_NODE (&program)); widen_denotation (TOP_NODE (&program)); get_max_simplout_size (TOP_NODE (&program)); set_moid_sizes (TOP_MOID (&program)); assign_offsets_table (a68g_standenv); assign_offsets (TOP_NODE (&program)); assign_offsets_packs (TOP_MOID (&program)); num = 0; renumber_nodes (TOP_NODE (&program), &num); verbosity (); } /* Application checker */ if (ERROR_COUNT (&program) == 0) { announce_phase ("application checker"); mark_moids (TOP_NODE (&program)); mark_auxilliary (TOP_NODE (&program)); jumps_from_procs (TOP_NODE (&program)); warn_for_unused_tags (TOP_NODE (&program)); verbosity (); } /* Scope checker */ if (ERROR_COUNT (&program) == 0) { announce_phase ("static scope checker"); tie_label_to_serial (TOP_NODE (&program)); tie_label_to_unit (TOP_NODE (&program)); bind_routine_tags_to_tree (TOP_NODE (&program)); bind_format_tags_to_tree (TOP_NODE (&program)); scope_checker (TOP_NODE (&program)); verbosity (); } /* Portability checker */ if (ERROR_COUNT (&program) == 0) { announce_phase ("portability checker"); portcheck (TOP_NODE (&program)); verbosity (); } /* Finalise syntax tree */ if (ERROR_COUNT (&program) == 0) { num = 0; renumber_nodes (TOP_NODE (&program), &num); NEST (TABLE (TOP_NODE (&program))) = symbol_table_count = 3; reset_symbol_table_nest_count (TOP_NODE (&program)); verbosity (); } /* Compiler */ if (ERROR_COUNT (&program) == 0 && OPTION_OPTIMISE (&program)) { announce_phase ("optimiser (code generator)"); num = 0; renumber_nodes (TOP_NODE (&program), &num); node_register = (NODE_T **) get_heap_space ((size_t) num * sizeof (NODE_T)); ABEND (node_register == NO_VAR, "compiler cannot register nodes", NO_TEXT); register_nodes (TOP_NODE (&program)); FILE_OBJECT_FD (&program) = open (FILE_OBJECT_NAME (&program), O_WRONLY | O_CREAT | O_TRUNC, A68_PROTECTION); ABEND (FILE_OBJECT_FD (&program) == -1, "cannot open object file", NO_TEXT); FILE_OBJECT_OPENED (&program) = A68_TRUE; compiler (FILE_OBJECT_FD (&program)); ASSERT (close (FILE_OBJECT_FD (&program)) == 0); FILE_OBJECT_OPENED (&program) = A68_FALSE; emitted = A68_TRUE; } #if defined HAVE_COMPILER /* Only compile C if the A68 compiler found no errors (constant folder for instance) */ if (ERROR_COUNT (&program) == 0 && OPTION_OPTIMISE (&program) && !OPTION_RUN_SCRIPT (&program)) { char cmd[BUFFER_SIZE], options[BUFFER_SIZE], *optimisation, extra_inc[BUFFER_SIZE]; #if defined HAVE_USR_LOCAL_PGSQL_INCLUDE ASSERT (snprintf (extra_inc, SNPRINTF_SIZE, "-I. -I%s -I/usr/local/pgsql/include", INCLUDEDIR) >= 0); #elif defined HAVE_USR_PKG_PGSQL_INCLUDE ASSERT (snprintf (extra_inc, SNPRINTF_SIZE, "-I. -I%s -I/usr/pkg/pgsql/include", INCLUDEDIR) >= 0); #elif defined HAVE_OPT_LOCAL_PGSQL_INCLUDE ASSERT (snprintf (extra_inc, SNPRINTF_SIZE, "-I. -I%s -I/opt/local/pgsql/include", INCLUDEDIR) >= 0); #else ASSERT (snprintf (extra_inc, SNPRINTF_SIZE, "-I. -I%s", INCLUDEDIR) >= 0); #endif switch (OPTION_OPT_LEVEL (&program)) { case 0: { optimisation = "-O0"; break; } case 1: { optimisation = "-O1"; break; } case 2: { optimisation = "-O2"; break; } case 3: { optimisation = "-O3"; break; } default: { optimisation = "-O2"; break; } } if (OPTION_RERUN (&program) == A68_FALSE) { announce_phase ("optimiser (code compiler)"); /*-------------------------------------------------------------+ | Build shared library using gcc. | | TODO: One day this should be all portable between platforms. | +-------------------------------------------------------------*/ /* Compilation on Linux, FreeBSD or NetBSD using gcc */ #if (defined HAVE_LINUX || defined HAVE_FREEBSD || defined HAVE_NETBSD) #if defined HAVE_TUNING ASSERT (snprintf (options, SNPRINTF_SIZE, "%s %s %s -g", extra_inc, optimisation, HAVE_TUNING) >= 0); #else ASSERT (snprintf (options, SNPRINTF_SIZE, "%s %s -g", extra_inc, optimisation) >= 0); #endif #if defined HAVE_PIC bufcat (options, " ", BUFFER_SIZE); bufcat (options, HAVE_PIC, BUFFER_SIZE); #endif ASSERT (snprintf (cmd, SNPRINTF_SIZE, "gcc %s -c -o \"%s\" \"%s\"", options, FILE_BINARY_NAME (&program), FILE_OBJECT_NAME (&program)) >= 0); if (OPTION_VERBOSE (&program)) { WRITELN (STDOUT_FILENO, cmd); } ABEND (system (cmd) != 0, "cannot compile", cmd); ASSERT (snprintf (cmd, SNPRINTF_SIZE, "ld -export-dynamic -shared -o \"%s\" \"%s\"", FILE_LIBRARY_NAME (&program), FILE_BINARY_NAME (&program)) >= 0); if (OPTION_VERBOSE (&program)) { WRITELN (STDOUT_FILENO, cmd); } ABEND (system (cmd) != 0, "cannot link", cmd); ABEND (remove (FILE_BINARY_NAME (&program)) != 0, "cannot remove", cmd); /* Compilation on Mac OS X using gcc */ #elif defined HAVE_MAC_OS_X #if defined HAVE_TUNING ASSERT (snprintf (options, SNPRINTF_SIZE, "%s %s %s -g -fno-common -dynamic", extra_inc, optimisation, HAVE_TUNING) >= 0); #else ASSERT (snprintf (options, SNPRINTF_SIZE, "%s %s -g -fno-common -dynamic", extra_inc, optimisation) >= 0); #endif #if defined HAVE_PIC bufcat (options, " ", BUFFER_SIZE); bufcat (options, HAVE_PIC, BUFFER_SIZE); #endif ASSERT (snprintf (cmd, SNPRINTF_SIZE, "gcc %s -c -o \"%s\" \"%s\"", options, FILE_BINARY_NAME (&program), FILE_OBJECT_NAME (&program)) >= 0); if (OPTION_VERBOSE (&program)) { WRITELN (STDOUT_FILENO, cmd); } ABEND (system (cmd) != 0, "cannot compile", cmd); ASSERT (snprintf (cmd, SNPRINTF_SIZE, "libtool -dynamic -flat_namespace -undefined suppress -o %s %s", FILE_LIBRARY_NAME (&program), FILE_BINARY_NAME (&program)) >= 0); if (OPTION_VERBOSE (&program)) { WRITELN (STDOUT_FILENO, cmd); } ABEND (system (cmd) != 0, "cannot link", cmd); ABEND (remove (FILE_BINARY_NAME (&program)) != 0, "cannot remove", cmd); #endif } verbosity (); } #else if (OPTION_OPTIMISE (&program)) { diagnostic_node (A68_WARNING | A68_FORCE_DIAGNOSTICS, TOP_NODE (&program), WARNING_OPTIMISATION); } #endif /* Indenter */ if (ERROR_COUNT (&program) == 0 && OPTION_PRETTY (&program)) { announce_phase ("indenter"); indenter (&program); verbosity (); } /* Interpreter */ diagnostics_to_terminal (TOP_LINE (&program), A68_ALL_DIAGNOSTICS); if (ERROR_COUNT (&program) == 0 && OPTION_COMPILE (&program) == A68_FALSE && (OPTION_CHECK_ONLY (&program) ? OPTION_RUN (&program) : A68_TRUE)) { #if defined HAVE_COMPILER void * compile_lib; #endif #if defined HAVE_COMPILER if (OPTION_RUN_SCRIPT (&program)) { rewrite_script_source (); } #endif if (OPTION_DEBUG (&program)) { state_license (STDOUT_FILENO); } #if defined HAVE_COMPILER if (OPTION_OPTIMISE (&program)) { char libname[BUFFER_SIZE]; void * a68g_lib; struct stat srcstat, objstat; int ret; announce_phase ("dynamic linker"); ASSERT (snprintf (libname, SNPRINTF_SIZE, "./%s", FILE_LIBRARY_NAME (&program)) >= 0); /* Check whether we are doing something rash */ ret = stat (FILE_SOURCE_NAME (&program), &srcstat); ABEND (ret != 0, "cannot stat", FILE_SOURCE_NAME (&program)); ret = stat (libname, &objstat); ABEND (ret != 0, "cannot stat", libname); if (OPTION_RERUN (&program)) { ABEND (ST_MTIME (&srcstat) > ST_MTIME (&objstat), "source file is younger than library", "do not specify RERUN"); } /* First load a68g itself so compiler code can resolve a68g symbols */ a68g_lib = dlopen (NULL, RTLD_NOW | RTLD_GLOBAL); ABEND (a68g_lib == NULL, "compiler cannot resolve a68g symbols", dlerror ()); /* Then load compiler code */ compile_lib = dlopen (libname, RTLD_NOW | RTLD_GLOBAL); ABEND (compile_lib == NULL, "compiler cannot resolve symbols", dlerror ()); } else { compile_lib = NULL; } announce_phase ("genie"); genie (compile_lib); /* Unload compiler library */ if (OPTION_OPTIMISE (&program)) { int ret = dlclose (compile_lib); ABEND (ret != 0, "cannot close shared library", dlerror ()); } #else genie (NO_NODE); #endif /* Free heap allocated by genie */ free_genie_heap (TOP_NODE (&program)); /* Normal end of program */ diagnostics_to_terminal (TOP_LINE (&program), A68_RUNTIME_ERROR); if (OPTION_DEBUG (&program) || OPTION_TRACE (&program) || OPTION_CLOCK (&program)) { ASSERT (snprintf (output_line, SNPRINTF_SIZE, "\nGenie finished in %.2f seconds\n", seconds () - cputime_0) >= 0); WRITE (STDOUT_FILENO, output_line); } verbosity (); } /* Setting up listing file */ if (OPTION_MOID_LISTING (&program) || OPTION_TREE_LISTING (&program) || OPTION_SOURCE_LISTING (&program) || OPTION_OBJECT_LISTING (&program) || OPTION_STATISTICS_LISTING (&program)) { FILE_LISTING_FD (&program) = open (FILE_LISTING_NAME (&program), O_WRONLY | O_CREAT | O_TRUNC, A68_PROTECTION); ABEND (FILE_LISTING_FD (&program) == -1, "cannot open listing file", NO_TEXT); FILE_LISTING_OPENED (&program) = A68_TRUE; } else { FILE_LISTING_OPENED (&program) = A68_FALSE; } /* Write listing */ if (FILE_LISTING_OPENED (&program)) { heap_is_fluid = A68_TRUE; write_listing_header (); write_source_listing (); write_tree_listing (); if (ERROR_COUNT (&program) == 0 && OPTION_OPTIMISE (&program)) { write_object_listing (); } write_listing (); ASSERT (close (FILE_LISTING_FD (&program)) == 0); FILE_LISTING_OPENED (&program) = A68_FALSE; verbosity (); } /* Cleaning up the intermediate files */ #if defined HAVE_COMPILER if (OPTION_RUN_SCRIPT (&program) && !OPTION_KEEP (&program)) { if (emitted) { ABEND (remove (FILE_OBJECT_NAME (&program)) != 0, "cannot remove", FILE_OBJECT_NAME (&program)); } ABEND (remove (FILE_SOURCE_NAME (&program)) != 0, "cannot remove", FILE_SOURCE_NAME (&program)); ABEND (remove (FILE_LIBRARY_NAME (&program)) != 0, "cannot remove", FILE_LIBRARY_NAME (&program)); } else if (OPTION_COMPILE (&program) && !OPTION_KEEP (&program)) { build_script (); if (emitted) { ABEND (remove (FILE_OBJECT_NAME (&program)) != 0, "cannot remove", FILE_OBJECT_NAME (&program)); } ABEND (remove (FILE_LIBRARY_NAME (&program)) != 0, "cannot remove", FILE_LIBRARY_NAME (&program)); } else if (OPTION_OPTIMISE (&program) && !OPTION_KEEP (&program)) { if (emitted) { ABEND (remove (FILE_OBJECT_NAME (&program)) != 0, "cannot remove", FILE_OBJECT_NAME (&program)); } } else if (OPTION_RERUN (&program) && !OPTION_KEEP (&program)) { if (emitted) { ABEND (remove (FILE_OBJECT_NAME (&program)) != 0, "cannot remove", FILE_OBJECT_NAME (&program)); } } #endif } /*! \brief exit a68g in an orderly manner \param code exit code **/ void a68g_exit (int code) { /* char name[BUFFER_SIZE]; bufcpy (name, ".", BUFFER_SIZE); bufcat (name, a68g_cmd_name, BUFFER_SIZE); bufcat (name, ".x", BUFFER_SIZE); (void) (remove (name)); */ /* Close unclosed files, remove temp files */ free_file_entries (); /* Close the terminal */ io_close_tty_line (); #if defined HAVE_CURSES /* "curses" might still be open if it was not closed from A68, or the program was interrupted, or a runtime error occured. That wreaks havoc on your terminal */ genie_curses_end (NO_NODE); #endif exit (code); } /*! \brief start bookkeeping for a phase \param t name of phase **/ static void announce_phase (char *t) { if (OPTION_VERBOSE (&program)) { ASSERT (snprintf (output_line, SNPRINTF_SIZE, "%s: %s", a68g_cmd_name, t) >= 0); io_close_tty_line (); WRITE (STDOUT_FILENO, output_line); } } #if defined HAVE_COMPILER /*! \brief build shell script from program **/ static void build_script (void) { int ret; FILE_T script, source; LINE_T *sl; char cmd[BUFFER_SIZE]; #if ! defined HAVE_COMPILER return; #endif announce_phase ("script builder"); /* Flatten the source file */ ASSERT (snprintf (cmd, SNPRINTF_SIZE, "%s.%s", HIDDEN_TEMP_FILE_NAME, FILE_SOURCE_NAME (&program)) >= 0); source = open (cmd, O_WRONLY | O_CREAT | O_TRUNC, A68_PROTECTION); ABEND (source == -1, "cannot flatten source file", cmd); for (sl = TOP_LINE (&program); sl != NO_LINE; FORWARD (sl)) { if (strlen (STRING (sl)) == 0 || (STRING (sl))[strlen (STRING (sl)) - 1] != NEWLINE_CHAR) { ASSERT (snprintf (cmd, SNPRINTF_SIZE, "%s\n%d\n%s\n", FILENAME (sl), NUMBER (sl), STRING (sl)) >= 0); } else { ASSERT (snprintf (cmd, SNPRINTF_SIZE, "%s\n%d\n%s", FILENAME (sl), NUMBER (sl), STRING (sl)) >= 0); } WRITE (source, cmd); } ASSERT (close (source) == 0); /* Compress source and library */ ASSERT (snprintf (cmd, SNPRINTF_SIZE, "cp %s %s.%s", FILE_LIBRARY_NAME (&program), HIDDEN_TEMP_FILE_NAME, FILE_LIBRARY_NAME (&program)) >= 0); ret = system (cmd); ABEND (ret != 0, "cannot copy", cmd); ASSERT (snprintf (cmd, SNPRINTF_SIZE, "tar czf %s.%s.tgz %s.%s %s.%s", HIDDEN_TEMP_FILE_NAME, FILE_GENERIC_NAME (&program), HIDDEN_TEMP_FILE_NAME, FILE_SOURCE_NAME (&program), HIDDEN_TEMP_FILE_NAME, FILE_LIBRARY_NAME (&program)) >= 0); ret = system (cmd); ABEND (ret != 0, "cannot compress", cmd); /* Compose script */ ASSERT (snprintf (cmd, SNPRINTF_SIZE, "%s.%s", HIDDEN_TEMP_FILE_NAME, FILE_SCRIPT_NAME (&program)) >= 0); script = open (cmd, O_WRONLY | O_CREAT | O_TRUNC, A68_PROTECTION); ABEND (script == -1, "cannot compose script file", cmd); if (OPTION_LOCAL (&program)) { ASSERT (snprintf (output_line, SNPRINTF_SIZE, "#! ./a68g --run-script\n") >= 0); } else { ASSERT (snprintf (output_line, SNPRINTF_SIZE, "#! %s/a68g --run-script\n", BINDIR) >= 0); } WRITE (script, output_line); ASSERT (snprintf (output_line, SNPRINTF_SIZE, "%s\n--verify \"%s\"\n", FILE_GENERIC_NAME (&program), PACKAGE_STRING) >= 0); WRITE (script, output_line); ASSERT (close (script) == 0); ASSERT (snprintf (cmd, SNPRINTF_SIZE, "cat %s.%s %s.%s.tgz > %s", HIDDEN_TEMP_FILE_NAME, FILE_SCRIPT_NAME (&program), HIDDEN_TEMP_FILE_NAME, FILE_GENERIC_NAME (&program), FILE_SCRIPT_NAME (&program)) >= 0); ret = system (cmd); ABEND (ret != 0, "cannot compose script file", cmd); ASSERT (snprintf (cmd, SNPRINTF_SIZE, "%s", FILE_SCRIPT_NAME (&program)) >= 0); ret = chmod (cmd, (__mode_t) (S_IRUSR | S_IWUSR | S_IXUSR | S_IRGRP | S_IROTH)); /* -rwx-r--r-- */ ABEND (ret != 0, "cannot compose script file", cmd); ABEND (ret != 0, "cannot remove", cmd); /* Clean up */ ASSERT (snprintf (cmd, SNPRINTF_SIZE, "%s.%s.tgz", HIDDEN_TEMP_FILE_NAME, FILE_GENERIC_NAME (&program)) >= 0); ret = remove (cmd); ABEND (ret != 0, "cannot remove", cmd); ASSERT (snprintf (cmd, SNPRINTF_SIZE, "%s.%s", HIDDEN_TEMP_FILE_NAME, FILE_SOURCE_NAME (&program)) >= 0); ret = remove (cmd); ABEND (ret != 0, "cannot remove", cmd); ASSERT (snprintf (cmd, SNPRINTF_SIZE, "%s.%s", HIDDEN_TEMP_FILE_NAME, FILE_LIBRARY_NAME (&program)) >= 0); ret = remove (cmd); ABEND (ret != 0, "cannot remove", cmd); ASSERT (snprintf (cmd, SNPRINTF_SIZE, "%s.%s", HIDDEN_TEMP_FILE_NAME, FILE_SCRIPT_NAME (&program)) >= 0); ret = remove (cmd); ABEND (ret != 0, "cannot remove", cmd); } #endif #if defined HAVE_COMPILER /*! \brief load program from shell script **/ static void load_script (void) { int k; FILE_T script; char cmd[BUFFER_SIZE], ch; #if ! defined HAVE_COMPILER return; #endif announce_phase ("script loader"); /* Decompress the archive */ ASSERT (snprintf (cmd, SNPRINTF_SIZE, "sed '1,3d' < %s | tar xzf -", FILE_INITIAL_NAME (&program)) >= 0); ABEND (system (cmd) != 0, "cannot decompress", cmd); /* Reread the header */ script = open (FILE_INITIAL_NAME (&program), O_RDONLY); ABEND (script == -1, "cannot open script file", cmd); /* Skip the #! a68g line */ ASSERT (io_read (script, &ch, 1) == 1); while (ch != NEWLINE_CHAR) { ASSERT (io_read (script, &ch, 1) == 1); } /* Read the generic filename */ input_line[0] = NULL_CHAR; k = 0; ASSERT (io_read (script, &ch, 1) == 1); while (ch != NEWLINE_CHAR) { input_line[k++] = ch; ASSERT (io_read (script, &ch, 1) == 1); } input_line[k] = NULL_CHAR; ASSERT (snprintf (cmd, SNPRINTF_SIZE, "%s.%s", HIDDEN_TEMP_FILE_NAME, input_line) >= 0); FILE_INITIAL_NAME (&program) = new_string (cmd, NO_TEXT); /* Read options */ input_line[0] = NULL_CHAR; k = 0; ASSERT (io_read (script, &ch, 1) == 1); while (ch != NEWLINE_CHAR) { input_line[k++] = ch; ASSERT (io_read (script, &ch, 1) == 1); } isolate_options (input_line, NO_LINE); (void) set_options (OPTION_LIST (&program), A68_FALSE); ASSERT (close (script) == 0); } #endif #if defined HAVE_COMPILER /*! \brief rewrite source for shell script **/ static void rewrite_script_source (void) { LINE_T * ref_l = NO_LINE; FILE_T source; /* Rebuild the source file */ ASSERT (remove (FILE_SOURCE_NAME (&program)) == 0); source = open (FILE_SOURCE_NAME (&program), O_WRONLY | O_CREAT | O_TRUNC, A68_PROTECTION); ABEND (source == -1, "cannot rewrite source file", FILE_SOURCE_NAME (&program)); for (ref_l = TOP_LINE (&program); ref_l != NO_LINE; FORWARD (ref_l)) { WRITE (source, STRING (ref_l)); if (strlen (STRING (ref_l)) == 0 || (STRING (ref_l))[strlen (STRING (ref_l) - 1)] != NEWLINE_CHAR) { WRITE (source, NEWLINE_STRING); } } /* Wrap it up */ ASSERT (close (source) == 0); } #endif /* This code handles options to Algol68G. Option syntax does not follow GNU standards. Options come from: [1] A rc file (normally .a68grc). [2] The A68G_OPTIONS environment variable overrules [1]. [3] Command line options overrule [2]. [4] Pragmat items overrule [3]. */ OPTIONS_T *options; /*! \brief set default values for options **/ void default_options (MODULE_T *p) { OPTION_NO_WARNINGS (p) = A68_TRUE; OPTION_BACKTRACE (p) = A68_FALSE; OPTION_BRACKETS (p) = A68_FALSE; OPTION_CHECK_ONLY (p) = A68_FALSE; OPTION_CLOCK (p) = A68_FALSE; OPTION_COMPILE (p) = A68_FALSE; OPTION_CROSS_REFERENCE (p) = A68_FALSE; OPTION_DEBUG (p) = A68_FALSE; OPTION_INDENT (p) = 2; OPTION_FOLD (p) = A68_FALSE; OPTION_KEEP (p) = A68_FALSE; OPTION_LOCAL (p) = A68_FALSE; OPTION_MOID_LISTING (p) = A68_FALSE; OPTION_NODEMASK (p) = (STATUS_MASK) (ASSERT_MASK | SOURCE_MASK); OPTION_OPT_LEVEL (p) = 0; OPTION_OPTIMISE (p) = A68_FALSE; OPTION_PORTCHECK (p) = A68_FALSE; OPTION_PRAGMAT_SEMA (p) = A68_TRUE; OPTION_PRETTY (p) = A68_FALSE; OPTION_QUIET (p) = A68_FALSE; OPTION_REDUCTIONS (p) = A68_FALSE; OPTION_REGRESSION_TEST (p) = A68_FALSE; OPTION_RERUN (p) = A68_FALSE; OPTION_RUN (p) = A68_FALSE; OPTION_RUN_SCRIPT (p) = A68_FALSE; OPTION_SOURCE_LISTING (p) = A68_FALSE; OPTION_STANDARD_PRELUDE_LISTING (p) = A68_FALSE; OPTION_STATISTICS_LISTING (p) = A68_FALSE; OPTION_STRICT (p) = A68_FALSE; OPTION_STROPPING (p) = UPPER_STROPPING; OPTION_TIME_LIMIT (p) = 0; OPTION_TRACE (p) = A68_FALSE; OPTION_TREE_LISTING (p) = A68_FALSE; OPTION_UNUSED (p) = A68_FALSE; OPTION_VERBOSE (p) = A68_FALSE; OPTION_VERSION (p) = A68_FALSE; OPTION_EDIT (p) = A68_FALSE; OPTION_TARGET (p) = NO_TEXT; } /*! \brief error handler for options \param l source line \param option option text \param info info text **/ static void option_error (LINE_T * l, char *option, char *info) { int k; ASSERT (snprintf (output_line, SNPRINTF_SIZE, "%s", option) >= 0); for (k = 0; output_line[k] != NULL_CHAR; k++) { output_line[k] = (char) TO_LOWER (output_line[k]); } if (info != NO_TEXT) { ASSERT (snprintf (edit_line, SNPRINTF_SIZE, "error: %s option \"%s\"", info, output_line) >= 0); } else { ASSERT (snprintf (edit_line, SNPRINTF_SIZE, "error: in option \"%s\"", output_line) >= 0); } scan_error (l, NO_TEXT, edit_line); } /*! \brief strip minus preceeding a string \param p text to strip \return stripped string **/ static char *strip_sign (char *p) { while (p[0] == '-' || p[0] == '+') { p++; } return (new_string (p, NO_TEXT)); } /*! \brief add an option to the list, to be processed later \param l option chain to link into \param str option text \param line source line **/ void add_option_list (OPTION_LIST_T ** l, char *str, LINE_T * line) { if (*l == NO_OPTION_LIST) { *l = (OPTION_LIST_T *) get_heap_space ((size_t) ALIGNED_SIZE_OF (OPTION_LIST_T)); SCAN (*l) = SOURCE_SCAN (&program); STR (*l) = new_string (str, NO_TEXT); PROCESSED (*l) = A68_FALSE; LINE (*l) = line; NEXT (*l) = NO_OPTION_LIST; } else { add_option_list (&(NEXT (*l)), str, line); } } /*! \brief initialise option handler **/ void init_options (void) { options = (OPTIONS_T *) malloc ((size_t) ALIGNED_SIZE_OF (OPTIONS_T)); OPTION_LIST (&program) = NO_OPTION_LIST; } /*! \brief test equality of p and q, upper case letters in q are mandatory \param p string to match \param q pattern \return whether equal **/ static BOOL_T eq (char *p, char *q) { /* Upper case letters in 'q' are mandatory, lower case must match */ if (OPTION_PRAGMAT_SEMA (&program)) { return (match_string (p, q, '=')); } else { return (A68_FALSE); } } /*! \brief process echoes gathered in the option list \param i option chain **/ void prune_echoes (OPTION_LIST_T * i) { while (i != NO_OPTION_LIST) { if (SCAN (i) == SOURCE_SCAN (&program)) { char *p = strip_sign (STR (i)); /* ECHO echoes a string */ if (eq (p, "ECHO")) { { char *car = a68g_strchr (p, '='); if (car != NO_TEXT) { io_close_tty_line (); ASSERT (snprintf (output_line, SNPRINTF_SIZE, "%s", &car[1]) >= 0); WRITE (STDOUT_FILENO, output_line); } else { FORWARD (i); if (i != NO_OPTION_LIST) { if (strcmp (STR (i), "=") == 0) { FORWARD (i); } if (i != NO_OPTION_LIST) { io_close_tty_line (); ASSERT (snprintf (output_line, SNPRINTF_SIZE, "%s", STR (i)) >= 0); WRITE (STDOUT_FILENO, output_line); } } } } } } FORWARD (i); } } /*! \brief translate integral option argument \param p text \param i option chain \param error whether error \return argument value **/ static int fetch_integral (char *p, OPTION_LIST_T ** i, BOOL_T * error) { LINE_T *start_l = LINE (*i); char *start_c = STR (*i); char *car = NO_TEXT, *num = NO_TEXT; int k, mult = 1; *error = A68_FALSE; /* Fetch argument */ car = a68g_strchr (p, '='); if (car == NO_TEXT) { FORWARD (*i); *error = (BOOL_T) (*i == NO_OPTION_LIST); if (!error && strcmp (STR (*i), "=") == 0) { FORWARD (*i); *error = (BOOL_T) (*i == NO_OPTION_LIST); } if (!*error) { num = STR (*i); } } else { num = &car[1]; *error = (BOOL_T) (num[0] == NULL_CHAR); } /* Translate argument into integer */ if (*error) { option_error (start_l, start_c, "integer value required by"); return (0); } else { char *suffix; RESET_ERRNO; k = (int) strtol (num, &suffix, 0); /* Accept also octal and hex */ *error = (BOOL_T) (suffix == num); if (errno != 0 || *error) { option_error (start_l, start_c, "conversion error in"); *error = A68_TRUE; } else if (k < 0) { option_error (start_l, start_c, "negative value in"); *error = A68_TRUE; } else { /* Accept suffix multipliers: 32k, 64M, 1G */ if (suffix != NO_TEXT) { switch (suffix[0]) { case NULL_CHAR: { mult = 1; break; } case 'k': case 'K': { mult = KILOBYTE; break; } case 'm': case 'M': { mult = MEGABYTE; break; } case 'g': case 'G': { mult = GIGABYTE; break; } default: { option_error (start_l, start_c, "unknown suffix in"); *error = A68_TRUE; break; } } if (suffix[0] != NULL_CHAR && suffix[1] != NULL_CHAR) { option_error (start_l, start_c, "unknown suffix in"); *error = A68_TRUE; } } } if ((double) k * (double) mult > (double) A68_MAX_INT) { errno = ERANGE; option_error (start_l, start_c, "conversion overflow in"); } return (k * mult); } } /*! \brief process options gathered in the option list \param i option chain \param cmd_line whether command line argument \return whether processing was successful **/ BOOL_T set_options (OPTION_LIST_T * i, BOOL_T cmd_line) { BOOL_T go_on = A68_TRUE, name_set = A68_FALSE, skip = A68_FALSE; OPTION_LIST_T *j = i; RESET_ERRNO; while (i != NO_OPTION_LIST && go_on) { /* Once SCRIPT is processed we skip options on the command line */ if (cmd_line && skip) { FORWARD (i); } else { LINE_T *start_l = LINE (i); char *start_c = STR (i); int n = (int) strlen (STR (i)); /* Allow for spaces ending in # to have A68 comment syntax with '#!' */ while (n > 0 && (IS_SPACE((STR (i))[n - 1]) || (STR (i))[n - 1] == '#')) { (STR (i))[--n] = NULL_CHAR; } if (!(PROCESSED (i))) { /* Accept UNIX '-option [=] value' */ BOOL_T minus_sign = (BOOL_T) ((STR (i))[0] == '-'); char *p = strip_sign (STR (i)); if (!minus_sign && eq (p, "#")) { ; } else if (!minus_sign && cmd_line) { /* Item without '-'s is a filename */ if (!name_set) { FILE_INITIAL_NAME (&program) = new_string (p, NO_TEXT); name_set = A68_TRUE; } else { option_error (NO_LINE, start_c, "multiple source file names at"); } } /* Preprocessor items stop option processing */ else if (eq (p, "INCLUDE")) { go_on = A68_FALSE; } else if (eq (p, "READ")) { go_on = A68_FALSE; } else if (eq (p, "PREPROCESSOR")) { go_on = A68_FALSE; } else if (eq (p, "NOPREPROCESSOR")) { go_on = A68_FALSE; } /* EXIT stops option processing */ else if (eq (p, "EXIT")) { go_on = A68_FALSE; } /* Empty item (from specifying '-' or '--') stops option processing */ else if (eq (p, "")) { go_on = A68_FALSE; } /* FILE accepts its argument as filename */ else if (eq (p, "File") && cmd_line) { FORWARD (i); if (i != NO_OPTION_LIST && strcmp (STR (i), "=") == 0) { FORWARD (i); } if (i != NO_OPTION_LIST) { if (!name_set) { FILE_INITIAL_NAME (&program) = new_string (STR (i), NO_TEXT); name_set = A68_TRUE; } else { option_error (start_l, start_c, "multiple source file names at"); } } else { option_error (start_l, start_c, "missing argument in"); } } /* TARGET accepts its argument as editor target */ else if (eq (p, "TArget") && cmd_line) { FORWARD (i); if (i != NO_OPTION_LIST && strcmp (STR (i), "=") == 0) { FORWARD (i); } if (i != NO_OPTION_LIST) { OPTION_TARGET (&program) = new_string (STR (i), NO_TEXT); } else { option_error (start_l, start_c, "missing argument in"); } } /* SCRIPT takes next argument as filename. Further options on the command line are not processed, but stored */ else if (eq (p, "Script") && cmd_line) { FORWARD (i); if (i != NO_OPTION_LIST) { if (!name_set) { FILE_INITIAL_NAME (&program) = new_string (STR (i), NO_TEXT); name_set = A68_TRUE; } else { option_error (start_l, start_c, "multiple source file names at"); } } else { option_error (start_l, start_c, "missing argument in"); } skip = A68_TRUE; } /* VERIFY checks that argument is current a68g version number */ else if (eq (p, "VERIFY")) { FORWARD (i); if (i != NO_OPTION_LIST && strcmp (STR (i), "=") == 0) { FORWARD (i); } if (i != NO_OPTION_LIST) { ASSERT (snprintf (output_line, SNPRINTF_SIZE, "%s verification \"%s\" does not match script verification \"%s\"", a68g_cmd_name, PACKAGE_STRING, STR (i)) >= 0); ABEND (strcmp (PACKAGE_STRING, STR (i)) != 0, new_string (output_line, NO_TEXT), "rebuild the script"); } else { option_error (start_l, start_c, "missing argument in"); } } /* HELP gives online help */ else if ((eq (p, "APropos") || eq (p, "Help") || eq (p, "INfo")) && cmd_line) { FORWARD (i); if (i != NO_OPTION_LIST && strcmp (STR (i), "=") == 0) { FORWARD (i); } if (i != NO_OPTION_LIST) { apropos (STDOUT_FILENO, NO_TEXT, STR (i)); } else { apropos (STDOUT_FILENO, NO_TEXT, "options"); } a68g_exit (EXIT_SUCCESS); } /* ECHO is treated later */ else if (eq (p, "ECHO")) { if (a68g_strchr (p, '=') == NO_TEXT) { FORWARD (i); if (i != NO_OPTION_LIST) { if (strcmp (STR (i), "=") == 0) { FORWARD (i); } } } } /* EDIT starts a basic editor */ else if (eq (p, "Edit")) { if (cmd_line == A68_FALSE) { option_error (start_l, start_c, "command-line-only"); } else { OPTION_EDIT (&program) = A68_TRUE; } } /* EXECUTE and PRINT execute their argument as Algol 68 text */ else if (eq (p, "EXECute") || eq (p, "X") || eq (p, "Print")) { if (cmd_line == A68_FALSE) { option_error (start_l, start_c, "command-line-only"); } else if ((FORWARD (i)) != NO_OPTION_LIST) { BOOL_T error = A68_FALSE; if (strcmp (STR (i), "=") == 0) { error = (BOOL_T) ((FORWARD (i)) == NO_OPTION_LIST); } if (!error) { char name[BUFFER_SIZE], new_name[BUFFER_SIZE]; FILE *f; int s_errno = errno; bufcpy (name, HIDDEN_TEMP_FILE_NAME, BUFFER_SIZE); bufcat (name, ".cmd.a68", BUFFER_SIZE); f = a68g_fopen (name, "w", new_name); ABEND (f == NO_FILE, "cannot open temp file", NO_TEXT); errno = s_errno; if (eq (p, "Execute") || eq (p, "X")) { fprintf (f, "(%s)\n", STR (i)); } else { fprintf (f, "(print ((%s)))\n", STR (i)); } ASSERT (fclose (f) == 0); FILE_INITIAL_NAME (&program) = new_string (new_name, NO_TEXT); } else { option_error (start_l, start_c, "unit required by"); } } else { option_error (start_l, start_c, "missing argument in"); } } /* STORAGE, HEAP, HANDLES, STACK, FRAME and OVERHEAD set core allocation */ else if (eq (p, "STOrage")) { BOOL_T error = A68_FALSE; int k = fetch_integral (p, &i, &error); /* Adjust size */ if (error || errno > 0) { option_error (start_l, start_c, "conversion error in"); } else if (k > 0) { default_mem_sizes (k); } } else if (eq (p, "HEAP") || eq (p, "HANDLES") || eq (p, "STACK") || eq (p, "FRAME") || eq (p, "OVERHEAD")) { BOOL_T error = A68_FALSE; int k = fetch_integral (p, &i, &error); /* Adjust size */ if (error || errno > 0) { option_error (start_l, start_c, "conversion error in"); } else if (k > 0) { if (k < MIN_MEM_SIZE) { option_error (start_l, start_c, "value less than minimum in"); k = MIN_MEM_SIZE; } if (eq (p, "HEAP")) { heap_size = k; } else if (eq (p, "HANDLES")) { handle_pool_size = k; } else if (eq (p, "STACK")) { expr_stack_size = k; } else if (eq (p, "FRAME")) { frame_stack_size = k; } else if (eq (p, "OVERHEAD")) { storage_overhead = k; } } } /* COMPILE and NOCOMPILE switch on/off compilation */ else if (eq (p, "Compile")) { #if defined HAVE_LINUX OPTION_COMPILE (&program) = A68_TRUE; OPTION_OPTIMISE (&program) = A68_TRUE; OPTION_OPT_LEVEL (&program) = 2; OPTION_RUN_SCRIPT (&program) = A68_FALSE; #else option_error (start_l, start_c, "linux-only"); #endif } else if (eq (p, "NOCompile")) { OPTION_COMPILE (&program) = A68_FALSE; OPTION_OPTIMISE (&program) = A68_FALSE; OPTION_OPT_LEVEL (&program) = 0; OPTION_RUN_SCRIPT (&program) = A68_FALSE; } else if (eq (p, "NO-Compile")) { OPTION_COMPILE (&program) = A68_FALSE; OPTION_OPTIMISE (&program) = A68_FALSE; OPTION_OPT_LEVEL (&program) = 0; OPTION_RUN_SCRIPT (&program) = A68_FALSE; } /* OPTIMISE and NOOPTIMISE switch on/off optimisation */ else if (eq (p, "OPTimise")) { OPTION_OPTIMISE (&program) = A68_TRUE; OPTION_OPT_LEVEL (&program) = 2; } else if (eq (p, "O0")) { OPTION_OPTIMISE (&program) = A68_TRUE; OPTION_OPT_LEVEL (&program) = 0; } else if (eq (p, "O")) { OPTION_OPTIMISE (&program) = A68_TRUE; OPTION_OPT_LEVEL (&program) = 1; } else if (eq (p, "O1")) { OPTION_OPTIMISE (&program) = A68_TRUE; OPTION_OPT_LEVEL (&program) = 1; } else if (eq (p, "O2")) { OPTION_OPTIMISE (&program) = A68_TRUE; OPTION_OPT_LEVEL (&program) = 2; } else if (eq (p, "O3")) { OPTION_OPTIMISE (&program) = A68_TRUE; OPTION_OPT_LEVEL (&program) = 3; } else if (eq (p, "NOOptimise")) { OPTION_OPTIMISE (&program) = A68_FALSE; OPTION_OPT_LEVEL (&program) = 0; } else if (eq (p, "NO-Optimise")) { OPTION_OPTIMISE (&program) = A68_FALSE; OPTION_OPT_LEVEL (&program) = 0; } else if (eq (p, "NOOptimize")) { OPTION_OPTIMISE (&program) = A68_FALSE; OPTION_OPT_LEVEL (&program) = 0; } else if (eq (p, "NO-Optimize")) { OPTION_OPTIMISE (&program) = A68_FALSE; OPTION_OPT_LEVEL (&program) = 0; } /* RUN-SCRIPT runs a comiled .sh script */ else if (eq (p, "RUN-SCRIPT")) { #if defined HAVE_LINUX FORWARD (i); if (i != NO_OPTION_LIST) { if (!name_set) { FILE_INITIAL_NAME (&program) = new_string (STR (i), NO_TEXT); name_set = A68_TRUE; } else { option_error (start_l, start_c, "multiple source file names at"); } } else { option_error (start_l, start_c, "missing argument in"); } skip = A68_TRUE; OPTION_RUN_SCRIPT (&program) = A68_TRUE; OPTION_COMPILE (&program) = A68_FALSE; OPTION_OPTIMISE (&program) = A68_TRUE; OPTION_OPT_LEVEL (&program) = 2; #else option_error (start_l, start_c, "linux-only"); #endif } /* RERUN re-uses an existing .so file */ else if (eq (p, "RERUN")) { OPTION_COMPILE (&program) = A68_FALSE; OPTION_RERUN (&program) = A68_TRUE; OPTION_OPTIMISE (&program) = A68_TRUE; OPTION_OPT_LEVEL (&program) = 2; } /* KEEP and NOKEEP switch off/on object file deletion */ else if (eq (p, "KEEP")) { OPTION_KEEP (&program) = A68_TRUE; } else if (eq (p, "NOKEEP")) { OPTION_KEEP (&program) = A68_FALSE; } else if (eq (p, "NO-KEEP")) { OPTION_KEEP (&program) = A68_FALSE; } /* BRACKETS extends Algol 68 syntax for brackets */ else if (eq (p, "BRackets")) { OPTION_BRACKETS (&program) = A68_TRUE; } /* PRETTY and INDENT perform basic pretty printing. This is meant for synthetic code. */ else if (eq (p, "PRETty-print")) { OPTION_PRETTY (&program) = A68_TRUE; OPTION_CHECK_ONLY (&program) = A68_TRUE; } else if (eq (p, "INDENT")) { OPTION_PRETTY (&program) = A68_TRUE; OPTION_CHECK_ONLY (&program) = A68_TRUE; } /* FOLD performs constant folding in basic lay-out formatting. */ else if (eq (p, "FOLD")) { OPTION_INDENT (&program) = A68_TRUE; OPTION_FOLD (&program) = A68_TRUE; OPTION_CHECK_ONLY (&program) = A68_TRUE; } /* REDUCTIONS gives parser reductions.*/ else if (eq (p, "REDuctions")) { OPTION_REDUCTIONS (&program) = A68_TRUE; } /* QUOTESTROPPING sets stropping to quote stropping */ else if (eq (p, "QUOTEstropping")) { OPTION_STROPPING (&program) = QUOTE_STROPPING; } else if (eq (p, "QUOTE-stropping")) { OPTION_STROPPING (&program) = QUOTE_STROPPING; } /* UPPERSTROPPING sets stropping to upper stropping, which is nowadays the expected default */ else if (eq (p, "UPPERstropping")) { OPTION_STROPPING (&program) = UPPER_STROPPING; } else if (eq (p, "UPPER-stropping")) { OPTION_STROPPING (&program) = UPPER_STROPPING; } /* CHECK and NORUN just check for syntax */ else if (eq (p, "Check") || eq (p, "NORun") || eq (p, "NO-Run")) { OPTION_CHECK_ONLY (&program) = A68_TRUE; } /* CLOCK times program execution */ else if (eq (p, "CLock")) { OPTION_CLOCK (&program) = A68_TRUE; } /* RUN overrides NORUN */ else if (eq (p, "RUN")) { OPTION_RUN (&program) = A68_TRUE; } /* MONITOR or DEBUG invokes the debugger at runtime errors */ else if (eq (p, "MONitor") || eq (p, "DEBUG")) { OPTION_DEBUG (&program) = A68_TRUE; } /* REGRESSION is an option that sets preferences when running the test suite - undocumented option */ else if (eq (p, "REGRESSION")) { OPTION_NO_WARNINGS (&program) = A68_FALSE; OPTION_PORTCHECK (&program) = A68_TRUE; OPTION_REGRESSION_TEST (&program) = A68_TRUE; OPTION_TIME_LIMIT (&program) = 120; OPTION_KEEP (&program) = A68_TRUE; term_width = MAX_TERM_WIDTH; } /* LOCAL assumes include files in the current directory - undocumented option */ else if (eq (p, "LOCal")) { OPTION_LOCAL (&program) = A68_TRUE; } /* NOWARNINGS switches unsuppressible warnings off */ else if (eq (p, "NOWarnings")) { OPTION_NO_WARNINGS (&program) = A68_TRUE; } else if (eq (p, "NO-Warnings")) { OPTION_NO_WARNINGS (&program) = A68_TRUE; } /* QUIET switches all warnings off */ else if (eq (p, "Quiet")) { OPTION_QUIET (&program) = A68_TRUE; } /* WARNINGS switches warnings on */ else if (eq (p, "Warnings")) { OPTION_NO_WARNINGS (&program) = A68_FALSE; } /* NOPORTCHECK switches portcheck off */ else if (eq (p, "NOPORTcheck")) { OPTION_PORTCHECK (&program) = A68_FALSE; } else if (eq (p, "NO-PORTcheck")) { OPTION_PORTCHECK (&program) = A68_FALSE; } /* PORTCHECK switches portcheck on */ else if (eq (p, "PORTcheck")) { OPTION_PORTCHECK (&program) = A68_TRUE; } /* PEDANTIC switches portcheck and warnings on */ else if (eq (p, "PEDANTIC")) { OPTION_PORTCHECK (&program) = A68_TRUE; OPTION_NO_WARNINGS (&program) = A68_FALSE; } /* PRAGMATS and NOPRAGMATS switch on/off pragmat processing */ else if (eq (p, "PRagmats")) { OPTION_PRAGMAT_SEMA (&program) = A68_TRUE; } else if (eq (p, "NOPRagmats")) { OPTION_PRAGMAT_SEMA (&program) = A68_FALSE; } else if (eq (p, "NO-PRagmats")) { OPTION_PRAGMAT_SEMA (&program) = A68_FALSE; } /* STRICT ignores A68G extensions to A68 syntax */ else if (eq (p, "STRict")) { OPTION_STRICT (&program) = A68_TRUE; OPTION_PORTCHECK (&program) = A68_TRUE; } /* VERBOSE in case you want to know what Algol68G is doing */ else if (eq (p, "VERBose")) { OPTION_VERBOSE (&program) = A68_TRUE; } /* VERSION lists the current version at an appropriate time in the future */ else if (eq (p, "Version")) { OPTION_VERSION (&program) = A68_TRUE; } /* XREF and NOXREF switch on/off a cross reference */ else if (eq (p, "XREF")) { OPTION_SOURCE_LISTING (&program) = A68_TRUE; OPTION_CROSS_REFERENCE (&program) = A68_TRUE; OPTION_NODEMASK (&program) |= (CROSS_REFERENCE_MASK | SOURCE_MASK); } else if (eq (p, "NOXREF")) { OPTION_NODEMASK (&program) &= ~(CROSS_REFERENCE_MASK | SOURCE_MASK); } else if (eq (p, "NO-Xref")) { OPTION_NODEMASK (&program) &= ~(CROSS_REFERENCE_MASK | SOURCE_MASK); } /* PRELUDELISTING cross references preludes, if they ever get implemented .. */ else if (eq (p, "PRELUDElisting")) { OPTION_STANDARD_PRELUDE_LISTING (&program) = A68_TRUE; } /* STATISTICS prints process statistics */ else if (eq (p, "STatistics")) { OPTION_STATISTICS_LISTING (&program) = A68_TRUE; } /* TREE and NOTREE switch on/off printing of the syntax tree. This gets bulky! */ else if (eq (p, "TREE")) { OPTION_SOURCE_LISTING (&program) = A68_TRUE; OPTION_TREE_LISTING (&program) = A68_TRUE; OPTION_NODEMASK (&program) |= (TREE_MASK | SOURCE_MASK); } else if (eq (p, "NOTREE")) { OPTION_NODEMASK (&program) ^= (TREE_MASK | SOURCE_MASK); } else if (eq (p, "NO-TREE")) { OPTION_NODEMASK (&program) ^= (TREE_MASK | SOURCE_MASK); } /* UNUSED indicates unused tags */ else if (eq (p, "UNUSED")) { OPTION_UNUSED (&program) = A68_TRUE; } /* EXTENSIVE set of options for an extensive listing */ else if (eq (p, "EXTensive")) { OPTION_SOURCE_LISTING (&program) = A68_TRUE; OPTION_OBJECT_LISTING (&program) = A68_TRUE; OPTION_TREE_LISTING (&program) = A68_TRUE; OPTION_CROSS_REFERENCE (&program) = A68_TRUE; OPTION_MOID_LISTING (&program) = A68_TRUE; OPTION_STANDARD_PRELUDE_LISTING (&program) = A68_TRUE; OPTION_STATISTICS_LISTING (&program) = A68_TRUE; OPTION_UNUSED (&program) = A68_TRUE; OPTION_NODEMASK (&program) |= (CROSS_REFERENCE_MASK | TREE_MASK | CODE_MASK | SOURCE_MASK); } /* LISTING set of options for a default listing */ else if (eq (p, "Listing")) { OPTION_SOURCE_LISTING (&program) = A68_TRUE; OPTION_CROSS_REFERENCE (&program) = A68_TRUE; OPTION_STATISTICS_LISTING (&program) = A68_TRUE; OPTION_NODEMASK (&program) |= (SOURCE_MASK | CROSS_REFERENCE_MASK); } /* TTY send listing to standout. Remnant from my mainframe past */ else if (eq (p, "TTY")) { OPTION_CROSS_REFERENCE (&program) = A68_TRUE; OPTION_STATISTICS_LISTING (&program) = A68_TRUE; OPTION_NODEMASK (&program) |= (SOURCE_MASK | CROSS_REFERENCE_MASK); } /* SOURCE and NOSOURCE print source lines */ else if (eq (p, "SOURCE")) { OPTION_SOURCE_LISTING (&program) = A68_TRUE; OPTION_NODEMASK (&program) |= SOURCE_MASK; } else if (eq (p, "NOSOURCE")) { OPTION_NODEMASK (&program) &= ~SOURCE_MASK; } else if (eq (p, "NO-SOURCE")) { OPTION_NODEMASK (&program) &= ~SOURCE_MASK; } /* OBJECT and NOOBJECT print object lines */ else if (eq (p, "OBJECT")) { OPTION_OBJECT_LISTING (&program) = A68_TRUE; } else if (eq (p, "NOOBJECT")) { OPTION_OBJECT_LISTING (&program) = A68_FALSE; } else if (eq (p, "NO-OBJECT")) { OPTION_OBJECT_LISTING (&program) = A68_FALSE; } /* MOIDS prints an overview of moids used in the program */ else if (eq (p, "MOIDS")) { OPTION_MOID_LISTING (&program) = A68_TRUE; } /* ASSERTIONS and NOASSERTIONS switch on/off the processing of assertions */ else if (eq (p, "Assertions")) { OPTION_NODEMASK (&program) |= ASSERT_MASK; } else if (eq (p, "NOAssertions")) { OPTION_NODEMASK (&program) &= ~ASSERT_MASK; } else if (eq (p, "NO-Assertions")) { OPTION_NODEMASK (&program) &= ~ASSERT_MASK; } /* PRECISION sets the precision */ else if (eq (p, "PRECision")) { BOOL_T error = A68_FALSE; int k = fetch_integral (p, &i, &error); if (error || errno > 0) { option_error (start_l, start_c, "conversion error in"); } else if (k > 1) { if (int_to_mp_digits (k) > long_mp_digits ()) { set_longlong_mp_digits (int_to_mp_digits (k)); } else { k = 1; while (int_to_mp_digits (k) <= long_mp_digits ()) { k++; } option_error (start_l, start_c, "value less than minimum in"); } } else { option_error (start_l, start_c, "invalid value in"); } } /* BACKTRACE and NOBACKTRACE switch on/off stack backtracing */ else if (eq (p, "BACKtrace")) { OPTION_BACKTRACE (&program) = A68_TRUE; } else if (eq (p, "NOBACKtrace")) { OPTION_BACKTRACE (&program) = A68_FALSE; } else if (eq (p, "NO-BACKtrace")) { OPTION_BACKTRACE (&program) = A68_FALSE; } /* BREAK and NOBREAK switch on/off tracing of the running program */ else if (eq (p, "BReakpoint")) { OPTION_NODEMASK (&program) |= BREAKPOINT_MASK; } else if (eq (p, "NOBReakpoint")) { OPTION_NODEMASK (&program) &= ~BREAKPOINT_MASK; } else if (eq (p, "NO-BReakpoint")) { OPTION_NODEMASK (&program) &= ~BREAKPOINT_MASK; } /* TRACE and NOTRACE switch on/off tracing of the running program */ else if (eq (p, "TRace")) { OPTION_TRACE (&program) = A68_TRUE; OPTION_NODEMASK (&program) |= BREAKPOINT_TRACE_MASK; } else if (eq (p, "NOTRace")) { OPTION_NODEMASK (&program) &= ~BREAKPOINT_TRACE_MASK; } else if (eq (p, "NO-TRace")) { OPTION_NODEMASK (&program) &= ~BREAKPOINT_TRACE_MASK; } /* TIMELIMIT lets the interpreter stop after so-many seconds */ else if (eq (p, "TImelimit") || eq (p, "TIME-Limit")) { BOOL_T error = A68_FALSE; int k = fetch_integral (p, &i, &error); if (error || errno > 0) { option_error (start_l, start_c, "conversion error in"); } else if (k < 1) { option_error (start_l, start_c, "invalid time span in"); } else { OPTION_TIME_LIMIT (&program) = k; } } else { /* Unrecognised */ option_error (start_l, start_c, "unrecognised"); } } /* Go processing next item, if present */ if (i != NO_OPTION_LIST) { FORWARD (i); } } } /* Mark options as processed */ for (; j != NO_OPTION_LIST; FORWARD (j)) { PROCESSED (j) = A68_TRUE; } return ((BOOL_T) (errno == 0)); } /*! \brief set default core size **/ static void default_mem_sizes (int n) { if (n < 0 || n > 20) { n = 1; } frame_stack_size = 6 * n * MEGABYTE; expr_stack_size = 2 * n * MEGABYTE; heap_size = 48 * n * MEGABYTE; handle_pool_size = 8 * n * MEGABYTE; storage_overhead = MIN_MEM_SIZE; } /*! \brief read options from the .rc file **/ void read_rc_options (void) { FILE *f; char name[BUFFER_SIZE], new_name[BUFFER_SIZE]; ASSERT (snprintf (name, SNPRINTF_SIZE, ".%src", a68g_cmd_name) >= 0); f = a68g_fopen (name, "r", new_name); if (f != NO_FILE) { while (!feof (f)) { if (fgets (input_line, BUFFER_SIZE, f) != NO_TEXT) { if (input_line[strlen (input_line) - 1] == NEWLINE_CHAR) { input_line[strlen (input_line) - 1] = NULL_CHAR; } isolate_options (input_line, NO_LINE); } } ASSERT (fclose (f) == 0); (void) set_options (OPTION_LIST (&program), A68_FALSE); } else { errno = 0; } } /*! \brief read options from A68G_OPTIONS **/ void read_env_options (void) { if (getenv ("A68G_OPTIONS") != NULL) { isolate_options (getenv ("A68G_OPTIONS"), NO_LINE); (void) set_options (OPTION_LIST (&program), A68_FALSE); errno = 0; } } /*! \brief tokenise string 'p' that holds options \param p text \param line source line **/ void isolate_options (char *p, LINE_T * line) { char *q; /* 'q' points at first significant char in item .*/ while (p[0] != NULL_CHAR) { /* Skip white space etc */ while ((p[0] == BLANK_CHAR || p[0] == TAB_CHAR || p[0] == ',' || p[0] == NEWLINE_CHAR) && p[0] != NULL_CHAR) { p++; } /* ... then tokenise an item */ if (p[0] != NULL_CHAR) { /* Item can be "string". Note that these are not A68 strings */ if (p[0] == QUOTE_CHAR || p[0] == '\'' || p[0] == '`') { char delim = p[0]; p++; q = p; while (p[0] != delim && p[0] != NULL_CHAR) { p++; } if (p[0] != NULL_CHAR) { p[0] = NULL_CHAR; /* p[0] was delimiter */ p++; } else { scan_error (line, NO_TEXT, ERROR_UNTERMINATED_STRING); } } else { /* Item is not a delimited string */ q = p; /* Tokenise symbol and gather it in the option list for later processing. Skip '='s, we accept if someone writes -prec=60 -heap=8192 */ if (*q == '=') { p++; } else { /* Skip item */ while (p[0] != BLANK_CHAR && p[0] != NULL_CHAR && p[0] != '=' && p[0] != ',' && p[0] != NEWLINE_CHAR) { p++; } } if (p[0] != NULL_CHAR) { p[0] = NULL_CHAR; p++; } } /* 'q' points to first significant char in item, and 'p' points after item */ add_option_list (&(OPTION_LIST (&program)), q, line); } } } /* Routines for making a listing file */ #define SHOW_EQ A68_FALSE char *bar[BUFFER_SIZE]; /*! \brief brief_mode_string \param p moid to print \return pointer to string **/ static void a68g_print_short_mode (FILE_T f, MOID_T * z) { if (IS (z, STANDARD)) { int i = DIM (z); if (i > 0) { while (i--) { WRITE (f, "LONG "); } } else if (i < 0) { while (i++) { WRITE (f, "SHORT "); } } ASSERT (snprintf (output_line, SNPRINTF_SIZE, "%s", NSYMBOL (NODE (z))) >= 0); WRITE (f, output_line); } else if (IS (z, REF_SYMBOL) && IS (SUB (z), STANDARD)) { WRITE (f, "REF "); a68g_print_short_mode (f, SUB (z)); } else if (IS (z, PROC_SYMBOL) && PACK (z) == NO_PACK && IS (SUB (z), STANDARD)) { WRITE (f, "PROC "); a68g_print_short_mode (f, SUB (z)); } else { ASSERT (snprintf (output_line, SNPRINTF_SIZE, "#%d", NUMBER (z)) >= 0); WRITE (f, output_line); } } /*! \brief a68g_print_flat_mode \param f file number \param z moid to print **/ void a68g_print_flat_mode (FILE_T f, MOID_T * z) { if (IS (z, STANDARD)) { int i = DIM (z); if (i > 0) { while (i--) { WRITE (f, "LONG "); } } else if (i < 0) { while (i++) { WRITE (f, "SHORT "); } } ASSERT (snprintf (output_line, SNPRINTF_SIZE, "%s", NSYMBOL (NODE (z))) >= 0); WRITE (f, output_line); } else if (IS (z, REF_SYMBOL)) { ASSERT (snprintf (output_line, SNPRINTF_SIZE, "REF ") >= 0); WRITE (f, output_line); a68g_print_short_mode (f, SUB (z)); } else if (IS (z, PROC_SYMBOL) && DIM (z) == 0) { ASSERT (snprintf (output_line, SNPRINTF_SIZE, "PROC ") >= 0); WRITE (f, output_line); a68g_print_short_mode (f, SUB (z)); } else if (IS (z, ROW_SYMBOL)) { int i = DIM (z); WRITE (f, "["); while (--i) { WRITE (f, ", "); } WRITE (f, "] "); a68g_print_short_mode (f, SUB (z)); } else { a68g_print_short_mode (f, z); } } /*! \brief brief_fields_flat \param f file number \param pack pack to print **/ static void a68g_print_short_pack (FILE_T f, PACK_T * pack) { if (pack != NO_PACK) { a68g_print_short_mode (f, MOID (pack)); if (NEXT (pack) != NO_PACK) { ASSERT (snprintf (output_line, SNPRINTF_SIZE, ", ") >= 0); WRITE (f, output_line); a68g_print_short_pack (f, NEXT (pack)); } } } /*! \brief a68g_print_mode \param f file number \param z moid to print **/ void a68g_print_mode (FILE_T f, MOID_T * z) { if (z != NO_MOID) { if (IS (z, STANDARD)) { a68g_print_flat_mode (f, z); } else if (IS (z, INDICANT)) { WRITE (f, NSYMBOL (NODE (z))); } else if (z == MODE (COLLITEM)) { WRITE (f, "\"COLLITEM\""); } else if (IS (z, REF_SYMBOL)) { WRITE (f, "REF "); a68g_print_flat_mode (f, SUB (z)); } else if (IS (z, FLEX_SYMBOL)) { WRITE (f, "FLEX "); a68g_print_flat_mode (f, SUB (z)); } else if (IS (z, ROW_SYMBOL)) { int i = DIM (z); WRITE (f, "["); while (--i) { WRITE (f, ", "); } WRITE (f, "] "); a68g_print_flat_mode (f, SUB (z)); } else if (IS (z, STRUCT_SYMBOL)) { WRITE (f, "STRUCT ("); a68g_print_short_pack (f, PACK (z)); WRITE (f, ")"); } else if (IS (z, UNION_SYMBOL)) { WRITE (f, "UNION ("); a68g_print_short_pack (f, PACK (z)); WRITE (f, ")"); } else if (IS (z, PROC_SYMBOL)) { WRITE (f, "PROC "); if (PACK (z) != NO_PACK) { WRITE (f, "("); a68g_print_short_pack (f, PACK (z)); WRITE (f, ") "); } a68g_print_flat_mode (f, SUB (z)); } else if (IS (z, IN_TYPE_MODE)) { WRITE (f, "\"SIMPLIN\""); } else if (IS (z, OUT_TYPE_MODE)) { WRITE (f, "\"SIMPLOUT\""); } else if (IS (z, ROWS_SYMBOL)) { WRITE (f, "\"ROWS\""); } else if (IS (z, SERIES_MODE)) { WRITE (f, "\"SERIES\" ("); a68g_print_short_pack (f, PACK (z)); WRITE (f, ")"); } else if (IS (z, STOWED_MODE)) { WRITE (f, "\"STOWED\" ("); a68g_print_short_pack (f, PACK (z)); WRITE (f, ")"); } } } /*! \brief print_mode_flat \param f file number \param m moid to print **/ void print_mode_flat (FILE_T f, MOID_T * m) { if (m != NO_MOID) { a68g_print_mode (f, m); if (NODE (m) != NO_NODE && NUMBER (NODE (m)) > 0) { ASSERT (snprintf (output_line, SNPRINTF_SIZE, " node %d", NUMBER (NODE (m))) >= 0); WRITE (f, output_line); } if (EQUIVALENT_MODE (m) != NO_MOID) { ASSERT (snprintf (output_line, SNPRINTF_SIZE, " equi #%d", NUMBER (EQUIVALENT (m))) >= 0); WRITE (f, output_line); } if (SLICE (m) != NO_MOID) { ASSERT (snprintf (output_line, SNPRINTF_SIZE, " slice #%d", NUMBER (SLICE (m))) >= 0); WRITE (f, output_line); } if (TRIM (m) != NO_MOID) { ASSERT (snprintf (output_line, SNPRINTF_SIZE, " trim #%d", NUMBER (TRIM (m))) >= 0); WRITE (f, output_line); } if (ROWED (m) != NO_MOID) { ASSERT (snprintf (output_line, SNPRINTF_SIZE, " rowed #%d", NUMBER (ROWED (m))) >= 0); WRITE (f, output_line); } if (DEFLEXED (m) != NO_MOID) { ASSERT (snprintf (output_line, SNPRINTF_SIZE, " deflex #%d", NUMBER (DEFLEXED (m))) >= 0); WRITE (f, output_line); } if (MULTIPLE (m) != NO_MOID) { ASSERT (snprintf (output_line, SNPRINTF_SIZE, " multiple #%d", NUMBER (MULTIPLE (m))) >= 0); WRITE (f, output_line); } if (NAME (m) != NO_MOID) { ASSERT (snprintf (output_line, SNPRINTF_SIZE, " name #%d", NUMBER (NAME (m))) >= 0); WRITE (f, output_line); } if (USE (m)) { ASSERT (snprintf (output_line, SNPRINTF_SIZE, " used") >= 0); WRITE (f, output_line); } if (DERIVATE (m)) { ASSERT (snprintf (output_line, SNPRINTF_SIZE, " derivate") >= 0); WRITE (f, output_line); } if (SIZE (m) > 0) { ASSERT (snprintf (output_line, SNPRINTF_SIZE, " size %d", MOID_SIZE (m)) >= 0); WRITE (f, output_line); } if (HAS_ROWS (m)) { WRITE (f, " []"); } } } /*! \brief xref_tags \param f file number \param s tag to print \param a attribute **/ static void xref_tags (FILE_T f, TAG_T * s, int a) { for (; s != NO_TAG; FORWARD (s)) { NODE_T *where_tag = NODE (s); if ((where_tag != NO_NODE) && ((STATUS_TEST (where_tag, CROSS_REFERENCE_MASK)) || TAG_TABLE (s) == a68g_standenv)) { WRITE (f, "\n "); ASSERT (snprintf (output_line, SNPRINTF_SIZE, "tag %d ", NUMBER (s)) >= 0); WRITE (f, output_line); switch (a) { case IDENTIFIER: { a68g_print_mode (f, MOID (s)); ASSERT (snprintf (output_line, SNPRINTF_SIZE, " %s", NSYMBOL (NODE (s))) >= 0); WRITE (f, output_line); break; } case INDICANT: { ASSERT (snprintf (output_line, SNPRINTF_SIZE, "indicant %s ", NSYMBOL (NODE (s))) >= 0); WRITE (f, output_line); a68g_print_mode (f, MOID (s)); break; } case PRIO_SYMBOL: { ASSERT (snprintf (output_line, SNPRINTF_SIZE, "priority %s %d", NSYMBOL (NODE (s)), PRIO (s)) >= 0); WRITE (f, output_line); break; } case OP_SYMBOL: { ASSERT (snprintf (output_line, SNPRINTF_SIZE, "operator %s ", NSYMBOL (NODE (s))) >= 0); WRITE (f, output_line); a68g_print_mode (f, MOID (s)); break; } case LABEL: { ASSERT (snprintf (output_line, SNPRINTF_SIZE, "label %s", NSYMBOL (NODE (s))) >= 0); WRITE (f, output_line); break; } case ANONYMOUS: { switch (PRIO (s)) { case ROUTINE_TEXT: { ASSERT (snprintf (output_line, SNPRINTF_SIZE, "routine text ") >= 0); break; } case FORMAT_TEXT: { ASSERT (snprintf (output_line, SNPRINTF_SIZE, "format text ") >= 0); break; } case FORMAT_IDENTIFIER: { ASSERT (snprintf (output_line, SNPRINTF_SIZE, "format item ") >= 0); break; } case COLLATERAL_CLAUSE: { ASSERT (snprintf (output_line, SNPRINTF_SIZE, "display ") >= 0); break; } case GENERATOR: { ASSERT (snprintf (output_line, SNPRINTF_SIZE, "generator ") >= 0); break; } } WRITE (f, output_line); a68g_print_mode (f, MOID (s)); break; } default: { ASSERT (snprintf (output_line, SNPRINTF_SIZE, "internal %d ", a) >= 0); WRITE (f, output_line); a68g_print_mode (f, MOID (s)); break; } } if (NODE (s) != NO_NODE && NUMBER (NODE (s)) > 0) { ASSERT (snprintf (output_line, SNPRINTF_SIZE, ", node %d", NUMBER (NODE (s))) >= 0); WRITE (f, output_line); } if (where_tag != NO_NODE && INFO (where_tag) != NO_NINFO && LINE (INFO (where_tag)) != NO_LINE) { ASSERT (snprintf (output_line, SNPRINTF_SIZE, ", line %d", LINE_NUMBER (where_tag)) >= 0); WRITE (f, output_line); } } } } /*! \brief xref_decs \param f file number \param t symbol table **/ static void xref_decs (FILE_T f, TABLE_T * t) { if (INDICANTS (t) != NO_TAG) { xref_tags (f, INDICANTS (t), INDICANT); } if (OPERATORS (t) != NO_TAG) { xref_tags (f, OPERATORS (t), OP_SYMBOL); } if (PRIO (t) != NO_TAG) { xref_tags (f, PRIO (t), PRIO_SYMBOL); } if (IDENTIFIERS (t) != NO_TAG) { xref_tags (f, IDENTIFIERS (t), IDENTIFIER); } if (LABELS (t) != NO_TAG) { xref_tags (f, LABELS (t), LABEL); } if (ANONYMOUS (t) != NO_TAG) { xref_tags (f, ANONYMOUS (t), ANONYMOUS); } } /*! \brief xref1_moid \param f file number \param p moid to xref **/ static void xref1_moid (FILE_T f, MOID_T * p) { ASSERT (snprintf (output_line, SNPRINTF_SIZE, "\n #%d ", NUMBER (p)) >= 0); WRITE (f, output_line); print_mode_flat (f, p); } /*! \brief moid_listing \param f file number \param m moid list to xref **/ void moid_listing (FILE_T f, MOID_T * m) { for (; m != NO_MOID; FORWARD (m)) { xref1_moid (f, m); } WRITE (f, "\n"); ASSERT (snprintf (output_line, SNPRINTF_SIZE, "\n MODE STRING #%d ", NUMBER (MODE (STRING))) >= 0); WRITE (f, output_line); ASSERT (snprintf (output_line, SNPRINTF_SIZE, "\n MODE COMPLEX #%d ", NUMBER (MODE (COMPLEX))) >= 0); WRITE (f, output_line); ASSERT (snprintf (output_line, SNPRINTF_SIZE, "\n MODE SEMA #%d ", NUMBER (MODE (SEMA))) >= 0); WRITE (f, output_line); } /*! \brief cross_reference \param file number \param p top node \param l source line **/ static void cross_reference (FILE_T f, NODE_T * p, LINE_T * l) { if (p != NO_NODE && CROSS_REFERENCE_SAFE (&program)) { for (; p != NO_NODE; FORWARD (p)) { if (is_new_lexical_level (p) && l == LINE (INFO (p))) { TABLE_T *c = TABLE (SUB (p)); ASSERT (snprintf (output_line, SNPRINTF_SIZE, "\n\n[level %d", LEVEL (c)) >= 0); WRITE (f, output_line); if (PREVIOUS (c) == a68g_standenv) { ASSERT (snprintf (output_line, SNPRINTF_SIZE, ", in standard environ") >= 0); } else { ASSERT (snprintf (output_line, SNPRINTF_SIZE, ", in level %d", LEVEL (PREVIOUS (c))) >= 0); } WRITE (f, output_line); ASSERT (snprintf (output_line, SNPRINTF_SIZE, ", %d increment]", AP_INCREMENT (c)) >= 0); WRITE (f, output_line); if (c != NO_TABLE) { xref_decs (f, c); } WRITE (f, "\n"); } cross_reference (f, SUB (p), l); } } } /*! \brief write_symbols \param file number \param p top node \param count symbols written static void write_symbols (FILE_T f, NODE_T * p, int *count) { for (; p != NO_NODE && (*count) < 5; FORWARD (p)) { if (SUB (p) != NO_NODE) { write_symbols (f, SUB (p), count); } else { if (*count > 0) { WRITE (f, " "); } (*count)++; if (*count == 5) { WRITE (f, "..."); } else { ASSERT (snprintf(output_line, SNPRINTF_SIZE, "%s", NSYMBOL (p)) >= 0); WRITE (f, output_line); } } } } **/ /*! \brief tree_listing \param f file number \param q top node \param x current level \param l source line \param ld index for indenting and drawing bars connecting nodes **/ void tree_listing (FILE_T f, NODE_T * q, int x, LINE_T * l, int *ld) { for (; q != NO_NODE; FORWARD (q)) { NODE_T *p = q; int k, dist; if (((STATUS_TEST (p, TREE_MASK))) && l == LINE (INFO (p))) { if (*ld < 0) { *ld = x; } /* Indent */ WRITE (f, "\n "); ASSERT (snprintf (output_line, SNPRINTF_SIZE, "%02d %06d p%02d ", x, NUMBER (p), PROCEDURE_LEVEL (INFO (p))) >= 0); WRITE (f, output_line); if (PREVIOUS (TABLE (p)) != NO_TABLE) { ASSERT (snprintf (output_line, SNPRINTF_SIZE, "%02d-%02d-%02d ", (TABLE (p) != NO_TABLE ? LEX_LEVEL (p) : 0), (TABLE (p) != NO_TABLE ? LEVEL (PREVIOUS (TABLE (p))) : 0), (NON_LOCAL (p) != NO_TABLE ? LEVEL (NON_LOCAL (p)) : 0) ) >= 0); } else { ASSERT (snprintf (output_line, SNPRINTF_SIZE, "%02d- -%02d", (TABLE (p) != NO_TABLE ? LEX_LEVEL (p) : 0), (NON_LOCAL (p) != NO_TABLE ? LEVEL (NON_LOCAL (p)) : 0) ) >= 0); } WRITE (f, output_line); if (MOID (q) != NO_MOID) { ASSERT (snprintf (output_line, SNPRINTF_SIZE, "#%04d ", NUMBER (MOID (p))) >= 0); } else { ASSERT (snprintf (output_line, SNPRINTF_SIZE, " ") >= 0); } WRITE (f, output_line); for (k = 0; k < (x - *ld); k++) { WRITE (f, bar[k]); } if (MOID (p) != NO_MOID) { ASSERT (snprintf (output_line, SNPRINTF_SIZE, "%s ", moid_to_string (MOID (p), MOID_WIDTH, NO_NODE)) >= 0); WRITE (f, output_line); } ASSERT (snprintf (output_line, SNPRINTF_SIZE, "%s", non_terminal_string (edit_line, ATTRIBUTE (p))) >= 0); WRITE (f, output_line); if (SUB (p) == NO_NODE) { ASSERT (snprintf (output_line, SNPRINTF_SIZE, " \"%s\"", NSYMBOL (p)) >= 0); WRITE (f, output_line); } if (TAX (p) != NO_TAG) { ASSERT (snprintf (output_line, SNPRINTF_SIZE, ", tag %06u", (unsigned) NUMBER (TAX (p))) >= 0); WRITE (f, output_line); if (MOID (TAX (p)) != NO_MOID) { ASSERT (snprintf (output_line, SNPRINTF_SIZE, ", mode %06u", (unsigned) NUMBER (MOID (TAX (p)))) >= 0); WRITE (f, output_line); } } if (GINFO (p) != NO_GINFO && propagator_name (UNIT (&GPROP (p))) != NO_TEXT) { ASSERT (snprintf (output_line, SNPRINTF_SIZE, ", %s", propagator_name (UNIT (&GPROP (p)))) >= 0); WRITE (f, output_line); } if (GINFO (p) != NO_GINFO && COMPILE_NAME (GINFO (p)) != NO_TEXT) { ASSERT (snprintf (output_line, SNPRINTF_SIZE, ", %s", COMPILE_NAME (GINFO (p))) >= 0); WRITE (f, output_line); } if (GINFO (p) != NO_GINFO && COMPILE_NODE (GINFO (p)) > 0) { ASSERT (snprintf (output_line, SNPRINTF_SIZE, ", %6d", COMPILE_NODE (GINFO (p))) >= 0); WRITE (f, output_line); } } dist = x - (*ld); if (dist >= 0 && dist < BUFFER_SIZE) { bar[dist] = (NEXT (p) != NO_NODE && l == LINE (INFO (NEXT (p))) ? "|" : " "); } tree_listing (f, SUB (p), x + 1, l, ld); dist = x - (*ld); if (dist >= 0 && dist < BUFFER_SIZE) { bar[dist] = " "; } } } /*! \brief leaves_to_print \param p top node \param l source line \return number of nodes to be printed in tree listing **/ static int leaves_to_print (NODE_T * p, LINE_T * l) { int z = 0; for (; p != NO_NODE && z == 0; FORWARD (p)) { if (l == LINE (INFO (p)) && ((STATUS_TEST (p, TREE_MASK)))) { z++; } else { z += leaves_to_print (SUB (p), l); } } return (z); } /*! \brief list_source_line \param f file number \param line source line **/ void list_source_line (FILE_T f, LINE_T * line, BOOL_T tree) { int k = (int) strlen (STRING (line)) - 1; if (NUMBER (line) <= 0) { /* Mask the prelude and postlude */ return; } if ((STRING (line))[k] == NEWLINE_CHAR) { (STRING (line))[k] = NULL_CHAR; } /* Print source line */ write_source_line (f, line, NO_NODE, A68_ALL_DIAGNOSTICS); /* Cross reference for lexical levels starting at this line */ if (OPTION_CROSS_REFERENCE (&program)) { cross_reference (f, TOP_NODE (&program), line); } /* Syntax tree listing connected with this line */ if (tree && OPTION_TREE_LISTING (&program)) { if (TREE_LISTING_SAFE (&program) && leaves_to_print (TOP_NODE (&program), line)) { int ld = -1, k2; WRITE (f, "\n\nSyntax tree"); for (k2 = 0; k2 < BUFFER_SIZE; k2++) { bar[k2] = " "; } tree_listing (f, TOP_NODE (&program), 1, line, &ld); WRITE (f, "\n"); } } } /*! \brief source_listing **/ void write_source_listing (void) { LINE_T *line = TOP_LINE (&program); FILE_T f = FILE_LISTING_FD (&program); int listed = 0; WRITE (FILE_LISTING_FD (&program), NEWLINE_STRING); WRITE (FILE_LISTING_FD (&program), "\nSource listing"); WRITE (FILE_LISTING_FD (&program), "\n------ -------"); WRITE (FILE_LISTING_FD (&program), NEWLINE_STRING); if (FILE_LISTING_OPENED (&program) == 0) { diagnostic_node (A68_ERROR, NO_NODE, ERROR_CANNOT_WRITE_LISTING); return; } for (; line != NO_LINE; FORWARD (line)) { if (NUMBER (line) > 0 && LIST (line)) { listed++; } list_source_line (f, line, A68_FALSE); } /* Warn if there was no source at all */ if (listed == 0) { ASSERT (snprintf (output_line, SNPRINTF_SIZE, "\n No lines to list") >= 0); WRITE (f, output_line); } } /*! \brief write_source_listing **/ void write_tree_listing (void) { LINE_T *line = TOP_LINE (&program); FILE_T f = FILE_LISTING_FD (&program); int listed = 0; WRITE (FILE_LISTING_FD (&program), NEWLINE_STRING); WRITE (FILE_LISTING_FD (&program), "\nSyntax tree listing"); WRITE (FILE_LISTING_FD (&program), "\n------ ---- -------"); WRITE (FILE_LISTING_FD (&program), NEWLINE_STRING); if (FILE_LISTING_OPENED (&program) == 0) { diagnostic_node (A68_ERROR, NO_NODE, ERROR_CANNOT_WRITE_LISTING); return; } for (; line != NO_LINE; FORWARD (line)) { if (NUMBER (line) > 0 && LIST (line)) { listed++; } list_source_line (f, line, A68_TRUE); } /* Warn if there was no source at all */ if (listed == 0) { ASSERT (snprintf (output_line, SNPRINTF_SIZE, "\n No lines to list") >= 0); WRITE (f, output_line); } } /*! \brief write_object_listing **/ void write_object_listing (void) { if (OPTION_OBJECT_LISTING (&program)) { WRITE (FILE_LISTING_FD (&program), NEWLINE_STRING); WRITE (FILE_LISTING_FD (&program), "\nObject listing"); WRITE (FILE_LISTING_FD (&program), "\n------ -------"); WRITE (FILE_LISTING_FD (&program), NEWLINE_STRING); compiler (FILE_LISTING_FD (&program)); } } /*! \brief write_listing **/ void write_listing (void) { FILE_T f = FILE_LISTING_FD (&program); if (OPTION_MOID_LISTING (&program)) { WRITE (FILE_LISTING_FD (&program), NEWLINE_STRING); WRITE (FILE_LISTING_FD (&program), "\nMode listing"); WRITE (FILE_LISTING_FD (&program), "\n---- -------"); WRITE (FILE_LISTING_FD (&program), NEWLINE_STRING); moid_listing (f, TOP_MOID (&program)); } if (OPTION_STANDARD_PRELUDE_LISTING (&program) && a68g_standenv != NO_TABLE) { WRITE (FILE_LISTING_FD (&program), NEWLINE_STRING); WRITE (FILE_LISTING_FD (&program), "\nStandard prelude listing"); WRITE (FILE_LISTING_FD (&program), "\n-------- ------- -------"); WRITE (FILE_LISTING_FD (&program), NEWLINE_STRING); xref_decs (f, a68g_standenv); } if (TOP_REFINEMENT (&program) != NO_REFINEMENT) { REFINEMENT_T *x = TOP_REFINEMENT (&program); WRITE (FILE_LISTING_FD (&program), NEWLINE_STRING); WRITE (FILE_LISTING_FD (&program), "\nRefinement listing"); WRITE (FILE_LISTING_FD (&program), "\n---------- -------"); WRITE (FILE_LISTING_FD (&program), NEWLINE_STRING); while (x != NO_REFINEMENT) { ASSERT (snprintf (output_line, SNPRINTF_SIZE, "\n \"%s\"", NAME (x)) >= 0); WRITE (f, output_line); if (LINE_DEFINED (x) != NO_LINE) { ASSERT (snprintf (output_line, SNPRINTF_SIZE, ", defined in line %d", NUMBER (LINE_DEFINED (x))) >= 0); WRITE (f, output_line); } if (LINE_APPLIED (x) != NO_LINE) { ASSERT (snprintf (output_line, SNPRINTF_SIZE, ", applied in line %d", NUMBER (LINE_APPLIED (x))) >= 0); WRITE (f, output_line); } switch (APPLICATIONS (x)) { case 0: { ASSERT (snprintf (output_line, SNPRINTF_SIZE, ", not applied") >= 0); WRITE (f, output_line); break; } case 1: { break; } default: { ASSERT (snprintf (output_line, SNPRINTF_SIZE, ", applied more than once") >= 0); WRITE (f, output_line); break; } } FORWARD (x); } } if (OPTION_LIST (&program) != NO_OPTION_LIST) { OPTION_LIST_T *i; int k = 1; WRITE (FILE_LISTING_FD (&program), NEWLINE_STRING); WRITE (FILE_LISTING_FD (&program), "\nPragmat listing"); WRITE (FILE_LISTING_FD (&program), "\n------- -------"); WRITE (FILE_LISTING_FD (&program), NEWLINE_STRING); for (i = OPTION_LIST (&program); i != NO_OPTION_LIST; FORWARD (i)) { ASSERT (snprintf (output_line, SNPRINTF_SIZE, "\n%d: %s", k++, STR (i)) >= 0); WRITE (f, output_line); } } } /*! \brief write_listing_header **/ void write_listing_header (void) { FILE_T f = FILE_LISTING_FD (&program); LINE_T * z; state_version (FILE_LISTING_FD (&program)); WRITE (FILE_LISTING_FD (&program), "\nFile \""); WRITE (FILE_LISTING_FD (&program), FILE_SOURCE_NAME (&program)); if (OPTION_STATISTICS_LISTING (&program)) { if (ERROR_COUNT (&program) + WARNING_COUNT (&program) > 0) { ASSERT (snprintf (output_line, SNPRINTF_SIZE, "\nDiagnostics: %d error(s), %d warning(s)", ERROR_COUNT (&program), WARNING_COUNT (&program)) >= 0); WRITE (f, output_line); for (z = TOP_LINE (&program); z != NO_LINE; FORWARD (z)) { if (DIAGNOSTICS (z) != NO_DIAGNOSTIC) { write_source_line (f, z, NO_NODE, A68_TRUE); } } } } } /* Small utility routines */ /*! \brief get terminal size \param h heigth in lines \param c width in columns **/ void a68g_getty (int * h, int * c) { /* Default action first */ (* h) = MAX_TERM_HEIGTH; (* c) = MAX_TERM_WIDTH; #if (defined HAVE_SYS_IOCTL_H && defined TIOCGWINSZ) { struct winsize w; if (ioctl (0, TIOCGWINSZ, &w) == 0) { (* h) = w.ws_row; (* c) = w.ws_col; } } #elif (defined HAVE_SYS_IOCTL_H && defined TIOCGSIZE) { struct ttysize w; (void) ioctl (0, TIOCGSIZE, &w); if (w.ts_lines > 0) { (* h) = w.ts_lines; } if (w.ts_cols > 0) { (* c) = w.ts_cols; } } #elif (defined HAVE_SYS_IOCTL_H && defined WIOCGETD) { struct uwdata w; (void) ioctl (0, WIOCGETD, &w); if (w.uw_heigth > 0 && w.uw_vs != 0) { (* h) = w.uw_heigth / w.uw_vs; } if (w.uw_width > 0 && w.uw_hs != 0) { (* c) = w.uw_width / w.uw_hs; } } #endif } /* Signal handlers */ /*! \brief signal for window resize \param i dummy **/ #if defined SIGWINCH static void sigwinch_handler (int i) { (void) i; ABEND (signal (SIGWINCH, sigwinch_handler) == SIG_ERR, "cannot install SIGWINCH handler", NO_TEXT); a68g_getty (&term_heigth, &term_width); return; } #endif /*! \brief signal reading for segment violation \param i dummy **/ static void sigsegv_handler (int i) { (void) i; exit (EXIT_FAILURE); return; } /*! \brief raise SYSREQUEST so you get to a monitor \param i dummy **/ static void sigint_handler (int i) { (void) i; ABEND (signal (SIGINT, sigint_handler) == SIG_ERR, "cannot install SIGINT handler", NO_TEXT); if (!(STATUS_TEST (TOP_NODE (&program), BREAKPOINT_INTERRUPT_MASK) || in_monitor)) { STATUS_SET (TOP_NODE (&program), BREAKPOINT_INTERRUPT_MASK); genie_break (TOP_NODE (&program)); } } #if ! defined HAVE_WIN32 /*! \brief signal reading from disconnected terminal \param i dummy **/ static void sigttin_handler (int i) { (void) i; ABEND (A68_TRUE, "background process attempts reading from disconnected terminal", NO_TEXT); } /*! \brief signal broken pipe \param i dummy **/ static void sigpipe_handler (int i) { (void) i; ABEND (A68_TRUE, "forked process has broken the pipe", NO_TEXT); } /*! \brief signal alarm - time limit check \param i dummy **/ static void sigalrm_handler (int i) { (void) i; if (in_execution && !in_monitor) { double _m_t = (double) OPTION_TIME_LIMIT (&program); if (_m_t > 0 && (seconds () - cputime_0) > _m_t) { diagnostic_node (A68_RUNTIME_ERROR, (NODE_T *) last_unit, ERROR_TIME_LIMIT_EXCEEDED); exit_genie ((NODE_T *) last_unit, A68_RUNTIME_ERROR); } } (void) alarm (1); } #endif /* ! defined HAVE_WIN32 */ /*! \brief install_signal_handlers **/ void install_signal_handlers (void) { ABEND (signal (SIGINT, sigint_handler) == SIG_ERR, "cannot install SIGINT handler", NO_TEXT); ABEND (signal (SIGSEGV, sigsegv_handler) == SIG_ERR, "cannot install SIGSEGV handler", NO_TEXT); #if defined SIGWINCH ABEND (signal (SIGWINCH, sigwinch_handler) == SIG_ERR, "cannot install SIGWINCH handler", NO_TEXT); #endif #if ! defined HAVE_WIN32 ABEND (signal (SIGALRM, sigalrm_handler) == SIG_ERR, "cannot install SIGALRM handler", NO_TEXT); ABEND (signal (SIGPIPE, sigpipe_handler) == SIG_ERR, "cannot install SIGPIPE handler", NO_TEXT); ABEND (signal (SIGTTIN, sigttin_handler) == SIG_ERR, "cannot install SIGTTIN handler", NO_TEXT); #endif /* ! defined HAVE_WIN32 */ } ADDR_T fixed_heap_pointer, temp_heap_pointer; POSTULATE_T *top_postulate, *top_postulate_list; KEYWORD_T *top_keyword; TOKEN_T *top_token; BOOL_T heap_is_fluid; static int tag_number = 0; /*! \brief pointer to block of "s" bytes \param s block lenght in bytes \return same **/ BYTE_T *get_heap_space (size_t s) { BYTE_T *z = (BYTE_T *) (A68_ALIGN_T *) malloc (A68_ALIGN (s)); ABEND (z == NO_BYTE, ERROR_OUT_OF_CORE, NO_TEXT); return (z); } /*! \brief make a new copy of concatenated strings \param t text \return pointer **/ char *new_string (char *t, ...) { va_list vl; char *q, *z; int len = 0; va_start (vl, t); q = t; while (q != NO_TEXT) { len += (int) strlen (q); q = va_arg (vl, char *); } va_end (vl); len ++; z = (char *) get_heap_space ((size_t) len); z[0] = NULL_CHAR; q = t; va_start (vl, t); while (q != NO_TEXT) { bufcat (z, q, len); q = va_arg (vl, char *); } va_end (vl); return (z); } /*! \brief make a new copy of "t" \param t text \return pointer **/ char *new_fixed_string (char *t) { int n = (int) (strlen (t) + 1); char *z = (char *) get_fixed_heap_space ((size_t) n); bufcpy (z, t, n); return (z); } /*! \brief make a new copy of "t" \param t text \return pointer **/ char *new_temp_string (char *t) { int n = (int) (strlen (t) + 1); char *z = (char *) get_temp_heap_space ((size_t) n); bufcpy (z, t, n); return (z); } /*! \brief get (preferably fixed) heap space \param s size in bytes \return pointer to block **/ BYTE_T *get_fixed_heap_space (size_t s) { BYTE_T *z; if (heap_is_fluid) { z = HEAP_ADDRESS (fixed_heap_pointer); fixed_heap_pointer += A68_ALIGN ((int) s); /* Allow for extra storage for diagnostics etcetera */ ABEND (fixed_heap_pointer >= (heap_size - MIN_MEM_SIZE), ERROR_OUT_OF_CORE, NO_TEXT); ABEND (((int) temp_heap_pointer - (int) fixed_heap_pointer) <= MIN_MEM_SIZE, ERROR_OUT_OF_CORE, NO_TEXT); return (z); } else { return (get_heap_space (s)); } } /*! \brief get (preferably temporary) heap space \param s size in bytes \return pointer to block **/ BYTE_T *get_temp_heap_space (size_t s) { BYTE_T *z; /* ABEND (!heap_is_fluid, ERROR_INTERNAL_CONSISTENCY, NO_TEXT); */ if (heap_is_fluid) { temp_heap_pointer -= A68_ALIGN ((int) s); /* Allow for extra storage for diagnostics etcetera */ ABEND (((int) temp_heap_pointer - (int) fixed_heap_pointer) <= MIN_MEM_SIZE, ERROR_OUT_OF_CORE, NO_TEXT); z = HEAP_ADDRESS (temp_heap_pointer); return (z); } else { return (get_heap_space (s)); } } /*! \brief get size of stack segment **/ void get_stack_size (void) { #if defined HAVE_WIN32 stack_size = MEGABYTE; /* guess */ #else struct rlimit limits; RESET_ERRNO; /* Some systems do not implement RLIMIT_STACK so if getrlimit fails, we do not abend */ if (!(getrlimit (RLIMIT_STACK, &limits) == 0 && errno == 0)) { stack_size = MEGABYTE; } stack_size = (int) (RLIM_CUR (&limits) < RLIM_MAX (&limits) ? RLIM_CUR (&limits) : RLIM_MAX (&limits)); /* A heuristic in case getrlimit yields extreme numbers: the frame stack is assumed to fill at a rate comparable to the C stack, so the C stack needs not be larger than the frame stack. This may not be true */ if (stack_size < KILOBYTE || (stack_size > 96 * MEGABYTE && stack_size > frame_stack_size)) { stack_size = frame_stack_size; } #endif stack_limit = (stack_size > (4 * storage_overhead) ? (stack_size - storage_overhead) : stack_size / 2); } /*! \brief convert integer to character \param i integer \return character **/ char digit_to_char (int i) { char *z = "0123456789abcdefghijklmnopqrstuvwxyz"; if (i >= 0 && i < (int) strlen (z)) { return (z[i]); } else { return ('*'); } } /*! \brief renumber nodes \param p position in tree \param n node number counter **/ void renumber_nodes (NODE_T * p, int *n) { for (; p != NO_NODE; FORWARD (p)) { NUMBER (p) = (*n)++; renumber_nodes (SUB (p), n); } } /*! \brief register nodes \param p position in tree **/ void register_nodes (NODE_T * p) { for (; p != NO_NODE; FORWARD (p)) { node_register[NUMBER (p)] = p; register_nodes (SUB (p)); } } /*! \brief new_node_info \return same **/ NODE_INFO_T *new_node_info (void) { NODE_INFO_T *z = (NODE_INFO_T *) get_fixed_heap_space ((size_t) ALIGNED_SIZE_OF (NODE_INFO_T)); new_node_infos++; PROCEDURE_LEVEL (z) = 0; CHAR_IN_LINE (z) = NO_TEXT; SYMBOL (z) = NO_TEXT; PRAGMENT (z) = NO_TEXT; PRAGMENT_TYPE (z) = 0; LINE (z) = NO_LINE; return (z); } /*! \brief new_genie_info \return same **/ GINFO_T *new_genie_info (void) { GINFO_T *z = (GINFO_T *) get_fixed_heap_space ((size_t) ALIGNED_SIZE_OF (GINFO_T)); new_genie_infos++; UNIT (&PROP (z)) = NO_PPROC; SOURCE (&PROP (z)) = NO_NODE; PARTIAL_PROC (z) = NO_MOID; PARTIAL_LOCALE (z) = NO_MOID; IS_COERCION (z) = A68_FALSE; IS_NEW_LEXICAL_LEVEL (z) = A68_FALSE; NEED_DNS (z) = A68_FALSE; PARENT (z) = NO_NODE; OFFSET (z) = NO_BYTE; CONSTANT (z) = NO_CONSTANT; LEVEL (z) = 0; ARGSIZE (z) = 0; SIZE (z) = 0; COMPILE_NAME (z) = NO_TEXT; COMPILE_NODE (z) = 0; return (z); } /*! \brief new_node \return same **/ NODE_T *new_node (void) { NODE_T *z = (NODE_T *) get_fixed_heap_space ((size_t) ALIGNED_SIZE_OF (NODE_T)); new_nodes++; STATUS (z) = NULL_MASK; CODEX (z) = NULL_MASK; TABLE (z) = NO_TABLE; INFO (z) = NO_NINFO; GINFO (z) = NO_GINFO; ATTRIBUTE (z) = 0; ANNOTATION (z) = 0; MOID (z) = NO_MOID; NEXT (z) = NO_NODE; PREVIOUS (z) = NO_NODE; SUB (z) = NO_NODE; NEST (z) = NO_NODE; NON_LOCAL (z) = NO_TABLE; TAX (z) = NO_TAG; SEQUENCE (z) = NO_NODE; PACK (z) = NO_PACK; return (z); } /*! \brief new_symbol_table \param p parent symbol table \return same **/ TABLE_T *new_symbol_table (TABLE_T * p) { TABLE_T *z = (TABLE_T *) get_fixed_heap_space ((size_t) ALIGNED_SIZE_OF (TABLE_T)); LEVEL (z) = symbol_table_count++; NEST (z) = symbol_table_count; ATTRIBUTE (z) = 0; AP_INCREMENT (z) = 0; INITIALISE_FRAME (z) = A68_TRUE; PROC_OPS (z) = A68_TRUE; INITIALISE_ANON (z) = A68_TRUE; PREVIOUS (z) = p; OUTER (z) = NO_TABLE; IDENTIFIERS (z) = NO_TAG; OPERATORS (z) = NO_TAG; PRIO (z) = NO_TAG; INDICANTS (z) = NO_TAG; LABELS (z) = NO_TAG; ANONYMOUS (z) = NO_TAG; JUMP_TO (z) = NO_NODE; SEQUENCE (z) = NO_NODE; return (z); } /*! \brief new_moid \return same **/ MOID_T *new_moid (void) { MOID_T *z = (MOID_T *) get_fixed_heap_space ((size_t) ALIGNED_SIZE_OF (MOID_T)); new_modes++; ATTRIBUTE (z) = 0; NUMBER (z) = 0; DIM (z) = 0; USE (z) = A68_FALSE; HAS_ROWS (z) = A68_FALSE; SIZE (z) = 0; PORTABLE (z) = A68_TRUE; DERIVATE (z) = A68_FALSE; NODE (z) = NO_NODE; PACK (z) = NO_PACK; SUB (z) = NO_MOID; EQUIVALENT_MODE (z) = NO_MOID; SLICE (z) = NO_MOID; TRIM (z) = NO_MOID; DEFLEXED (z) = NO_MOID; NAME (z) = NO_MOID; MULTIPLE_MODE (z) = NO_MOID; NEXT (z) = NO_MOID; return (z); } /*! \brief new_pack \return same **/ PACK_T *new_pack (void) { PACK_T *z = (PACK_T *) get_fixed_heap_space ((size_t) ALIGNED_SIZE_OF (PACK_T)); MOID (z) = NO_MOID; TEXT (z) = NO_TEXT; NODE (z) = NO_NODE; NEXT (z) = NO_PACK; PREVIOUS (z) = NO_PACK; SIZE (z) = 0; OFFSET (z) = 0; return (z); } /*! \brief new_tag \return same **/ TAG_T *new_tag (void) { TAG_T *z = (TAG_T *) get_fixed_heap_space ((size_t) ALIGNED_SIZE_OF (TAG_T)); STATUS (z) = NULL_MASK; CODEX (z) = NULL_MASK; TAG_TABLE (z) = NO_TABLE; MOID (z) = NO_MOID; NODE (z) = NO_NODE; UNIT (z) = NO_NODE; VALUE (z) = NO_TEXT; A68G_STANDENV_PROC (z) = 0; PROCEDURE (z) = NO_GPROC; SCOPE (z) = PRIMAL_SCOPE; SCOPE_ASSIGNED (z) = A68_FALSE; PRIO (z) = 0; USE (z) = A68_FALSE; IN_PROC (z) = A68_FALSE; HEAP (z) = A68_FALSE; SIZE (z) = 0; OFFSET (z) = 0; YOUNGEST_ENVIRON (z) = PRIMAL_SCOPE; LOC_ASSIGNED (z) = A68_FALSE; NEXT (z) = NO_TAG; BODY (z) = NO_TAG; PORTABLE (z) = A68_TRUE; NUMBER (z) = ++tag_number; return (z); } /*! \brief new_source_line \return same **/ LINE_T *new_source_line (void) { LINE_T *z = (LINE_T *) get_fixed_heap_space ((size_t) ALIGNED_SIZE_OF (LINE_T)); MARKER (z)[0] = NULL_CHAR; STRING (z) = NO_TEXT; FILENAME (z) = NO_TEXT; DIAGNOSTICS (z) = NO_DIAGNOSTIC; NUMBER (z) = 0; PRINT_STATUS (z) = 0; LIST (z) = A68_TRUE; NEXT (z) = NO_LINE; PREVIOUS (z) = NO_LINE; return (z); } /*! \brief make special, internal mode \param n chain to insert into \param m moid number **/ void make_special_mode (MOID_T ** n, int m) { (*n) = new_moid (); ATTRIBUTE (*n) = 0; NUMBER (*n) = m; PACK (*n) = NO_PACK; SUB (*n) = NO_MOID; EQUIVALENT (*n) = NO_MOID; DEFLEXED (*n) = NO_MOID; NAME (*n) = NO_MOID; SLICE (*n) = NO_MOID; TRIM (*n) = NO_MOID; ROWED (*n) = NO_MOID; } /*! \brief whether x matches c; case insensitive \param string string to test \param string to match, leading '-' or caps in c are mandatory \param alt string terminator other than NULL_CHAR \return whether match **/ BOOL_T match_string (char *x, char *c, char alt) { BOOL_T match = A68_TRUE; while ((IS_UPPER (c[0]) || IS_DIGIT (c[0]) || c[0] == '-') && match) { match = (BOOL_T) (match & (TO_LOWER (x[0]) == TO_LOWER ((c++)[0]))); if (!(x[0] == NULL_CHAR || x[0] == alt)) { x++; } } while (x[0] != NULL_CHAR && x[0] != alt && c[0] != NULL_CHAR && match) { match = (BOOL_T) (match & (TO_LOWER ((x++)[0]) == TO_LOWER ((c++)[0]))); } return ((BOOL_T) (match ? (x[0] == NULL_CHAR || x[0] == alt) : A68_FALSE)); } /*! \brief whether attributes match in subsequent nodes \param p position in tree \return whether match **/ BOOL_T whether (NODE_T * p, ...) { va_list vl; int a; va_start (vl, p); while ((a = va_arg (vl, int)) != STOP) { if (p != NO_NODE && a == WILDCARD) { FORWARD (p); } else if (p != NO_NODE && (a == KEYWORD)) { if (find_keyword_from_attribute (top_keyword, ATTRIBUTE (p)) != NO_KEYWORD) { FORWARD (p); } else { va_end (vl); return (A68_FALSE); } } else if (p != NO_NODE && (a >= 0 ? a == ATTRIBUTE (p) : (-a) != ATTRIBUTE (p))) { FORWARD (p); } else { va_end (vl); return (A68_FALSE); } } va_end (vl); return (A68_TRUE); } /*! \brief whether one of a series of attributes matches a node \param p position in tree \return whether match **/ BOOL_T is_one_of (NODE_T * p, ...) { if (p != NO_NODE) { va_list vl; int a; BOOL_T match = A68_FALSE; va_start (vl, p); while ((a = va_arg (vl, int)) != STOP) { match = (BOOL_T) (match | (BOOL_T) (IS (p, a))); } va_end (vl); return (match); } else { return (A68_FALSE); } } /*! \brief isolate nodes p-q making p a branch to p-q \param p first node to branch \param q last node to branch \param t attribute for branch **/ void make_sub (NODE_T * p, NODE_T * q, int t) { NODE_T *z = new_node (); ABEND (p == NO_NODE || q == NO_NODE, ERROR_INTERNAL_CONSISTENCY, "make_sub"); *z = *p; if (GINFO (p) != NO_GINFO) { GINFO (z) = new_genie_info (); } PREVIOUS (z) = NO_NODE; if (p == q) { NEXT (z) = NO_NODE; } else { if (NEXT (p) != NO_NODE) { PREVIOUS (NEXT (p)) = z; } NEXT (p) = NEXT (q); if (NEXT (p) != NO_NODE) { PREVIOUS (NEXT (p)) = p; } NEXT (q) = NO_NODE; } SUB (p) = z; ATTRIBUTE (p) = t; } /*! \brief find symbol table at level 'i' \param n position in tree \param i level \return same **/ TABLE_T *find_level (NODE_T * n, int i) { if (n == NO_NODE) { return (NO_TABLE); } else { TABLE_T *s = TABLE (n); if (s != NO_TABLE && LEVEL (s) == i) { return (s); } else if ((s = find_level (SUB (n), i)) != NO_TABLE) { return (s); } else if ((s = find_level (NEXT (n), i)) != NO_TABLE) { return (s); } else { return (NO_TABLE); } } } /*! \brief time versus arbitrary origin \return same **/ double seconds (void) { return ((double) clock () / (double) CLOCKS_PER_SEC); } /*! \brief whether 'p' is top of lexical level \param p position in tree \return same **/ BOOL_T is_new_lexical_level (NODE_T * p) { switch (ATTRIBUTE (p)) { case ALT_DO_PART: case BRIEF_ELIF_PART: case BRIEF_OUSE_PART: case BRIEF_CONFORMITY_OUSE_PART: case CHOICE: case CLOSED_CLAUSE: case CONDITIONAL_CLAUSE: case DO_PART: case ELIF_PART: case ELSE_PART: case FORMAT_TEXT: case CASE_CLAUSE: case CASE_CHOICE_CLAUSE: case CASE_IN_PART: case CASE_OUSE_PART: case OUT_PART: case ROUTINE_TEXT: case SPECIFIED_UNIT: case THEN_PART: case UNTIL_PART: case CONFORMITY_CLAUSE: case CONFORMITY_CHOICE: case CONFORMITY_IN_PART: case CONFORMITY_OUSE_PART: case WHILE_PART: { return (A68_TRUE); } default: { return (A68_FALSE); } } } /*! \brief some_node \param t token text \return same **/ NODE_T *some_node (char *t) { NODE_T *z = new_node (); INFO (z) = new_node_info (); GINFO (z) = new_genie_info (); NSYMBOL (z) = t; return (z); } /*! \brief initialise use of elem-lists **/ void init_postulates (void) { top_postulate = NO_POSTULATE; top_postulate_list = NO_POSTULATE; } /*! \brief make old postulates available for new use \param start start of list to save \param stop first element to not save **/ void free_postulate_list (POSTULATE_T *start, POSTULATE_T *stop) { POSTULATE_T *last; if (start == stop) { return; } for (last = start; NEXT (last) != stop; FORWARD (last)) { /* skip */; } NEXT (last) = top_postulate_list; top_postulate_list = start; } /*! \brief add elements to elem-list \param p postulate chain \param a moid 1 \param b moid 2 **/ void make_postulate (POSTULATE_T ** p, MOID_T * a, MOID_T * b) { POSTULATE_T *new_one; if (top_postulate_list != NO_POSTULATE) { new_one = top_postulate_list; FORWARD (top_postulate_list); } else { new_one = (POSTULATE_T *) get_temp_heap_space ((size_t) ALIGNED_SIZE_OF (POSTULATE_T)); new_postulates++; } A (new_one) = a; B (new_one) = b; NEXT (new_one) = *p; *p = new_one; } /*! \brief where elements are in the list \param p postulate chain \param a moid 1 \param b moid 2 \return containing postulate **/ POSTULATE_T *is_postulated_pair (POSTULATE_T * p, MOID_T * a, MOID_T * b) { for (; p != NO_POSTULATE; FORWARD (p)) { if (A (p) == a && B (p) == b) { return (p); } } return (NO_POSTULATE); } /*! \brief where element is in the list \param p postulate chain \param a moid 1 \return containing postulate **/ POSTULATE_T *is_postulated (POSTULATE_T * p, MOID_T * a) { for (; p != NO_POSTULATE; FORWARD (p)) { if (A (p) == a) { return (p); } } return (NO_POSTULATE); } /*------------------+ | Control of C heap | +------------------*/ /*! \brief discard_heap **/ void discard_heap (void) { if (heap_segment != NO_BYTE) { free (heap_segment); } fixed_heap_pointer = 0; temp_heap_pointer = 0; } /*! \brief initialise C and A68 heap management **/ void init_heap (void) { int heap_a_size = A68_ALIGN (heap_size); int handle_a_size = A68_ALIGN (handle_pool_size); int frame_a_size = A68_ALIGN (frame_stack_size); int expr_a_size = A68_ALIGN (expr_stack_size); int total_size = A68_ALIGN (heap_a_size + handle_a_size + frame_a_size + 2 * expr_a_size); BYTE_T *core = (BYTE_T *) (A68_ALIGN_T *) malloc ((size_t) total_size); ABEND (core == NO_BYTE, ERROR_OUT_OF_CORE, NO_TEXT); heap_segment = &core[0]; handle_segment = &heap_segment[heap_a_size]; stack_segment = &handle_segment[handle_a_size]; fixed_heap_pointer = A68_ALIGNMENT; temp_heap_pointer = total_size; frame_start = 0; /* actually, heap_a_size + handle_a_size */ frame_end = stack_start = frame_start + frame_a_size; stack_end = stack_start + expr_a_size; } /*! \brief add token to the token tree \param p top token \param t token text \return new entry **/ TOKEN_T *add_token (TOKEN_T ** p, char *t) { char *z = new_fixed_string (t); while (*p != NO_TOKEN) { int k = strcmp (z, TEXT (*p)); if (k < 0) { p = &LESS (*p); } else if (k > 0) { p = &MORE (*p); } else { return (*p); } } *p = (TOKEN_T *) get_fixed_heap_space ((size_t) ALIGNED_SIZE_OF (TOKEN_T)); TEXT (*p) = z; LESS (*p) = MORE (*p) = NO_TOKEN; return (*p); } /*! \brief find keyword, from token name \param p top keyword \param t token text to find \return entry **/ KEYWORD_T *find_keyword (KEYWORD_T * p, char *t) { while (p != NO_KEYWORD) { int k = strcmp (t, TEXT (p)); if (k < 0) { p = LESS (p); } else if (k > 0) { p = MORE (p); } else { return (p); } } return (NO_KEYWORD); } /*! \brief find keyword, from attribute \param p top keyword \param a token attribute \return entry **/ KEYWORD_T *find_keyword_from_attribute (KEYWORD_T * p, int a) { if (p == NO_KEYWORD) { return (NO_KEYWORD); } else if (a == ATTRIBUTE (p)) { return (p); } else { KEYWORD_T *z; if ((z = find_keyword_from_attribute (LESS (p), a)) != NO_KEYWORD) { return (z); } else if ((z = find_keyword_from_attribute (MORE (p), a)) != NO_KEYWORD) { return (z); } else { return (NO_KEYWORD); } } } /* A list of 10 ^ 2 ^ n for conversion purposes on IEEE 754 platforms */ #define MAX_DOUBLE_EXPO 511 static double pow_10[] = { 10.0, 100.0, 1.0e4, 1.0e8, 1.0e16, 1.0e32, 1.0e64, 1.0e128, 1.0e256 }; /*! \brief 10 ** expo \param expo exponent \return same **/ double ten_up (int expo) { /* This way appears sufficiently accurate */ double dbl_expo = 1.0, *dep; BOOL_T neg_expo = (BOOL_T) (expo < 0); if (neg_expo) { expo = -expo; } ABEND (expo > MAX_DOUBLE_EXPO, "exponent too large", NO_TEXT); for (dep = pow_10; expo != 0; expo >>= 1, dep++) { if (expo & 0x1) { dbl_expo *= *dep; } } return (neg_expo ? 1 / dbl_expo : dbl_expo); } /*! \brief search first char in string \param str string to search \param c character to find \return pointer to first "c" in "str" **/ char *a68g_strchr (char *str, int c) { return (strchr (str, c)); } /*! \brief safely append to buffer \param dst text buffer \param src text to append \param len size of dst **/ void bufcat (char *dst, char *src, int len) { if (src != NO_TEXT) { char *d = dst, *s = src; int n = len, dlen; /* Find end of dst and left-adjust; do not go past end */ for (; n-- != 0 && d[0] != NULL_CHAR; d++) { ; } dlen = (int) (d - dst); n = len - dlen; if (n > 0) { while (s[0] != NULL_CHAR) { if (n != 1) { (d++)[0] = s[0]; n--; } s++; } d[0] = NULL_CHAR; } /* Better sure than sorry */ dst[len - 1] = NULL_CHAR; } } /*! \brief safely copy to buffer \param dst text buffer \param src text to append \param siz size of dst **/ void bufcpy (char *dst, char *src, int len) { if (src != NO_TEXT) { char *d = dst, *s = src; int n = len; /* Copy as many as fit */ if (n > 0 && --n > 0) { do { if (((d++)[0] = (s++)[0]) == NULL_CHAR) { break; } } while (--n > 0); } if (n == 0 && len > 0) { /* Not enough room in dst, so terminate */ d[0] = NULL_CHAR; } /* Better sure than sorry */ dst[len - 1] = NULL_CHAR; } } /*! \brief grep in string (STRING, STRING, REF INT, REF INT) INT \param pat search string or regular expression if supported \param str string to match \param start index of first character in first matching substring \param start index of last character in first matching substring \return 0: match, 1: no match, 2: no core, 3: other error **/ int grep_in_string (char *pat, char *str, int *start, int *end) { #if defined HAVE_REGEX_H int rc, nmatch, k, max_k, widest; regex_t compiled; regmatch_t *matches; rc = regcomp (&compiled, pat, REG_NEWLINE | REG_EXTENDED); if (rc != 0) { regfree (&compiled); return (rc); } nmatch = (int) (RE_NSUB (&compiled)); if (nmatch == 0) { nmatch = 1; } matches = malloc ((size_t) (nmatch * ALIGNED_SIZE_OF (regmatch_t))); if (nmatch > 0 && matches == NO_REGMATCH) { regfree (&compiled); return (2); } rc = regexec (&compiled, str, (size_t) nmatch, matches, 0); if (rc != 0) { regfree (&compiled); return (rc); } /* Find widest match. Do not assume it is the first one */ widest = 0; max_k = 0; for (k = 0; k < nmatch; k++) { int dif = (int) RM_EO (&matches[k]) - (int) RM_SO (&matches[k]); if (dif > widest) { widest = dif; max_k = k; } } if (start != NO_INT) { (*start) = (int) RM_SO (&matches[max_k]); } if (end != NO_INT) { (*end) = (int) RM_EO (&matches[max_k]); } free (matches); return (0); #else (void) start; (void) end; if (strstr (str, pat) != NO_TEXT) { return (0); } else { return (1); } #endif /* HAVE_REGEX_H */ } /* VMS style acronyms */ /* This code was contributed by Theo Vosse. */ static BOOL_T is_vowel (char); static BOOL_T is_consonant (char); static int qsort_strcmp (const void *, const void *); static BOOL_T is_coda (char *, int); static void get_init_sylls (char *, char *); static void reduce_vowels (char *); static int error_length (char *); static BOOL_T remove_extra_coda (char *); static void make_acronym (char *, char *); /*! \brief whether ch is a vowel \param ch character under test \return same **/ static BOOL_T is_vowel (char ch) { return ((BOOL_T) (a68g_strchr ("aeiouAEIOU", ch) != NO_TEXT)); } /*! \brief whether ch is consonant \param ch character under test \return same **/ static BOOL_T is_consonant (char ch) { return ((BOOL_T) (a68g_strchr ("qwrtypsdfghjklzxcvbnmQWRTYPSDFGHJKLZXCVBNM", ch) != NO_TEXT)); } static char *codas[] = { "BT", "CH", "CHS", "CHT", "CHTS", "CT", "CTS", "D", "DS", "DST", "DT", "F", "FD", "FDS", "FDST", "FDT", "FS", "FST", "FT", "FTS", "FTST", "G", "GD", "GDS", "GDST", "GDT", "GS", "GST", "GT", "H", "K", "KS", "KST", "KT", "KTS", "KTST", "L", "LD", "LDS", "LDST", "LDT", "LF", "LFD", "LFS", "LFT", "LG", "LGD", "LGT", "LK", "LKS", "LKT", "LM", "LMD", "LMS", "LMT", "LP", "LPS", "LPT", "LS", "LSD", "LST", "LT", "LTS", "LTST", "M", "MBT", "MBTS", "MD", "MDS", "MDST", "MDT", "MF", "MP", "MPT", "MPTS", "MPTST", "MS", "MST", "MT", "N", "ND", "NDR", "NDS", "NDST", "NDT", "NG", "NGD", "NGS", "NGST", "NGT", "NK", "NKS", "NKST", "NKT", "NS", "NSD", "NST", "NT", "NTS", "NTST", "NTZ", "NX", "P", "PS", "PST", "PT", "PTS", "PTST", "R", "RCH", "RCHT", "RD", "RDS", "RDST", "RDT", "RG", "RGD", "RGS", "RGT", "RK", "RKS", "RKT", "RLS", "RM", "RMD", "RMS", "RMT", "RN", "RND", "RNS", "RNST", "RNT", "RP", "RPS", "RPT", "RS", "RSD", "RST", "RT", "RTS", "S", "SC", "SCH", "SCHT", "SCS", "SD", "SK", "SKS", "SKST", "SKT", "SP", "SPT", "ST", "STS", "T", "TS", "TST", "W", "WD", "WDS", "WDST", "WS", "WST", "WT", "X", "XT" }; /*! \brief compare function to pass to bsearch \param key key to search \param data data to search in \return difference between key and data **/ static int qsort_strcmp (const void *key, const void *data) { return (strcmp ((char *) key, *(char **) data)); } /*! \brief whether first characters of string are a coda \param str string under test \param len number of characters \return same **/ static BOOL_T is_coda (char *str, int len) { char str2[BUFFER_SIZE]; bufcpy (str2, str, BUFFER_SIZE); str2[len] = NULL_CHAR; return ((BOOL_T) (bsearch (str2, codas, sizeof (codas) / sizeof (char *), sizeof (char *), qsort_strcmp) != NULL)); } /*! \brief get_init_sylls \param in input string \param out output string **/ static void get_init_sylls (char *in, char *out) { char *coda; while (*in != NULL_CHAR) { if (IS_ALPHA (*in)) { while (*in != NULL_CHAR && IS_ALPHA (*in) && !is_vowel (*in)) { *out++ = (char) TO_UPPER (*in++); } while (*in != NULL_CHAR && is_vowel (*in)) { *out++ = (char) TO_UPPER (*in++); } coda = out; while (*in != NULL_CHAR && is_consonant (*in)) { *out++ = (char) TO_UPPER (*in++); *out = NULL_CHAR; if (!is_coda (coda, (int) (out - coda))) { out--; break; } } while (*in != NULL_CHAR && IS_ALPHA (*in)) { in++; } *out++ = '+'; } else { in++; } } out[-1] = NULL_CHAR; } /*! \brief reduce vowels in string \param str string **/ static void reduce_vowels (char *str) { char *next; while (*str != NULL_CHAR) { next = a68g_strchr (str + 1, '+'); if (next == NO_TEXT) { break; } if (!is_vowel (*str) && is_vowel (next[1])) { while (str != next && !is_vowel (*str)) { str++; } if (str != next) { memmove (str, next, strlen (next) + 1); } } else { while (*str != NULL_CHAR && *str != '+') str++; } if (*str == '+') { str++; } } } /*! \brief remove boundaries in string \param str string \param max_len maximym length **/ static void remove_boundaries (char *str, int max_len) { int len = 0; while (*str != NULL_CHAR) { if (len >= max_len) { *str = NULL_CHAR; return; } if (*str == '+') { memmove (str, str + 1, strlen (str + 1) + 1); } else { str++; len++; } } } /*! \brief error_length \param str string \return same **/ static int error_length (char *str) { int len = 0; while (*str != NULL_CHAR) { if (*str != '+') { len++; } str++; } return (len); } /*! \brief remove extra coda \param str string \return whether operation succeeded **/ static BOOL_T remove_extra_coda (char *str) { int len; while (*str != NULL_CHAR) { if (is_vowel (*str) && str[1] != '+' && !is_vowel (str[1]) && str[2] != '+' && str[2] != NULL_CHAR) { for (len = 2; str[len] != NULL_CHAR && str[len] != '+'; len++); memmove (str + 1, str + len, strlen (str + len) + 1); return (A68_TRUE); } str++; } return (A68_FALSE); } /*! \brief make acronym \param in input string \param out output string **/ static void make_acronym (char *in, char *out) { get_init_sylls (in, out); reduce_vowels (out); while (error_length (out) > 8 && remove_extra_coda (out)); remove_boundaries (out, 8); } /*! \brief push acronym of string in stack \param p position in tree **/ void genie_acronym (NODE_T * p) { A68_REF z; int len; char *u, *v; POP_REF (p, &z); len = a68_string_size (p, z); u = (char *) malloc ((size_t) (len + 1)); v = (char *) malloc ((size_t) (len + 1 + 8)); (void) a_to_c_string (p, u, z); if (u != NO_TEXT && u[0] != NULL_CHAR && v != NO_TEXT) { make_acronym (u, v); PUSH_REF (p, c_to_a_string (p, v, DEFAULT_WIDTH)); } else { PUSH_REF (p, empty_string (p)); } if (u != NO_TEXT) { free (u); } if (v != NO_TEXT) { free (v); } } /* Translate int attributes to string names */ static char *attribute_names[WILDCARD + 1] = { NO_TEXT, "A68_PATTERN", "ACCO_SYMBOL", "ACTUAL_DECLARER_MARK", "ALT_DO_PART", "ALT_DO_SYMBOL", "ALT_EQUALS_SYMBOL", "ALT_FORMAL_BOUNDS_LIST", "ANDF_SYMBOL", "AND_FUNCTION", "ANONYMOUS", "ARGUMENT", "ARGUMENT_LIST", "ASSERTION", "ASSERT_SYMBOL", "ASSIGNATION", "ASSIGN_SYMBOL", "ASSIGN_TO_SYMBOL", "AT_SYMBOL", "BEGIN_SYMBOL", "BITS_C_PATTERN", "BITS_DENOTATION", "BITS_PATTERN", "BITS_SYMBOL", "BOLD_COMMENT_SYMBOL", "BOLD_PRAGMAT_SYMBOL", "BOLD_TAG", "BOOLEAN_PATTERN", "BOOL_SYMBOL", "BOUND", "BOUNDS", "BOUNDS_LIST", "BRIEF_OUSE_PART", "BRIEF_CONFORMITY_OUSE_PART", "BRIEF_ELIF_PART", "BRIEF_OPERATOR_DECLARATION", "BUS_SYMBOL", "BYTES_SYMBOL", "BY_PART", "BY_SYMBOL", "CALL", "CASE_CHOICE_CLAUSE", "CASE_CLAUSE", "CASE_IN_PART", "CASE_OUSE_PART", "CASE_PART", "CASE_SYMBOL", "CAST", "CHANNEL_SYMBOL", "CHAR_C_PATTERN", "CHAR_SYMBOL", "CHOICE", "CHOICE_PATTERN", "CLASS_SYMBOL", "CLOSED_CLAUSE", "CLOSE_SYMBOL", "CODE_CLAUSE", "CODE_LIST", "CODE_SYMBOL", "COLLATERAL_CLAUSE", "COLLECTION", "COLON_SYMBOL", "COLUMN_FUNCTION", "COLUMN_SYMBOL", "COMMA_SYMBOL", "COMPLEX_PATTERN", "COMPLEX_SYMBOL", "COMPL_SYMBOL", "CONDITIONAL_CLAUSE", "CONFORMITY_CHOICE", "CONFORMITY_CLAUSE", "CONFORMITY_IN_PART", "CONFORMITY_OUSE_PART", "CONSTRUCT", "DECLARATION_LIST", "DECLARER", "DEFINING_IDENTIFIER", "DEFINING_INDICANT", "DEFINING_OPERATOR", "DENOTATION", "DEPROCEDURING", "DEREFERENCING", "DIAGONAL_FUNCTION", "DIAGONAL_SYMBOL", "DOTDOT_SYMBOL", "DOWNTO_SYMBOL", "DO_PART", "DO_SYMBOL", "DYNAMIC_REPLICATOR", "EDOC_SYMBOL", "ELIF_IF_PART", "ELIF_PART", "ELIF_SYMBOL", "ELSE_BAR_SYMBOL", "ELSE_OPEN_PART", "ELSE_PART", "ELSE_SYMBOL", "EMPTY_SYMBOL", "ENCLOSED_CLAUSE", "END_SYMBOL", "ENQUIRY_CLAUSE", "ENVIRON_NAME", "ENVIRON_SYMBOL", "EQUALS_SYMBOL", "ERROR", "ERROR_IDENTIFIER", "ESAC_SYMBOL", "EXIT_SYMBOL", "EXPONENT_FRAME", "FALSE_SYMBOL", "FIELD", "FIELD_IDENTIFIER", "FILE_SYMBOL", "FIRM", "FIXED_C_PATTERN", "FI_SYMBOL", "FLEX_SYMBOL", "FLOAT_C_PATTERN", "FORMAL_BOUNDS", "FORMAL_BOUNDS_LIST", "FORMAL_DECLARERS", "FORMAL_DECLARERS_LIST", "FORMAL_DECLARER_MARK", "FORMAT_A_FRAME", "FORMAT_CLOSE_SYMBOL", "FORMAT_DELIMITER_SYMBOL", "FORMAT_D_FRAME", "FORMAT_E_FRAME", "FORMAT_IDENTIFIER", "FORMAT_ITEM_A", "FORMAT_ITEM_B", "FORMAT_ITEM_C", "FORMAT_ITEM_D", "FORMAT_ITEM_E", "FORMAT_ITEM_ESCAPE", "FORMAT_ITEM_F", "FORMAT_ITEM_G", "FORMAT_ITEM_H", "FORMAT_ITEM_I", "FORMAT_ITEM_J", "FORMAT_ITEM_K", "FORMAT_ITEM_L", "FORMAT_ITEM_M", "FORMAT_ITEM_MINUS", "FORMAT_ITEM_N", "FORMAT_ITEM_O", "FORMAT_ITEM_P", "FORMAT_ITEM_PLUS", "FORMAT_ITEM_POINT", "FORMAT_ITEM_Q", "FORMAT_ITEM_R", "FORMAT_ITEM_S", "FORMAT_ITEM_T", "FORMAT_ITEM_U", "FORMAT_ITEM_V", "FORMAT_ITEM_W", "FORMAT_ITEM_X", "FORMAT_ITEM_Y", "FORMAT_ITEM_Z", "FORMAT_I_FRAME", "FORMAT_OPEN_SYMBOL", "FORMAT_PATTERN", "FORMAT_POINT_FRAME", "FORMAT_SYMBOL", "FORMAT_TEXT", "FORMAT_Z_FRAME", "FORMULA", "FOR_PART", "FOR_SYMBOL", "FROM_PART", "FROM_SYMBOL", "GENERAL_C_PATTERN", "GENERAL_PATTERN", "GENERATOR", "GENERIC_ARGUMENT", "GENERIC_ARGUMENT_LIST", "GOTO_SYMBOL", "GO_SYMBOL", "HEAP_SYMBOL", "IDENTIFIER", "IDENTITY_DECLARATION", "IDENTITY_RELATION", "IF_PART", "IF_SYMBOL", "INDICANT", "INITIALISER_SERIES", "INSERTION", "INTEGRAL_C_PATTERN", "INTEGRAL_MOULD", "INTEGRAL_PATTERN", "INT_DENOTATION", "INT_SYMBOL", "IN_SYMBOL", "IN_TYPE_MODE", "ISNT_SYMBOL", "IS_SYMBOL", "JUMP", "KEYWORD", "LABEL", "LABELED_UNIT", "LABEL_IDENTIFIER", "LABEL_SEQUENCE", "LITERAL", "LOCAL_LABEL", "LOC_SYMBOL", "LONGETY", "LONG_SYMBOL", "LOOP_CLAUSE", "LOOP_IDENTIFIER", "MAIN_SYMBOL", "MEEK", "MODE_BITS", "MODE_BOOL", "MODE_BYTES", "MODE_CHAR", "MODE_COMPLEX", "MODE_DECLARATION", "MODE_FILE", "MODE_FORMAT", "MODE_INT", "MODE_LONGLONG_BITS", "MODE_LONGLONG_COMPLEX", "MODE_LONGLONG_INT", "MODE_LONGLONG_REAL", "MODE_LONG_BITS", "MODE_LONG_BYTES", "MODE_LONG_COMPLEX", "MODE_LONG_INT", "MODE_LONG_REAL", "MODE_NO_CHECK", "MODE_PIPE", "MODE_REAL", "MODE_SOUND", "MODE_SYMBOL", "MONADIC_FORMULA", "MONAD_SEQUENCE", "NEW_SYMBOL", "NIHIL", "NIL_SYMBOL", "NORMAL_IDENTIFIER", "NO_SORT", "OCCA_SYMBOL", "OD_SYMBOL", "OF_SYMBOL", "OPEN_PART", "OPEN_SYMBOL", "OPERATOR", "OPERATOR_DECLARATION", "OPERATOR_PLAN", "OP_SYMBOL", "ORF_SYMBOL", "OR_FUNCTION", "OUSE_PART", "OUSE_SYMBOL", "OUT_PART", "OUT_SYMBOL", "OUT_TYPE_MODE", "PARALLEL_CLAUSE", "PARAMETER", "PARAMETER_IDENTIFIER", "PARAMETER_LIST", "PARAMETER_PACK", "PARTICULAR_PROGRAM", "PAR_SYMBOL", "PICTURE", "PICTURE_LIST", "PIPE_SYMBOL", "POINT_SYMBOL", "PRIMARY", "PRIORITY", "PRIORITY_DECLARATION", "PRIO_SYMBOL", "PROCEDURE_DECLARATION", "PROCEDURE_VARIABLE_DECLARATION", "PROCEDURING", "PROC_SYMBOL", "QUALIFIER", "RADIX_FRAME", "REAL_DENOTATION", "REAL_PATTERN", "REAL_SYMBOL", "REF_SYMBOL", "REPLICATOR", "ROUTINE_TEXT", "ROUTINE_UNIT", "ROWING", "ROWS_SYMBOL", "ROW_CHAR_DENOTATION", "ROW_FUNCTION", "ROW_SYMBOL", "SECONDARY", "SELECTION", "SELECTOR", "SEMA_SYMBOL", "SEMI_SYMBOL", "SERIAL_CLAUSE", "SERIES_MODE", "SHORTETY", "SHORT_SYMBOL", "SIGN_MOULD", "SKIP", "SKIP_SYMBOL", "SLICE", "SOFT", "SOME_CLAUSE", "SOUND_SYMBOL", "SPECIFICATION", "SPECIFIED_UNIT", "SPECIFIED_UNIT_LIST", "SPECIFIED_UNIT_UNIT", "SPECIFIER", "SPECIFIER_IDENTIFIER", "STANDARD", "STATIC_REPLICATOR", "STOWED_MODE", "STRING_C_PATTERN", "STRING_PATTERN", "STRING_SYMBOL", "STRONG", "STRUCTURED_FIELD", "STRUCTURED_FIELD_LIST", "STRUCTURE_PACK", "STRUCT_SYMBOL", "STYLE_II_COMMENT_SYMBOL", "STYLE_I_COMMENT_SYMBOL", "STYLE_I_PRAGMAT_SYMBOL", "SUB_SYMBOL", "SUB_UNIT", "TERTIARY", "THEN_BAR_SYMBOL", "THEN_PART", "THEN_SYMBOL", "TO_PART", "TO_SYMBOL", "TRANSPOSE_FUNCTION", "TRANSPOSE_SYMBOL", "TRIMMER", "TRUE_SYMBOL", "UNION_DECLARER_LIST", "UNION_PACK", "UNION_SYMBOL", "UNIT", "UNITING", "UNIT_LIST", "UNIT_SERIES", "UNTIL_PART", "UNTIL_SYMBOL", "VARIABLE_DECLARATION", "VIRTUAL_DECLARER_MARK", "VOIDING", "VOID_SYMBOL", "WEAK", "WHILE_PART", "WHILE_SYMBOL", "WIDENING", "WILDCARD" }; /*! \brief non_terminal_string \param buf text buffer \param att attribute \return buf, containing name of non terminal string **/ char *non_terminal_string (char *buf, int att) { if (att > 0 && att < WILDCARD) { if (attribute_names[att] != NO_TEXT) { char *q = buf; bufcpy (q, attribute_names[att], BUFFER_SIZE); while (q[0] != NULL_CHAR) { if (q[0] == '_') { q[0] = '-'; } else { q[0] = (char) TO_LOWER (q[0]); } q++; } return (buf); } else { return (NO_TEXT); } } else { return (NO_TEXT); } } /*! \brief standard_environ_proc_name \param f routine that implements a standard environ item \return name of that what "f" implements **/ char *standard_environ_proc_name (GPROC f) { TAG_T *i = IDENTIFIERS (a68g_standenv); for (; i != NO_TAG; FORWARD (i)) { if (PROCEDURE (i) == f) { return (NSYMBOL (NODE (i))); } } return (NO_TEXT); } /* Interactive help */ typedef struct A68_INFO A68_INFO; struct A68_INFO { char *cat; char *term; char *def; }; static A68_INFO info_text[] = { {"monitor", "breakpoint clear [all]", "clear breakpoints and watchpoint expression"}, {"monitor", "breakpoint clear breakpoints", "clear breakpoints"}, {"monitor", "breakpoint clear watchpoint", "clear watchpoint expression"}, {"monitor", "breakpoint [list]", "list breakpoints"}, {"monitor", "breakpoint \"n\" clear", "clear breakpoints in line \"n\""}, {"monitor", "breakpoint \"n\" if \"expression\"", "break in line \"n\" when expression evaluates to true"}, {"monitor", "breakpoint \"n\"", "set breakpoints in line \"n\""}, {"monitor", "breakpoint watch \"expression\"", "break on watchpoint expression when it evaluates to true"}, {"monitor", "calls [n]", "print \"n\" frames in the call stack (default n=3)"}, {"monitor", "continue, resume", "continue execution"}, {"monitor", "do \"command\", exec \"command\"", "pass \"command\" to the shell and print return code"}, {"monitor", "elems [n]", "print first \"n\" elements of rows (default n=24)"}, {"monitor", "evaluate \"expression\", x \"expression\"", "print result of \"expression\""}, {"monitor", "examine \"n\"", "print value of symbols named \"n\" in the call stack"}, {"monitor", "exit, hx, quit", "terminates the program"}, {"monitor", "finish, out", "continue execution until current procedure incarnation is finished"}, {"monitor", "frame 0", "set current stack frame to top of frame stack"}, {"monitor", "frame \"n\"", "set current stack frame to \"n\""}, {"monitor", "frame", "print contents of the current stack frame"}, {"monitor", "heap \"n\"", "print contents of the heap with address not greater than \"n\""}, {"monitor", "help [expression]", "print brief help text"}, {"monitor", "ht", "halts typing to standard output"}, {"monitor", "list [n]", "show \"n\" lines around the interrupted line (default n=10)"}, {"monitor", "next", "continue execution to next interruptable unit (do not enter routine-texts)"}, {"monitor", "prompt \"s\"", "set prompt to \"s\""}, {"monitor", "rerun, restart", "restarts a program without resetting breakpoints"}, {"monitor", "reset", "restarts a program and resets breakpoints"}, {"monitor", "rt", "resumes typing to standard output"}, {"monitor", "sizes", "print size of memory segments"}, {"monitor", "stack [n]", "print \"n\" frames in the stack (default n=3)"}, {"monitor", "step", "continue execution to next interruptable unit"}, {"monitor", "until \"n\"", "continue execution until line number \"n\" is reached"}, {"monitor", "where", "print the interrupted line"}, {"monitor", "xref \"n\"", "give detailed information on source line \"n\""}, {"options", "--assertions, --noassertions", "switch elaboration of assertions on or off"}, {"options", "--backtrace, --nobacktrace", "switch stack backtracing in case of a runtime error"}, {"options", "--boldstropping", "set stropping mode to bold stropping"}, {"options", "--brackets", "consider [ .. ] and { .. } as equivalent to ( .. )"}, {"options", "--check, --norun", "check syntax only, interpreter does not start"}, {"options", "--clock", "report execution time excluding compilation time"}, {"options", "--debug, --monitor", "start execution in the debugger and debug in case of runtime error"}, {"options", "--echo string", "echo \"string\" to standard output"}, {"options", "--execute unit", "execute algol 68 unit \"unit\""}, {"options", "--exit, --", "ignore next options"}, {"options", "--extensive", "make extensive listing"}, {"options", "--file string", "accept string as generic filename"}, {"options", "--frame \"number\"", "set frame stack size to \"number\""}, {"options", "--handles \"number\"", "set handle space size to \"number\""}, {"options", "--heap \"number\"", "set heap size to \"number\""}, {"options", "--keep, --nokeep", "switch object file deletion off or on"}, {"options", "--listing", "make concise listing"}, {"options", "--moids", "make overview of moids in listing file"}, {"options", "-O0, -O1, -O2, -O3", "switch compilation on and pass option to back-end C compiler"}, {"options", "--optimise, --nooptimise", "switch compilation on or off"}, {"options", "--pedantic", "equivalent to --warnings --portcheck"}, {"options", "--portcheck, --noportcheck", "switch portability warnings on or off"}, {"options", "--pragmats, --nopragmats", "switch elaboration of pragmat items on or off"}, {"options", "--precision \"number\"", "set precision for long long modes to \"number\" significant digits"}, {"options", "--preludelisting", "make a listing of preludes"}, {"options", "--pretty-print", "pretty-print the source file"}, {"options", "--print unit", "print value yielded by algol 68 unit \"unit\""}, {"options", "--quiet", "suppresses all warning diagnostics"}, {"options", "--quotestropping", "set stropping mode to quote stropping"}, {"options", "--reductions", "print parser reductions"}, {"options", "--run", "override --check/--norun options"}, {"options", "--rerun", "run using already compiled code"}, {"options", "--script", "set next option as source file name; pass further options to algol 68 program"}, {"options", "--source, --nosource", "switch listing of source lines in listing file on or off"}, {"options", "--stack \"number\"", "set expression stack size to \"number\""}, {"options", "--statistics", "print statistics in listing file"}, {"options", "--strict", "disable most extensions to Algol 68 syntax"}, {"options", "--timelimit \"number\"", "interrupt the interpreter after \"number\" seconds"}, {"options", "--trace, --notrace", "switch tracing of a running program on or off"}, {"options", "--tree, --notree", "switch syntax tree listing in listing file on or off"}, {"options", "--unused", "make an overview of unused tags in the listing file"}, {"options", "--verbose", "inform on program actions"}, {"options", "--version", "state version of the running copy"}, {"options", "--warnings, --nowarnings", "switch warning diagnostics on or off"}, {"options", "--xref, --noxref", "switch cross reference in the listing file on or off"}, {NO_TEXT, NO_TEXT, NO_TEXT} }; /*! \brief print_info \param f file number \param prompt prompt text \param k index of info item to print **/ static void print_info (FILE_T f, char *prompt, int k) { if (prompt != NO_TEXT) { ASSERT (snprintf (output_line, SNPRINTF_SIZE, "%s %s: %s.", prompt, TERM (&info_text[k]), DEF (&info_text[k])) >= 0); } else { ASSERT (snprintf (output_line, SNPRINTF_SIZE, "%s: %s.", TERM (&info_text[k]), DEF (&info_text[k])) >= 0); } WRITELN (f, output_line); } /*! \brief apropos \param f file number \param prompt prompt text \param info item to print **/ void apropos (FILE_T f, char *prompt, char *item) { int k, n = 0; if (item == NO_TEXT) { for (k = 0; CAT (&info_text[k]) != NO_TEXT; k++) { print_info (f, prompt, k); } return; } for (k = 0; CAT (&info_text[k]) != NO_TEXT; k++) { if (grep_in_string (item, CAT (&info_text[k]), NO_INT, NO_INT) == 0) { print_info (f, prompt, k); n++; } } if (n > 0) { return; } for (k = 0; CAT (&info_text[k]) != NO_TEXT; k++) { if (grep_in_string (item, TERM (&info_text[k]), NO_INT, NO_INT) == 0 || grep_in_string (item, DEF (&info_text[k]), NO_INT, NO_INT) == 0) { print_info (f, prompt, k); n++; } } } /* Error handling routines */ #define TABULATE(n) (8 * (n / 8 + 1) - n) /*! \brief whether unprintable control character \param ch character under test \return same **/ BOOL_T unprintable (char ch) { return ((BOOL_T) (!IS_PRINT (ch) && ch != TAB_CHAR)); } /*! \brief format for printing control character \param ch control character \return string containing formatted character **/ char *ctrl_char (int ch) { static char loc_str[SMALL_BUFFER_SIZE]; ch = TO_UCHAR (ch); if (IS_CNTRL (ch) && IS_LOWER (ch + 96)) { ASSERT (snprintf (loc_str, (size_t) SMALL_BUFFER_SIZE, "\\^%c", ch + 96) >= 0); } else { ASSERT (snprintf (loc_str, (size_t) SMALL_BUFFER_SIZE, "\\%02x", (unsigned) ch) >= 0); } return (loc_str); } /*! \brief widen single char to string \param ch character \return (short) string **/ static char *char_to_str (char ch) { static char loc_str[2]; loc_str[0] = ch; loc_str[1] = NULL_CHAR; return (loc_str); } /*! \brief pretty-print diagnostic \param f file number \param p text **/ static void pretty_diag (FILE_T f, char *p) { int pos = 1, line_width = (f == STDOUT_FILENO ? term_width : MAX_TERM_WIDTH); while (p[0] != NULL_CHAR) { char *q; int k; /* Count the number of characters in token to print */ if (IS_GRAPH (p[0])) { for (k = 0, q = p; q[0] != BLANK_CHAR && q[0] != NULL_CHAR && k <= line_width; q++, k++) { ; } } else { k = 1; } /* Now see if there is space for the token */ if (k > line_width) { k = 1; } if ((pos + k) >= line_width) { WRITE (f, NEWLINE_STRING); pos = 1; } for (; k > 0; k--, p++, pos++) { WRITE (f, char_to_str (p[0])); } } for (; p[0] == BLANK_CHAR; p++, pos++) { WRITE (f, char_to_str (p[0])); } } /*! \brief abnormal end \param reason why abend \param info additional info \param file name of source file where abend \param line line in source file where abend **/ void abend (char *reason, char *info, char *file, int line) { ASSERT (snprintf (output_line, SNPRINTF_SIZE, "%s: exiting: %s: %d: %s", a68g_cmd_name, file, line, reason) >= 0); if (info != NO_TEXT) { bufcat (output_line, ", ", BUFFER_SIZE); bufcat (output_line, info, BUFFER_SIZE); } if (errno != 0) { bufcat (output_line, " (", BUFFER_SIZE); bufcat (output_line, error_specification (), BUFFER_SIZE); bufcat (output_line, ")", BUFFER_SIZE); } io_close_tty_line (); pretty_diag (STDOUT_FILENO, output_line); a68g_exit (EXIT_FAILURE); } /*! \brief position in line \param p source line \param q node pertaining to "p" **/ static char *where_pos (LINE_T * p, NODE_T * q) { char *pos; if (q != NO_NODE && p == LINE (INFO (q))) { pos = CHAR_IN_LINE (INFO (q)); } else { pos = STRING (p); } if (pos == NO_TEXT) { pos = STRING (p); } for (; IS_SPACE (pos[0]) && pos[0] != NULL_CHAR; pos++) { ; } if (pos[0] == NULL_CHAR) { pos = STRING (p); } return (pos); } /*! \brief position in line where diagnostic points at \param a source line \param d diagnostic \return pointer to character to mark **/ static char *diag_pos (LINE_T * p, DIAGNOSTIC_T * d) { char *pos; if (WHERE (d) != NO_NODE && p == LINE (INFO (WHERE (d)))) { pos = CHAR_IN_LINE (INFO (WHERE (d))); } else { pos = STRING (p); } if (pos == NO_TEXT) { pos = STRING (p); } for (; IS_SPACE (pos[0]) && pos[0] != NULL_CHAR; pos++) { ; } if (pos[0] == NULL_CHAR) { pos = STRING (p); } return (pos); } /*! \brief write source line to file with diagnostics \param f file number \param p source line \param where node where to mark \param diag whether and how to print diagnostics **/ void write_source_line (FILE_T f, LINE_T * p, NODE_T * nwhere, int diag) { char *c, *c0; int continuations = 0; int pos = 5, col; int line_width = (f == STDOUT_FILENO ? term_width : MAX_TERM_WIDTH); BOOL_T line_ended; /* Terminate properly */ if ((STRING (p))[strlen (STRING (p)) - 1] == NEWLINE_CHAR) { (STRING (p))[strlen (STRING (p)) - 1] = NULL_CHAR; if ((STRING (p))[strlen (STRING (p)) - 1] == CR_CHAR) { (STRING (p))[strlen (STRING (p)) - 1] = NULL_CHAR; } } /* Print line number */ if (f == STDOUT_FILENO) { io_close_tty_line (); } else { WRITE (f, NEWLINE_STRING); } if (NUMBER (p) == 0) { ASSERT (snprintf (output_line, SNPRINTF_SIZE, " ") >= 0); } else { ASSERT (snprintf (output_line, SNPRINTF_SIZE, "%-5d ", NUMBER (p) % 100000) >= 0); } WRITE (f, output_line); /* Pretty print line */ c = c0 = STRING (p); col = 1; line_ended = A68_FALSE; while (!line_ended) { int len = 0; char *new_pos = NO_TEXT; if (c[0] == NULL_CHAR) { bufcpy (output_line, "", BUFFER_SIZE); line_ended = A68_TRUE; } else { if (IS_GRAPH (c[0])) { char *c1; bufcpy (output_line, "", BUFFER_SIZE); for (c1 = c; IS_GRAPH (c1[0]) && len <= line_width - 5; c1++, len++) { bufcat (output_line, char_to_str (c1[0]), BUFFER_SIZE); } if (len > line_width - 5) { bufcpy (output_line, char_to_str (c[0]), BUFFER_SIZE); len = 1; } new_pos = &c[len]; col += len; } else if (c[0] == TAB_CHAR) { int n = TABULATE (col); len = n; col += n; bufcpy (output_line, "", BUFFER_SIZE); while (n--) { bufcat (output_line, " ", BUFFER_SIZE); } new_pos = &c[1]; } else if (unprintable (c[0])) { bufcpy (output_line, ctrl_char ((int) c[0]), BUFFER_SIZE); len = (int) strlen (output_line); new_pos = &c[1]; col++; } else { bufcpy (output_line, char_to_str (c[0]), BUFFER_SIZE); len = 1; new_pos = &c[1]; col++; } } if (!line_ended && (pos + len) <= line_width) { /* Still room - print a character */ WRITE (f, output_line); pos += len; c = new_pos; } else { /* First see if there are diagnostics to be printed */ BOOL_T y = A68_FALSE, z = A68_FALSE; DIAGNOSTIC_T *d = DIAGNOSTICS (p); if (d != NO_DIAGNOSTIC || nwhere != NO_NODE) { char *c1; for (c1 = c0; c1 != c; c1++) { y |= (BOOL_T) (nwhere != NO_NODE && p == LINE (INFO (nwhere)) ? c1 == where_pos (p, nwhere) : A68_FALSE); if (diag != A68_NO_DIAGNOSTICS) { for (d = DIAGNOSTICS (p); d != NO_DIAGNOSTIC; FORWARD (d)) { z = (BOOL_T) (z | (c1 == diag_pos (p, d))); } } } } /* If diagnostics are to be printed then print marks */ if (y || z) { DIAGNOSTIC_T *d2; char *c1; int col_2 = 1; WRITE (f, "\n "); for (c1 = c0; c1 != c; c1++) { int k = 0, diags_at_this_pos = 0; for (d2 = DIAGNOSTICS (p); d2 != NO_DIAGNOSTIC; FORWARD (d2)) { if (c1 == diag_pos (p, d2)) { diags_at_this_pos++; k = NUMBER (d2); } } if (y == A68_TRUE && c1 == where_pos (p, nwhere)) { bufcpy (output_line, "-", BUFFER_SIZE); } else if (diags_at_this_pos != 0) { if (diag == A68_NO_DIAGNOSTICS) { bufcpy (output_line, " ", BUFFER_SIZE); } else if (diags_at_this_pos == 1) { ASSERT (snprintf (output_line, SNPRINTF_SIZE, "%c", digit_to_char (k)) >= 0); } else { bufcpy (output_line, "*", BUFFER_SIZE); } } else { if (unprintable (c1[0])) { int n = (int) strlen (ctrl_char (c1[0])); col_2 += 1; bufcpy (output_line, "", BUFFER_SIZE); while (n--) { bufcat (output_line, " ", BUFFER_SIZE); } } else if (c1[0] == TAB_CHAR) { int n = TABULATE (col_2); col_2 += n; bufcpy (output_line, "", BUFFER_SIZE); while (n--) { bufcat (output_line, " ", BUFFER_SIZE); } } else { bufcpy (output_line, " ", BUFFER_SIZE); col_2++; } } WRITE (f, output_line); } } /* Resume pretty printing of line */ if (!line_ended) { continuations++; ASSERT (snprintf (output_line, SNPRINTF_SIZE, "\n.%1d ", continuations) >= 0); WRITE (f, output_line); if (continuations >= 9) { WRITE (f, "..."); line_ended = A68_TRUE; } else { c0 = c; pos = 5; col = 1; } } } } /* while */ /* Print the diagnostics */ if (diag) { if (DIAGNOSTICS (p) != NO_DIAGNOSTIC) { DIAGNOSTIC_T *d; for (d = DIAGNOSTICS (p); d != NO_DIAGNOSTIC; FORWARD (d)) { if (diag == A68_RUNTIME_ERROR) { if (IS (d, A68_RUNTIME_ERROR)) { WRITE (f, NEWLINE_STRING); pretty_diag (f, TEXT (d)); } } else { WRITE (f, NEWLINE_STRING); pretty_diag (f, TEXT (d)); } } } } } /*! \brief write diagnostics to STDOUT \param p source line \param what severity of diagnostics to print **/ void diagnostics_to_terminal (LINE_T * p, int what) { for (; p != NO_LINE; FORWARD (p)) { if (DIAGNOSTICS (p) != NO_DIAGNOSTIC) { BOOL_T z = A68_FALSE; DIAGNOSTIC_T *d = DIAGNOSTICS (p); for (; d != NO_DIAGNOSTIC; FORWARD (d)) { if (what == A68_ALL_DIAGNOSTICS) { z = (BOOL_T) (z | (IS (d, A68_WARNING) || IS (d, A68_ERROR) || IS (d, A68_SYNTAX_ERROR) || IS (d, A68_MATH_ERROR) || IS (d, A68_RUNTIME_ERROR) || IS (d, A68_SUPPRESS_SEVERITY))); } else if (what == A68_RUNTIME_ERROR) { z = (BOOL_T) (z | (IS (d, A68_RUNTIME_ERROR))); } } if (z) { write_source_line (STDOUT_FILENO, p, NO_NODE, what); } } } } /*! \brief give an intelligible error and exit \param u source line \param v where to mark \param txt error text **/ void scan_error (LINE_T * u, char *v, char *txt) { if (errno != 0) { diagnostic_line (A68_SUPPRESS_SEVERITY, u, v, txt, error_specification ()); } else { diagnostic_line (A68_SUPPRESS_SEVERITY, u, v, txt, ERROR_UNSPECIFIED); } longjmp (RENDEZ_VOUS (&program), 1); } /* \brief get severity text \param sev severity \return same */ static char *get_severity (int sev) { switch (sev) { case A68_ERROR: { return ("error"); } case A68_SYNTAX_ERROR: { return ("syntax error"); } case A68_RUNTIME_ERROR: { return ("runtime error"); } case A68_MATH_ERROR: { return ("math error"); } case A68_WARNING: { return ("warning"); } case A68_SUPPRESS_SEVERITY: { return (NO_TEXT); } default: { return (NO_TEXT); } } } /*! \brief print diagnostic \param sev severity \param b diagnostic text */ static void write_diagnostic (int sev, char *b) { char st[SMALL_BUFFER_SIZE]; char *severity = get_severity (sev); if (severity == NO_TEXT) { ASSERT (snprintf (output_line, SNPRINTF_SIZE, "%s: %s.", a68g_cmd_name, b) >= 0); } else { bufcpy (st, get_severity (sev), SMALL_BUFFER_SIZE); ASSERT (snprintf (output_line, SNPRINTF_SIZE, "%s: %s: %s.", a68g_cmd_name, st, b) >= 0); } io_close_tty_line (); pretty_diag (STDOUT_FILENO, output_line); } /*! \brief add diagnostic to source line \param line source line \param pos where to mark \param p node to mark \param sev severity \param b diagnostic text */ static void add_diagnostic (LINE_T * line, char *pos, NODE_T * p, int sev, char *b) { /* Add diagnostic and choose GNU style or non-GNU style */ DIAGNOSTIC_T *msg = (DIAGNOSTIC_T *) get_heap_space ((size_t) ALIGNED_SIZE_OF (DIAGNOSTIC_T)); DIAGNOSTIC_T **ref_msg; char a[BUFFER_SIZE], st[SMALL_BUFFER_SIZE], nst[BUFFER_SIZE]; char *severity = get_severity (sev); int k = 1; if (line == NO_LINE && p == NO_NODE) { return; } if (in_monitor) { monitor_error (b, NO_TEXT); return; } nst[0] = NULL_CHAR; if (line == NO_LINE && p != NO_NODE) { line = LINE (INFO (p)); } while (line != NO_LINE && NUMBER (line) == 0) { FORWARD (line); } if (line == NO_LINE) { return; } ref_msg = &(DIAGNOSTICS (line)); while (*ref_msg != NO_DIAGNOSTIC) { ref_msg = &(NEXT (*ref_msg)); k++; } if (p != NO_NODE) { NODE_T *n = NEST (p); if (n != NO_NODE && NSYMBOL (n) != NO_TEXT) { char *nt = non_terminal_string (edit_line, ATTRIBUTE (n)); if (nt != NO_TEXT) { if (LINE_NUMBER (n) == 0) { ASSERT (snprintf (nst, SNPRINTF_SIZE, "detected in %s", nt) >= 0); } else { if (MOID (n) != NO_MOID) { if (LINE_NUMBER (n) == NUMBER (line)) { ASSERT (snprintf (nst, SNPRINTF_SIZE, "detected in %s %s starting at \"%.64s\" in this line", moid_to_string (MOID (n), MOID_ERROR_WIDTH, p), nt, NSYMBOL (n)) >= 0); } else { ASSERT (snprintf (nst, SNPRINTF_SIZE, "detected in %s %s starting at \"%.64s\" in line %d", moid_to_string (MOID (n), MOID_ERROR_WIDTH, p), nt, NSYMBOL (n), LINE_NUMBER (n)) >= 0); } } else { if (LINE_NUMBER (n) == NUMBER (line)) { ASSERT (snprintf (nst, SNPRINTF_SIZE, "detected in %s starting at \"%.64s\" in this line", nt, NSYMBOL (n)) >= 0); } else { ASSERT (snprintf (nst, SNPRINTF_SIZE, "detected in %s starting at \"%.64s\" in line %d", nt, NSYMBOL (n), LINE_NUMBER (n)) >= 0); } } } } } } if (severity == NO_TEXT) { if (FILENAME (line) != NO_TEXT && strcmp (FILE_SOURCE_NAME (&program), FILENAME (line)) == 0) { ASSERT (snprintf (a, SNPRINTF_SIZE, "%s: %x: %s", a68g_cmd_name, (unsigned) k, b) >= 0); } else if (FILENAME (line) != NO_TEXT) { ASSERT (snprintf (a, SNPRINTF_SIZE, "%s: %s: %x: %s", a68g_cmd_name, FILENAME (line), (unsigned) k, b) >= 0); } else { ASSERT (snprintf (a, SNPRINTF_SIZE, "%s: %x: %s", a68g_cmd_name, (unsigned) k, b) >= 0); } } else { bufcpy (st, get_severity (sev), SMALL_BUFFER_SIZE); if (FILENAME (line) != NO_TEXT && strcmp (FILE_SOURCE_NAME (&program), FILENAME (line)) == 0) { ASSERT (snprintf (a, SNPRINTF_SIZE, "%s: %s: %x: %s", a68g_cmd_name, st, (unsigned) k, b) >= 0); } else if (FILENAME (line) != NO_TEXT) { ASSERT (snprintf (a, SNPRINTF_SIZE, "%s: %s: %s: %x: %s", a68g_cmd_name, FILENAME (line), st, (unsigned) k, b) >= 0); } else { ASSERT (snprintf (a, SNPRINTF_SIZE, "%s: %s: %x: %s", a68g_cmd_name, st, (unsigned) k, b) >= 0); } } msg = (DIAGNOSTIC_T *) get_heap_space ((size_t) ALIGNED_SIZE_OF (DIAGNOSTIC_T)); *ref_msg = msg; ATTRIBUTE (msg) = sev; if (nst[0] != NULL_CHAR) { bufcat (a, " (", BUFFER_SIZE); bufcat (a, nst, BUFFER_SIZE); bufcat (a, ")", BUFFER_SIZE); } bufcat (a, ".", BUFFER_SIZE); TEXT (msg) = new_string (a, NO_TEXT); WHERE (msg) = p; LINE (msg) = line; SYMBOL (msg) = pos; NUMBER (msg) = k; NEXT (msg) = NO_DIAGNOSTIC; } /* Legend for special symbols: # skip extra syntactical information @ non terminal A non terminal B keyword C context D argument in decimal E string literal from errno H char argument K int argument as 'k', 'M' or 'G' L line number M moid - if error mode return without giving a message N mode - MODE (NIL) O moid - operand S quoted symbol, when possible with typographical display features U unquoted string literal X expected attribute Z quoted string literal. */ #define COMPOSE_DIAGNOSTIC\ while (t[0] != NULL_CHAR) {\ if (t[0] == '#') {\ extra_syntax = A68_FALSE;\ } else if (t[0] == '@') {\ char *nt = non_terminal_string (edit_line, ATTRIBUTE (p));\ if (t != NO_TEXT) {\ bufcat (b, nt, BUFFER_SIZE);\ } else {\ bufcat (b, "construct", BUFFER_SIZE);\ }\ } else if (t[0] == 'A') {\ int att = va_arg (args, int);\ char *nt = non_terminal_string (edit_line, att);\ if (nt != NO_TEXT) {\ bufcat (b, nt, BUFFER_SIZE);\ } else {\ bufcat (b, "construct", BUFFER_SIZE);\ }\ } else if (t[0] == 'B') {\ int att = va_arg (args, int);\ KEYWORD_T *nt = find_keyword_from_attribute (top_keyword, att);\ if (nt != NO_KEYWORD) {\ bufcat (b, "\"", BUFFER_SIZE);\ bufcat (b, TEXT (nt), BUFFER_SIZE);\ bufcat (b, "\"", BUFFER_SIZE);\ } else {\ bufcat (b, "keyword", BUFFER_SIZE);\ }\ } else if (t[0] == 'C') {\ int att = va_arg (args, int);\ if (att == NO_SORT) {\ bufcat (b, "this", BUFFER_SIZE);\ }\ if (att == SOFT) {\ bufcat (b, "a soft", BUFFER_SIZE);\ } else if (att == WEAK) {\ bufcat (b, "a weak", BUFFER_SIZE);\ } else if (att == MEEK) {\ bufcat (b, "a meek", BUFFER_SIZE);\ } else if (att == FIRM) {\ bufcat (b, "a firm", BUFFER_SIZE);\ } else if (att == STRONG) {\ bufcat (b, "a strong", BUFFER_SIZE);\ }\ } else if (t[0] == 'D') {\ int a = va_arg (args, int);\ char d[BUFFER_SIZE];\ ASSERT (snprintf(d, SNPRINTF_SIZE, "%d", a) >= 0);\ bufcat (b, d, BUFFER_SIZE);\ } else if (t[0] == 'H') {\ char *a = va_arg (args, char *);\ char d[SMALL_BUFFER_SIZE];\ ASSERT (snprintf(d, (size_t) SMALL_BUFFER_SIZE, "\"%c\"", a[0]) >= 0);\ bufcat (b, d, BUFFER_SIZE);\ } else if (t[0] == 'L') {\ LINE_T *a = va_arg (args, LINE_T *);\ char d[SMALL_BUFFER_SIZE];\ ABEND (a == NO_LINE, "null source line in error", NO_TEXT);\ if (NUMBER (a) == 0) {\ bufcat (b, "in standard environment", BUFFER_SIZE);\ } else {\ if (p != NO_NODE && NUMBER (a) == LINE_NUMBER (p)) {\ ASSERT (snprintf(d, (size_t) SMALL_BUFFER_SIZE, "in this line") >= 0);\ } else {\ ASSERT (snprintf(d, (size_t) SMALL_BUFFER_SIZE, "in line %d", NUMBER (a)) >= 0);\ }\ bufcat (b, d, BUFFER_SIZE);\ }\ } else if (t[0] == 'M') {\ moid = va_arg (args, MOID_T *);\ if (moid == NO_MOID || moid == MODE (ERROR)) {\ moid = MODE (UNDEFINED);\ }\ if (IS (moid, SERIES_MODE)) {\ if (PACK (moid) != NO_PACK && NEXT (PACK (moid)) == NO_PACK) {\ bufcat (b, moid_to_string (MOID (PACK (moid)), MOID_ERROR_WIDTH, p), BUFFER_SIZE);\ } else {\ bufcat (b, moid_to_string (moid, MOID_ERROR_WIDTH, p), BUFFER_SIZE);\ }\ } else {\ bufcat (b, moid_to_string (moid, MOID_ERROR_WIDTH, p), BUFFER_SIZE);\ }\ } else if (t[0] == 'N') {\ bufcat (b, "NIL name of mode ", BUFFER_SIZE);\ moid = va_arg (args, MOID_T *);\ if (moid != NO_MOID) {\ bufcat (b, moid_to_string (moid, MOID_ERROR_WIDTH, p), BUFFER_SIZE);\ }\ } else if (t[0] == 'O') {\ moid = va_arg (args, MOID_T *);\ if (moid == NO_MOID || moid == MODE (ERROR)) {\ moid = MODE (UNDEFINED);\ }\ if (moid == MODE (VOID)) {\ bufcat (b, "UNION (VOID, ..)", BUFFER_SIZE);\ } else if (IS (moid, SERIES_MODE)) {\ if (PACK (moid) != NO_PACK && NEXT (PACK (moid)) == NO_PACK) {\ bufcat (b, moid_to_string (MOID (PACK (moid)), MOID_ERROR_WIDTH, p), BUFFER_SIZE);\ } else {\ bufcat (b, moid_to_string (moid, MOID_ERROR_WIDTH, p), BUFFER_SIZE);\ }\ } else {\ bufcat (b, moid_to_string (moid, MOID_ERROR_WIDTH, p), BUFFER_SIZE);\ }\ } else if (t[0] == 'S') {\ if (p != NO_NODE && NSYMBOL (p) != NO_TEXT) {\ char *txt = NSYMBOL (p);\ char *sym = NCHAR_IN_LINE (p);\ int n = 0, size = (int) strlen (txt);\ bufcat (b, "\"", BUFFER_SIZE);\ if (txt[0] != sym[0] || (int) strlen (sym) - 1 <= size) {\ bufcat (b, NSYMBOL (p), BUFFER_SIZE);\ } else {\ while (n < size) {\ char str[2];\ str[0] = sym[0];\ str[1] = NULL_CHAR;\ bufcat (b, str, BUFFER_SIZE);\ if (TO_LOWER (txt[0]) == TO_LOWER (sym[0])) {\ txt ++;\ n ++;\ }\ sym ++;\ }\ }\ bufcat (b, "\"", BUFFER_SIZE);\ } else {\ bufcat (b, "symbol", BUFFER_SIZE);\ }\ } else if (t[0] == 'U') {\ char *loc_string = va_arg (args, char *);\ bufcat (b, loc_string, BUFFER_SIZE);\ } else if (t[0] == 'X') {\ int att = va_arg (args, int);\ char z[BUFFER_SIZE];\ /* ASSERT (snprintf(z, SNPRINTF_SIZE, "\"%s\"", TEXT (find_keyword_from_attribute (top_keyword, att))) >= 0); */\ (void) non_terminal_string (z, att);\ bufcat (b, new_string (z, NO_TEXT), BUFFER_SIZE);\ } else if (t[0] == 'Y') {\ char *loc_string = va_arg (args, char *);\ bufcat (b, loc_string, BUFFER_SIZE);\ } else if (t[0] == 'Z') {\ char *loc_string = va_arg (args, char *);\ bufcat (b, "\"", BUFFER_SIZE);\ bufcat (b, loc_string, BUFFER_SIZE);\ bufcat (b, "\"", BUFFER_SIZE);\ } else {\ char q[2];\ q[0] = t[0];\ q[1] = NULL_CHAR;\ bufcat (b, q, BUFFER_SIZE);\ }\ t++;\ } /*! \brief give a diagnostic message \param sev severity \param p position in tree \param loc_str message string \param ... various arguments needed by special symbols in loc_str **/ void diagnostic_node (int sev, NODE_T * p, char *loc_str, ...) { va_list args; MOID_T *moid = NO_MOID; char *t = loc_str, b[BUFFER_SIZE]; BOOL_T force, extra_syntax = A68_TRUE, shortcut = A68_FALSE; int err = errno; va_start (args, loc_str); b[0] = NULL_CHAR; force = (BOOL_T) ((sev & A68_FORCE_DIAGNOSTICS) != 0); sev &= ~A68_FORCE_DIAGNOSTICS; /* No warnings? */ if (!force && sev == A68_WARNING && OPTION_NO_WARNINGS (&program)) { return; } if (sev == A68_WARNING && OPTION_QUIET (&program)) { return; } /* Suppressed? */ if (sev == A68_ERROR || sev == A68_SYNTAX_ERROR) { if (ERROR_COUNT (&program) == MAX_ERRORS) { bufcpy (b, "further error diagnostics suppressed", BUFFER_SIZE); sev = A68_ERROR; shortcut = A68_TRUE; } else if (ERROR_COUNT (&program) > MAX_ERRORS) { ERROR_COUNT (&program)++; return; } } else if (sev == A68_WARNING) { if (WARNING_COUNT (&program) == MAX_ERRORS) { bufcpy (b, "further warning diagnostics suppressed", BUFFER_SIZE); shortcut = A68_TRUE; } else if (WARNING_COUNT (&program) > MAX_ERRORS) { WARNING_COUNT (&program)++; return; } } if (shortcut == A68_FALSE) { /* Synthesize diagnostic message */ COMPOSE_DIAGNOSTIC; /* Add information from errno, if any */ if (err != 0) { char *loc_str2 = new_string (error_specification (), NO_TEXT); if (loc_str2 != NO_TEXT) { char *stu; bufcat (b, " (", BUFFER_SIZE); for (stu = loc_str2; stu[0] != NULL_CHAR; stu++) { stu[0] = (char) TO_LOWER (stu[0]); } bufcat (b, loc_str2, BUFFER_SIZE); bufcat (b, ")", BUFFER_SIZE); } } } /* Construct a diagnostic message */ if (sev == A68_WARNING) { WARNING_COUNT (&program)++; } else { ERROR_COUNT (&program)++; } if (p == NO_NODE) { write_diagnostic (sev, b); } else { add_diagnostic (NO_LINE, NO_TEXT, p, sev, b); } va_end (args); } /*! \brief give a diagnostic message \param sev severity \param p position in tree \param loc_str message string \param ... various arguments needed by special symbols in loc_str **/ void diagnostic_line (int sev, LINE_T * line, char *pos, char *loc_str, ...) { va_list args; MOID_T *moid = NO_MOID; char *t = loc_str, b[BUFFER_SIZE]; BOOL_T force, extra_syntax = A68_TRUE, shortcut = A68_FALSE; int err = errno; NODE_T *p = NO_NODE; b[0] = NULL_CHAR; va_start (args, loc_str); force = (BOOL_T) ((sev & A68_FORCE_DIAGNOSTICS) != 0); sev &= ~A68_FORCE_DIAGNOSTICS; /* No warnings? */ if (!force && sev == A68_WARNING && OPTION_NO_WARNINGS (&program)) { return; } if (sev == A68_WARNING && OPTION_QUIET (&program)) { return; } /* Suppressed? */ if (sev == A68_ERROR || sev == A68_SYNTAX_ERROR) { if (ERROR_COUNT (&program) == MAX_ERRORS) { bufcpy (b, "further error diagnostics suppressed", BUFFER_SIZE); sev = A68_ERROR; shortcut = A68_TRUE; } else if (ERROR_COUNT (&program) > MAX_ERRORS) { ERROR_COUNT (&program)++; return; } } else if (sev == A68_WARNING) { if (WARNING_COUNT (&program) == MAX_ERRORS) { bufcpy (b, "further warning diagnostics suppressed", BUFFER_SIZE); shortcut = A68_TRUE; } else if (WARNING_COUNT (&program) > MAX_ERRORS) { WARNING_COUNT (&program)++; return; } } if (!shortcut) { /* Synthesize diagnostic message */ COMPOSE_DIAGNOSTIC; /* Add information from errno, if any */ if (err != 0) { char *loc_str2 = new_string (error_specification (), NO_TEXT); if (loc_str2 != NO_TEXT) { char *stu; bufcat (b, " (", BUFFER_SIZE); for (stu = loc_str2; stu[0] != NULL_CHAR; stu++) { stu[0] = (char) TO_LOWER (stu[0]); } bufcat (b, loc_str2, BUFFER_SIZE); bufcat (b, ")", BUFFER_SIZE); } } } /* Construct a diagnostic message */ if (pos != NO_TEXT && IS_PRINT (*pos)) { bufcat (b, " (detected at", BUFFER_SIZE); if (*pos == '\"') { bufcat (b, " quote-character", BUFFER_SIZE); } else { bufcat (b, " character \"", BUFFER_SIZE); bufcat (b, char_to_str (*pos), BUFFER_SIZE); bufcat (b, "\"", BUFFER_SIZE); } bufcat (b, ")", BUFFER_SIZE); } if (sev == A68_WARNING) { WARNING_COUNT (&program)++; } else { ERROR_COUNT (&program)++; } if (line == NO_LINE) { write_diagnostic (sev, b); } else { add_diagnostic (line, pos, NO_NODE, sev, b); } va_end (args); } /*! \brief add keyword to the tree \param p top keyword \param a attribute \param t keyword text **/ static void add_keyword (KEYWORD_T ** p, int a, char *t) { while (*p != NO_KEYWORD) { int k = strcmp (t, TEXT (*p)); if (k < 0) { p = &LESS (*p); } else { p = &MORE (*p); } } *p = (KEYWORD_T *) get_fixed_heap_space ((size_t) ALIGNED_SIZE_OF (KEYWORD_T)); ATTRIBUTE (*p) = a; TEXT (*p) = t; LESS (*p) = MORE (*p) = NO_KEYWORD; } /*! \brief make tables of keywords and non-terminals **/ void set_up_tables (void) { /* Entries are randomised to balance the tree */ if (OPTION_STRICT (&program) == A68_FALSE) { add_keyword (&top_keyword, ENVIRON_SYMBOL, "ENVIRON"); add_keyword (&top_keyword, DOWNTO_SYMBOL, "DOWNTO"); add_keyword (&top_keyword, UNTIL_SYMBOL, "UNTIL"); add_keyword (&top_keyword, CLASS_SYMBOL, "CLASS"); add_keyword (&top_keyword, NEW_SYMBOL, "NEW"); add_keyword (&top_keyword, DIAGONAL_SYMBOL, "DIAG"); add_keyword (&top_keyword, TRANSPOSE_SYMBOL, "TRNSP"); add_keyword (&top_keyword, ROW_SYMBOL, "ROW"); add_keyword (&top_keyword, COLUMN_SYMBOL, "COL"); add_keyword (&top_keyword, CODE_SYMBOL, "CODE"); add_keyword (&top_keyword, EDOC_SYMBOL, "EDOC"); add_keyword (&top_keyword, ANDF_SYMBOL, "THEF"); add_keyword (&top_keyword, ORF_SYMBOL, "ELSF"); add_keyword (&top_keyword, ANDF_SYMBOL, "ANDTH"); add_keyword (&top_keyword, ORF_SYMBOL, "OREL"); add_keyword (&top_keyword, ANDF_SYMBOL, "ANDF"); add_keyword (&top_keyword, ORF_SYMBOL, "ORF"); } add_keyword (&top_keyword, POINT_SYMBOL, "."); add_keyword (&top_keyword, COMPLEX_SYMBOL, "COMPLEX"); add_keyword (&top_keyword, ACCO_SYMBOL, "{"); add_keyword (&top_keyword, OCCA_SYMBOL, "}"); add_keyword (&top_keyword, SOUND_SYMBOL, "SOUND"); add_keyword (&top_keyword, COLON_SYMBOL, ":"); add_keyword (&top_keyword, THEN_BAR_SYMBOL, "|"); add_keyword (&top_keyword, SUB_SYMBOL, "["); add_keyword (&top_keyword, BY_SYMBOL, "BY"); add_keyword (&top_keyword, OP_SYMBOL, "OP"); add_keyword (&top_keyword, COMMA_SYMBOL, ","); add_keyword (&top_keyword, AT_SYMBOL, "AT"); add_keyword (&top_keyword, PRIO_SYMBOL, "PRIO"); add_keyword (&top_keyword, STYLE_I_COMMENT_SYMBOL, "CO"); add_keyword (&top_keyword, END_SYMBOL, "END"); add_keyword (&top_keyword, GO_SYMBOL, "GO"); add_keyword (&top_keyword, TO_SYMBOL, "TO"); add_keyword (&top_keyword, ELSE_BAR_SYMBOL, "|:"); add_keyword (&top_keyword, THEN_SYMBOL, "THEN"); add_keyword (&top_keyword, TRUE_SYMBOL, "TRUE"); add_keyword (&top_keyword, PROC_SYMBOL, "PROC"); add_keyword (&top_keyword, FOR_SYMBOL, "FOR"); add_keyword (&top_keyword, GOTO_SYMBOL, "GOTO"); add_keyword (&top_keyword, WHILE_SYMBOL, "WHILE"); add_keyword (&top_keyword, IS_SYMBOL, ":=:"); add_keyword (&top_keyword, ASSIGN_TO_SYMBOL, "=:"); add_keyword (&top_keyword, COMPL_SYMBOL, "COMPL"); add_keyword (&top_keyword, FROM_SYMBOL, "FROM"); add_keyword (&top_keyword, BOLD_PRAGMAT_SYMBOL, "PRAGMAT"); add_keyword (&top_keyword, BOLD_COMMENT_SYMBOL, "COMMENT"); add_keyword (&top_keyword, DO_SYMBOL, "DO"); add_keyword (&top_keyword, STYLE_II_COMMENT_SYMBOL, "#"); add_keyword (&top_keyword, CASE_SYMBOL, "CASE"); add_keyword (&top_keyword, LOC_SYMBOL, "LOC"); add_keyword (&top_keyword, CHAR_SYMBOL, "CHAR"); add_keyword (&top_keyword, ISNT_SYMBOL, ":/=:"); add_keyword (&top_keyword, REF_SYMBOL, "REF"); add_keyword (&top_keyword, NIL_SYMBOL, "NIL"); add_keyword (&top_keyword, ASSIGN_SYMBOL, ":="); add_keyword (&top_keyword, FI_SYMBOL, "FI"); add_keyword (&top_keyword, FILE_SYMBOL, "FILE"); add_keyword (&top_keyword, PAR_SYMBOL, "PAR"); add_keyword (&top_keyword, ASSERT_SYMBOL, "ASSERT"); add_keyword (&top_keyword, OUSE_SYMBOL, "OUSE"); add_keyword (&top_keyword, IN_SYMBOL, "IN"); add_keyword (&top_keyword, LONG_SYMBOL, "LONG"); add_keyword (&top_keyword, SEMI_SYMBOL, ";"); add_keyword (&top_keyword, EMPTY_SYMBOL, "EMPTY"); add_keyword (&top_keyword, MODE_SYMBOL, "MODE"); add_keyword (&top_keyword, IF_SYMBOL, "IF"); add_keyword (&top_keyword, OD_SYMBOL, "OD"); add_keyword (&top_keyword, OF_SYMBOL, "OF"); add_keyword (&top_keyword, STRUCT_SYMBOL, "STRUCT"); add_keyword (&top_keyword, STYLE_I_PRAGMAT_SYMBOL, "PR"); add_keyword (&top_keyword, BUS_SYMBOL, "]"); add_keyword (&top_keyword, SKIP_SYMBOL, "SKIP"); add_keyword (&top_keyword, SHORT_SYMBOL, "SHORT"); add_keyword (&top_keyword, IS_SYMBOL, "IS"); add_keyword (&top_keyword, ESAC_SYMBOL, "ESAC"); add_keyword (&top_keyword, CHANNEL_SYMBOL, "CHANNEL"); add_keyword (&top_keyword, REAL_SYMBOL, "REAL"); add_keyword (&top_keyword, STRING_SYMBOL, "STRING"); add_keyword (&top_keyword, BOOL_SYMBOL, "BOOL"); add_keyword (&top_keyword, ISNT_SYMBOL, "ISNT"); add_keyword (&top_keyword, FALSE_SYMBOL, "FALSE"); add_keyword (&top_keyword, UNION_SYMBOL, "UNION"); add_keyword (&top_keyword, OUT_SYMBOL, "OUT"); add_keyword (&top_keyword, OPEN_SYMBOL, "("); add_keyword (&top_keyword, BEGIN_SYMBOL, "BEGIN"); add_keyword (&top_keyword, FLEX_SYMBOL, "FLEX"); add_keyword (&top_keyword, VOID_SYMBOL, "VOID"); add_keyword (&top_keyword, BITS_SYMBOL, "BITS"); add_keyword (&top_keyword, ELSE_SYMBOL, "ELSE"); add_keyword (&top_keyword, EXIT_SYMBOL, "EXIT"); add_keyword (&top_keyword, HEAP_SYMBOL, "HEAP"); add_keyword (&top_keyword, INT_SYMBOL, "INT"); add_keyword (&top_keyword, BYTES_SYMBOL, "BYTES"); add_keyword (&top_keyword, PIPE_SYMBOL, "PIPE"); add_keyword (&top_keyword, FORMAT_SYMBOL, "FORMAT"); add_keyword (&top_keyword, SEMA_SYMBOL, "SEMA"); add_keyword (&top_keyword, CLOSE_SYMBOL, ")"); add_keyword (&top_keyword, AT_SYMBOL, "@"); add_keyword (&top_keyword, ELIF_SYMBOL, "ELIF"); add_keyword (&top_keyword, FORMAT_DELIMITER_SYMBOL, "$"); } /* Next are routines to calculate the size of a mode */ /*! \brief max unitings to simplout \param p position in tree \param max maximum calculated moid size **/ static void max_unitings_to_simplout (NODE_T * p, int *max) { for (; p != NO_NODE; FORWARD (p)) { if (IS (p, UNITING) && MOID (p) == MODE (SIMPLOUT)) { MOID_T *q = MOID (SUB (p)); if (q != MODE (SIMPLOUT)) { int size = moid_size (q); if (size > *max) { *max = size; } } } max_unitings_to_simplout (SUB (p), max); } } /*! \brief get max simplout size \param p position in tree **/ void get_max_simplout_size (NODE_T * p) { max_simplout_size = A68_REF_SIZE; /* For anonymous SKIP */ max_unitings_to_simplout (p, &max_simplout_size); } /*! \brief set moid sizes \param z moid to start from **/ void set_moid_sizes (MOID_T * z) { for (; z != NO_MOID; FORWARD (z)) { SIZE (z) = moid_size (z); } } /*! \brief moid size 2 \param p moid to calculate \return moid size **/ static int moid_size_2 (MOID_T * p) { if (p == NO_MOID) { return (0); } else if (EQUIVALENT (p) != NO_MOID) { return (moid_size_2 (EQUIVALENT (p))); } else if (p == MODE (HIP)) { return (0); } else if (p == MODE (VOID)) { return (0); } else if (p == MODE (INT)) { return (ALIGNED_SIZE_OF (A68_INT)); } else if (p == MODE (LONG_INT)) { return ((int) size_long_mp ()); } else if (p == MODE (LONGLONG_INT)) { return ((int) size_longlong_mp ()); } else if (p == MODE (REAL)) { return (ALIGNED_SIZE_OF (A68_REAL)); } else if (p == MODE (LONG_REAL)) { return ((int) size_long_mp ()); } else if (p == MODE (LONGLONG_REAL)) { return ((int) size_longlong_mp ()); } else if (p == MODE (BOOL)) { return (ALIGNED_SIZE_OF (A68_BOOL)); } else if (p == MODE (CHAR)) { return (ALIGNED_SIZE_OF (A68_CHAR)); } else if (p == MODE (ROW_CHAR)) { return (A68_REF_SIZE); } else if (p == MODE (BITS)) { return (ALIGNED_SIZE_OF (A68_BITS)); } else if (p == MODE (LONG_BITS)) { return ((int) size_long_mp ()); } else if (p == MODE (LONGLONG_BITS)) { return ((int) size_longlong_mp ()); } else if (p == MODE (BYTES)) { return (ALIGNED_SIZE_OF (A68_BYTES)); } else if (p == MODE (LONG_BYTES)) { return (ALIGNED_SIZE_OF (A68_LONG_BYTES)); } else if (p == MODE (FILE)) { return (ALIGNED_SIZE_OF (A68_FILE)); } else if (p == MODE (CHANNEL)) { return (ALIGNED_SIZE_OF (A68_CHANNEL)); } else if (p == MODE (FORMAT)) { return (ALIGNED_SIZE_OF (A68_FORMAT)); } else if (p == MODE (SEMA)) { return (A68_REF_SIZE); } else if (p == MODE (SOUND)) { return (ALIGNED_SIZE_OF (A68_SOUND)); } else if (p == MODE (COLLITEM)) { return (ALIGNED_SIZE_OF (A68_COLLITEM)); } else if (p == MODE (NUMBER)) { int k = 0; if (ALIGNED_SIZE_OF (A68_INT) > k) { k = ALIGNED_SIZE_OF (A68_INT); } if ((int) size_long_mp () > k) { k = (int) size_long_mp (); } if ((int) size_longlong_mp () > k) { k = (int) size_longlong_mp (); } if (ALIGNED_SIZE_OF (A68_REAL) > k) { k = ALIGNED_SIZE_OF (A68_REAL); } if ((int) size_long_mp () > k) { k = (int) size_long_mp (); } if ((int) size_longlong_mp () > k) { k = (int) size_longlong_mp (); } if (A68_REF_SIZE > k) { k = A68_REF_SIZE; } return (ALIGNED_SIZE_OF (A68_UNION) + k); } else if (p == MODE (SIMPLIN)) { int k = 0; if (A68_REF_SIZE > k) { k = A68_REF_SIZE; } if (ALIGNED_SIZE_OF (A68_FORMAT) > k) { k = ALIGNED_SIZE_OF (A68_FORMAT); } if (ALIGNED_SIZE_OF (A68_PROCEDURE) > k) { k = ALIGNED_SIZE_OF (A68_PROCEDURE); } if (ALIGNED_SIZE_OF (A68_SOUND) > k) { k = ALIGNED_SIZE_OF (A68_SOUND); } return (ALIGNED_SIZE_OF (A68_UNION) + k); } else if (p == MODE (SIMPLOUT)) { return (ALIGNED_SIZE_OF (A68_UNION) + max_simplout_size); } else if (IS (p, REF_SYMBOL)) { return (A68_REF_SIZE); } else if (IS (p, PROC_SYMBOL)) { return (ALIGNED_SIZE_OF (A68_PROCEDURE)); } else if (IS (p, ROW_SYMBOL) && p != MODE (ROWS)) { return (A68_REF_SIZE); } else if (p == MODE (ROWS)) { return (ALIGNED_SIZE_OF (A68_UNION) + A68_REF_SIZE); } else if (IS (p, FLEX_SYMBOL)) { return moid_size (SUB (p)); } else if (IS (p, STRUCT_SYMBOL)) { PACK_T *z = PACK (p); int size = 0; for (; z != NO_PACK; FORWARD (z)) { size += moid_size (MOID (z)); } return (size); } else if (IS (p, UNION_SYMBOL)) { PACK_T *z = PACK (p); int size = 0; for (; z != NO_PACK; FORWARD (z)) { if (moid_size (MOID (z)) > size) { size = moid_size (MOID (z)); } } return (ALIGNED_SIZE_OF (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 size \param p moid to set size \return moid size **/ int moid_size (MOID_T * p) { SIZE (p) = moid_size_2 (p); return (SIZE (p)); } /******************************/ /* A pretty printer for moids */ /******************************/ /*! \brief moid to string 3 \param dst text buffer \param str string to concatenate \param w estimated width \param idf print indicants if one exists in this range **/ static void add_to_moid_text (char *dst, char *str, int *w) { bufcat (dst, str, BUFFER_SIZE); (*w) -= (int) strlen (str); } /*! \brief find a tag, searching symbol tables towards the root \param table symbol table to search \param mode mode of the tag \return entry in symbol table **/ TAG_T *find_indicant_global (TABLE_T * table, MOID_T * mode) { if (table != NO_TABLE) { TAG_T *s; for (s = INDICANTS (table); s != NO_TAG; FORWARD (s)) { if (MOID (s) == mode) { return (s); } } return (find_indicant_global (PREVIOUS (table), mode)); } else { return (NO_TAG); } } /*! \brief pack to string \param b text buffer \param p pack \param w estimated width \param text include field names \param idf print indicants if one exists in this range **/ static void pack_to_string (char *b, PACK_T * p, int *w, BOOL_T text, NODE_T * idf) { for (; p != NO_PACK; FORWARD (p)) { moid_to_string_2 (b, MOID (p), w, idf); if (text) { if (TEXT (p) != NO_TEXT) { add_to_moid_text (b, " ", w); add_to_moid_text (b, TEXT (p), w); } } if (p != NO_PACK && NEXT (p) != NO_PACK) { add_to_moid_text (b, ", ", w); } } } /*! \brief moid to string 2 \param b text buffer \param n moid \param w estimated width \param idf print indicants if one exists in this range **/ static void moid_to_string_2 (char *b, MOID_T * n, int *w, NODE_T * idf) { /* Oops. Should not happen */ if (n == NO_MOID) { add_to_moid_text (b, "null", w);; return; } /* Reference to self through REF or PROC */ if (is_postulated (postulates, n)) { add_to_moid_text (b, "SELF", w); return; } /* If declared by a mode-declaration, present the indicant */ if (idf != NO_NODE && ISNT (n, STANDARD)) { TAG_T *indy = find_indicant_global (TABLE (idf), n); if (indy != NO_TAG) { add_to_moid_text (b, NSYMBOL (NODE (indy)), w); return; } } /* Write the standard modes */ if (n == MODE (HIP)) { add_to_moid_text (b, "HIP", w); } else if (n == MODE (ERROR)) { add_to_moid_text (b, "ERROR", w); } else if (n == MODE (UNDEFINED)) { add_to_moid_text (b, "unresolved", w); } else if (n == MODE (C_STRING)) { add_to_moid_text (b, "C-STRING", w); } else if (n == MODE (COMPLEX) || n == MODE (COMPL)) { add_to_moid_text (b, "COMPLEX", w); } else if (n == MODE (LONG_COMPLEX) || n == MODE (LONG_COMPL)) { add_to_moid_text (b, "LONG COMPLEX", w); } else if (n == MODE (LONGLONG_COMPLEX) || n == MODE (LONGLONG_COMPL)) { add_to_moid_text (b, "LONG LONG COMPLEX", w); } else if (n == MODE (STRING)) { add_to_moid_text (b, "STRING", w); } else if (n == MODE (PIPE)) { add_to_moid_text (b, "PIPE", w); } else if (n == MODE (SOUND)) { add_to_moid_text (b, "SOUND", w); } else if (n == MODE (COLLITEM)) { add_to_moid_text (b, "COLLITEM", w); } else if (IS (n, IN_TYPE_MODE)) { add_to_moid_text (b, "\"SIMPLIN\"", w); } else if (IS (n, OUT_TYPE_MODE)) { add_to_moid_text (b, "\"SIMPLOUT\"", w); } else if (IS (n, ROWS_SYMBOL)) { add_to_moid_text (b, "\"ROWS\"", w); } else if (n == MODE (VACUUM)) { add_to_moid_text (b, "\"VACUUM\"", w); } else if (IS (n, VOID_SYMBOL) || IS (n, STANDARD) || IS (n, INDICANT)) { if (DIM (n) > 0) { int k = DIM (n); if ((*w) >= k * (int) strlen ("LONG ") + (int) strlen (NSYMBOL (NODE (n)))) { while (k --) { add_to_moid_text (b, "LONG ", w); } add_to_moid_text (b, NSYMBOL (NODE (n)), w); } else { add_to_moid_text (b, "..", w); } } else if (DIM (n) < 0) { int k = -DIM (n); if ((*w) >= k * (int) strlen ("LONG ") + (int) strlen (NSYMBOL (NODE (n)))) { while (k --) { add_to_moid_text (b, "LONG ", w); } add_to_moid_text (b, NSYMBOL (NODE (n)), w); } else { add_to_moid_text (b, "..", w); } } else if (DIM (n) == 0) { add_to_moid_text (b, NSYMBOL (NODE (n)), w); } /* Write compounded modes */ } else if (IS (n, REF_SYMBOL)) { if ((*w) >= (int) strlen ("REF ..")) { add_to_moid_text (b, "REF ", w); moid_to_string_2 (b, SUB (n), w, idf); } else { add_to_moid_text (b, "REF ..", w); } } else if (IS (n, FLEX_SYMBOL)) { if ((*w) >= (int) strlen ("FLEX ..")) { add_to_moid_text (b, "FLEX ", w); moid_to_string_2 (b, SUB (n), w, idf); } else { add_to_moid_text (b, "FLEX ..", w); } } else if (IS (n, ROW_SYMBOL)) { int j = (int) strlen ("[] ..") + (DIM (n) - 1) * (int) strlen (","); if ((*w) >= j) { int k = DIM (n) - 1; add_to_moid_text (b, "[", w); while (k-- > 0) { add_to_moid_text (b, ",", w); } add_to_moid_text (b, "] ", w); moid_to_string_2 (b, SUB (n), w, idf); } else if (DIM (n) == 1) { add_to_moid_text (b, "[] ..", w); } else { int k = DIM (n); add_to_moid_text (b, "[", w); while (k--) { add_to_moid_text (b, ",", w); } add_to_moid_text (b, "] ..", w); } } else if (IS (n, STRUCT_SYMBOL)) { int j = (int) strlen ("STRUCT ()") + (DIM (n) - 1) * (int) strlen (".., ") + (int) strlen (".."); if ((*w) >= j) { POSTULATE_T *save = postulates; make_postulate (&postulates, n, NO_MOID); add_to_moid_text (b, "STRUCT (", w); pack_to_string (b, PACK (n), w, A68_TRUE, idf); add_to_moid_text (b, ")", w); free_postulate_list (postulates, save); postulates = save; } else { int k = DIM (n); add_to_moid_text (b, "STRUCT (", w); while (k-- > 0) { add_to_moid_text (b, ",", w); } add_to_moid_text (b, ")", w); } } else if (IS (n, UNION_SYMBOL)) { int j = (int) strlen ("UNION ()") + (DIM (n) - 1) * (int) strlen (".., ") + (int) strlen (".."); if ((*w) >= j) { POSTULATE_T *save = postulates; make_postulate (&postulates, n, NO_MOID); add_to_moid_text (b, "UNION (", w); pack_to_string (b, PACK (n), w, A68_FALSE, idf); add_to_moid_text (b, ")", w); free_postulate_list (postulates, save); postulates = save; } else { int k = DIM (n); add_to_moid_text (b, "UNION (", w); while (k-- > 0) { add_to_moid_text (b, ",", w); } add_to_moid_text (b, ")", w); } } else if (IS (n, PROC_SYMBOL) && DIM (n) == 0) { if ((*w) >= (int) strlen ("PROC ..")) { add_to_moid_text (b, "PROC ", w); moid_to_string_2 (b, SUB (n), w, idf); } else { add_to_moid_text (b, "PROC ..", w); } } else if (IS (n, PROC_SYMBOL) && DIM (n) > 0) { int j = (int) strlen ("PROC () ..") + (DIM (n) - 1) * (int) strlen (".., ") + (int) strlen (".."); if ((*w) >= j) { POSTULATE_T *save = postulates; make_postulate (&postulates, n, NO_MOID); add_to_moid_text (b, "PROC (", w); pack_to_string (b, PACK (n), w, A68_FALSE, idf); add_to_moid_text (b, ") ", w); moid_to_string_2 (b, SUB (n), w, idf); free_postulate_list (postulates, save); postulates = save; } else { int k = DIM (n); add_to_moid_text (b, "PROC (", w); while (k-- > 0) { add_to_moid_text (b, ",", w); } add_to_moid_text (b, ") ..", w); } } else if (IS (n, SERIES_MODE) || IS (n, STOWED_MODE)) { int j = (int) strlen ("()") + (DIM (n) - 1) * (int) strlen (".., ") + (int) strlen (".."); if ((*w) >= j) { add_to_moid_text (b, "(", w); pack_to_string (b, PACK (n), w, A68_FALSE, idf); add_to_moid_text (b, ")", w); } else { int k = DIM (n); add_to_moid_text (b, "(", w); while (k-- > 0) { add_to_moid_text (b, ",", w); } add_to_moid_text (b, ")", w); } } else { char str[SMALL_BUFFER_SIZE]; ASSERT (snprintf (str, (size_t) SMALL_BUFFER_SIZE, "\\%d", ATTRIBUTE (n)) >= 0); add_to_moid_text (b, str, w); } } /*! \brief pretty-formatted mode "n"; "w" is a measure of width \param n moid \param w estimated width; if w is exceeded, modes are abbreviated \param idf print indicants if one exists in this range \return text buffer **/ char *moid_to_string (MOID_T * n, int w, NODE_T * idf) { char a[BUFFER_SIZE]; a[0] = NULL_CHAR; if (w >= BUFFER_SIZE) { w = BUFFER_SIZE - 1; } postulates = NO_POSTULATE; if (n != NO_MOID) { moid_to_string_2 (a, n, &w, idf); } else { bufcat (a, "null", BUFFER_SIZE); } return (new_string (a, NO_TEXT)); } algol68g-2.4.1/source/a68g.h0000644000175000001440000043664711771373134012327 00000000000000/*! \file algol68g.h \brief general definitions for Algol 68 Genie **/ /* This file is part of Algol68G - an Algol 68 interpreter. Copyright (C) 2001-2012 J. Marcel van der Veer . 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_ALGOL68G_H #define A68G_ALGOL68G_H /*****************/ /* Configuration */ /*****************/ #include "a68g-config.h" /*************************/ /* Derived configuration */ /*************************/ /* Do we have a compiler? */ #if (! defined HAVE_GCC || defined NO_MINUS_C_MINUS_O || ! defined HAVE_DL) #undef HAVE_COMPILER #elif (! HAVE_MAC_OS_X && ! defined HAVE_EXPORT_DYNAMIC) #undef HAVE_COMPILER #elif ((defined HAVE_LINUX || defined HAVE_MAC_OS_X) && defined HAVE_DL) #define HAVE_COMPILER 1 #elif (defined HAVE_FREEBSD || defined HAVE_NETBSD) #define HAVE_COMPILER 1 #else #undef HAVE_COMPILER #endif /* Can we access the internet? */ #if (defined HAVE_NETDB_H && defined HAVE_NETINET_IN_H && defined HAVE_SYS_SOCKET_H) #if (defined HAVE_LINUX || defined HAVE_MAC_OS_X || defined HAVE_FREEBSD || defined HAVE_NETBSD) #define HAVE_HTTP #endif #endif /* Do we have an editor? */ #if (defined HAVE_CURSES && defined HAVE_REGEX_H) #define HAVE_EDITOR #endif /************/ /* Includes */ /************/ #if defined HAVE_SYS_TYPES_H #include #endif #if defined HAVE_STDIO_H #include #endif #if defined HAVE_LIMITS_H #include #endif #if defined HAVE_ASSERT_H #include #endif #if defined HAVE_CONIO_H #include #endif #if defined HAVE_CTYPE_H #include #endif #if defined HAVE_CURSES_H #include #elif defined HAVE_NCURSES_CURSES_H #include #endif #if defined HAVE_READLINE_READLINE_H #include #endif #if defined HAVE_READLINE_HISTORY_H #include #endif #if defined HAVE_DIRENT_H #include #endif #if defined HAVE_DL #include #endif #if defined HAVE_ERRNO_H #include #endif #if defined HAVE_FCNTL_H #include #endif #if defined HAVE_FLOAT_H #include #endif #if defined HAVE_LIBPQ-FE_H #include #endif #if defined HAVE_MATH_H #include #endif #if defined HAVE_NETDB_H #include #endif #if defined HAVE_NETINET_IN_H #include #endif #if defined HAVE_GNU_PLOTUTILS #include #endif #if defined HAVE_PTHREAD_H #include #endif #if defined HAVE_REGEX_H #include #endif #if defined HAVE_SETJMP_H #include #endif #if defined HAVE_SIGNAL_H #include #endif #if defined HAVE_STDARG_H #include #endif #if defined HAVE_STDDEF_H #include #endif #if defined HAVE_STDLIB_H #include #endif #if defined HAVE_STRING_H #include #endif #if defined HAVE_STRINGS_H #include #endif #if (defined HAVE_TERMIOS_H && ! defined TIOCGWINSZ) #include #elif (defined HAVE_TERMIOS_H && ! defined GWINSZ_IN_SYS_IOCTL) #include #endif #if defined HAVE_TIME_H #include #endif #if defined HAVE_UNISTD_H #include #endif #if defined HAVE_SYS_IOCTL_H #include #endif #if defined HAVE_SYS_RESOURCE_H #include #endif #if defined HAVE_SYS_SOCKET_H #include #endif #if defined HAVE_SYS_STAT_H #include #endif #if defined HAVE_SYS_TIME_H #include #endif #if defined HAVE_SYS_WAIT_H #include #endif #if defined HAVE_GSL_GSL_BLAS_H #include #endif #if defined HAVE_GSL_GSL_COMPLEX_H #include #endif #if defined HAVE_GSL_GSL_COMPLEX_H #include #endif #if defined HAVE_GSL_GSL_COMPLEX_H #include #endif #if defined HAVE_GSL_GSL_COMPLEX_MATH_H #include #endif #if defined HAVE_GSL_GSL_COMPLEX_MATH_H #include #endif #if defined HAVE_GSL_GSL_COMPLEX_MATH_H #include #endif #if defined HAVE_GSL_GSL_ERRNO_H #include #endif #if defined HAVE_GSL_GSL_ERRNO_H #include #endif #if defined HAVE_GSL_GSL_ERRNO_H #include #endif #if defined HAVE_GSL_GSL_FFT_COMPLEX_H #include #endif #if defined HAVE_GSL_GSL_INTEGRATION_H #include #endif #if defined HAVE_GSL_GSL_LINALG_H #include #endif #if defined HAVE_GSL_GSL_MATH_H #include #endif #if defined HAVE_GSL_GSL_MATH_H #include #endif #if defined HAVE_GSL_GSL_MATH_H #include #endif #if defined HAVE_GSL_GSL_MATRIX_H #include #endif #if defined HAVE_GSL_GSL_PERMUTATION_H #include #endif #if defined HAVE_GSL_GSL_SF_H #include #endif #if defined HAVE_GSL_GSL_SF_H #include #endif #if defined HAVE_GSL_GSL_SF_H #include #endif #if defined HAVE_GSL_GSL_VECTOR_H #include #endif /*****************/ /* Compatibility */ /*****************/ #if ! defined HAVE_SNPRINTF #define snprintf a68g_snprintf extern int a68g_snprintf (char *, size_t, char *, ...); #endif #if ! defined O_BINARY #define O_BINARY 0x0000 #endif /*************/ /* Constants */ /*************/ #define A68_DIR ".a68g" #define A68_FALSE ((BOOL_T) 0) #define A68_HISTORY_FILE ".a68g.edit.hist" #define A68_MAX_BITS (UINT_MAX) #define A68_MAX_INT (INT_MAX) #define A68_MAX_UNT (UINT_MAX) #define A68_NO_FILENO ((FILE_T) -1) #define A68_PI 3.1415926535897932384626433832795029 #define A68_PROTECTION (S_IRUSR | S_IWUSR | S_IRGRP | S_IROTH) /* -rw-r--r-- */ #define A68_READ_ACCESS (O_RDONLY) #define A68_TRUE ((BOOL_T) 1) #define A68_WRITE_ACCESS (O_WRONLY | O_CREAT | O_TRUNC) #define BACKSLASH_CHAR '\\' #define BINARY_EXTENSION ".o" #define BLANK_CHAR ' ' #define BUFFER_SIZE (KILOBYTE) #define BYTES_WIDTH 32 #define CR_CHAR '\r' #define DEFAULT_DOUBLE_DIGITS 5 #define DEFAULT_MP_RADIX 10000000 #define DEFAULT_WIDTH (-1) #define DIGIT_BLANK ((unsigned) 0x2) #define DIGIT_NORMAL ((unsigned) 0x1) #define DOUBLE_ACCURACY (DBL_DIG - 1) #define EMBEDDED_FORMAT A68_TRUE #define EOF_CHAR (EOF) #define ERROR_CHAR '*' #define ESCAPE_CHAR '\033' #define EXPONENT_CHAR 'e' #define FLIP_CHAR 'T' #define FLOP_CHAR 'F' #define FORMFEED_CHAR '\f' #define GIGABYTE (KILOBYTE * MEGABYTE) #define HIDDEN_TEMP_FILE_NAME ".a68g.tmp" #define INSERTION_BLANK ((unsigned) 0x20) #define INSERTION_NORMAL ((unsigned) 0x10) #define ITEM_NOT_USED (-1) #define KILOBYTE ((int) 1024) #define LIBRARY_EXTENSION ".so" #define LISTING_EXTENSION ".l" #define LOG2_10 3.321928094887362347870319430 #define LOG_MP_BASE 7 #define LONGLONG_EXP_WIDTH (EXP_WIDTH) #define LONG_BYTES_WIDTH 256 #define LONG_EXP_WIDTH (EXP_WIDTH) #define LONG_MP_DIGITS DEFAULT_DOUBLE_DIGITS #define MAX_ERRORS 8 #define MAX_MP_EXPONENT 142857 /* Arbitrary. Let M = MAX_REPR_INT then the largest range is M / Log M / LOG_MP_BASE */ #define MAX_OPEN_FILES 64 /* Some OS's won't open more than this number */ #define MAX_PRIORITY 9 #define MAX_REPR_INT 9007199254740992.0 /* 2^53, max int in a double */ #define MAX_TERM_HEIGTH 24 #define MAX_TERM_WIDTH (BUFFER_SIZE / 2) #define MAX_TRANSPUT_BUFFER (MAX_OPEN_FILES) #define MEGABYTE (KILOBYTE * KILOBYTE) #define MIN_MEM_SIZE (128 * KILOBYTE) #define MOID_ERROR_WIDTH 80 #define MOID_WIDTH 80 #define MONADS "%^&+-~!?" #define MP_BITS_BITS 23 #define MP_BITS_RADIX 8388608 /* Max power of two smaller than MP_RADIX */ #define MP_RADIX DEFAULT_MP_RADIX #define NEWLINE_CHAR '\n' #define NEWLINE_STRING "\n" #define NOMADS "> 0) {*_m_u++ = *_m_v++; _m_k -= A68_ALIGNMENT;}} #define MOVE(d, s, n) {\ int _m_k = (int) (n); BYTE_T *_m_d = (BYTE_T *) (d), *_m_s = (BYTE_T *) (s);\ if (_m_s < _m_d) {\ _m_d += _m_k; _m_s += _m_k;\ while (_m_k--) {*(--_m_d) = *(--_m_s);}\ } else {\ while (_m_k--) {*(_m_d++) = *(_m_s++);}\ }} #define FILL(d, s, n) {\ int _m_k = (n); BYTE_T *_m_u = (BYTE_T *) (d), _m_v = (BYTE_T) (s);\ while (_m_k--) {*_m_u++ = _m_v;}} #define FILL_ALIGNED(d, s, n) {\ int _m_k = (n); A68_ALIGN_T *_m_u = (A68_ALIGN_T *) (d), _m_v = (A68_ALIGN_T) (s);\ while (_m_k > 0) {*_m_u++ = _m_v; _m_k -= A68_ALIGNMENT;}} #define ABEND(p, reason, info) {\ if (p) {\ abend ((char *) reason, (char *) info, __FILE__, __LINE__);\ }} #if defined HAVE_CURSES #define ASSERT(f) {\ if (!(f)) {\ if (a68g_curses_mode == A68_TRUE) {\ (void) attrset (A_NORMAL);\ (void) endwin ();\ a68g_curses_mode = A68_FALSE;\ }\ ABEND(A68_TRUE, "Return value failure", error_specification ())\ }} #else #define ASSERT(f) {\ ABEND((!(f)), "Return value failure", error_specification ())\ } #endif /* Some macros to overcome the ambiguity in having signed or unsigned char on various systems. PDP-11s and IBM 370s are still haunting us with this. */ #define IS_ALNUM(c) isalnum ((unsigned char) (c)) #define IS_ALPHA(c) isalpha ((unsigned char) (c)) #define IS_CNTRL(c) iscntrl ((unsigned char) (c)) #define IS_DIGIT(c) isdigit ((unsigned char) (c)) #define IS_GRAPH(c) isgraph ((unsigned char) (c)) #define IS_LOWER(c) islower ((unsigned char) (c)) #define IS_PRINT(c) isprint ((unsigned char) (c)) #define IS_PUNCT(c) ispunct ((unsigned char) (c)) #define IS_SPACE(c) isspace ((unsigned char) (c)) #define IS_UPPER(c) isupper ((unsigned char) (c)) #define IS_XDIGIT(c) isxdigit ((unsigned char) (c)) #define TO_LOWER(c) (char) tolower ((unsigned char) (c)) #define TO_UCHAR(c) ((c) >= 0 ? (int) (c) : (int) (UCHAR_MAX + (int) (c) + 1)) #define TO_UPPER(c) (char) toupper ((unsigned char) (c)) /* Macro's for fat A68 pointers */ #define ADDRESS(z) (&((IS_IN_HEAP (z) ? REF_POINTER (z) : stack_segment)[REF_OFFSET (z)])) #define ARRAY_ADDRESS(z) (&(REF_POINTER (z)[REF_OFFSET (z)])) #define DEREF(mode, expr) ((mode *) ADDRESS (expr)) #define FILE_DEREF(p) DEREF (A68_FILE, (p)) #define HEAP_ADDRESS(n) ((BYTE_T *) & (heap_segment[n])) #define IS_IN_FRAME(z) (STATUS (z) & IN_FRAME_MASK) #define IS_IN_HEAP(z) (STATUS (z) & IN_HEAP_MASK) #define IS_IN_STACK(z) (STATUS (z) & IN_STACK_MASK) #define IS_NIL(p) ((BOOL_T) ((STATUS (&(p)) & NIL_MASK) != 0)) #define LOCAL_ADDRESS(z) (& stack_segment[REF_OFFSET (z)]) #define REF_HANDLE(z) (HANDLE (z)) #define REF_OFFSET(z) (OFFSET (z)) #define REF_POINTER(z) (POINTER (REF_HANDLE (z))) #define REF_SCOPE(z) (SCOPE (z)) #define STACK_ADDRESS(n) ((BYTE_T *) &(stack_segment[(n)])) #define STACK_OFFSET(n) (STACK_ADDRESS (stack_pointer + (int) (n))) #define STACK_TOP (STACK_ADDRESS (stack_pointer)) /* Miscellaneous macros */ #define A68_REF_SIZE (ALIGNED_SIZE_OF (A68_REF)) #define A68_UNION_SIZE (ALIGNED_SIZE_OF (A68_UNION)) #define A68_ALIGN(s) ((int) ((s) % A68_ALIGNMENT) == 0 ? (s) : ((s) - (s) % A68_ALIGNMENT + A68_ALIGNMENT)) #define A68_ALIGNMENT ((int) (sizeof (A68_ALIGN_T))) #define A68_ALIGN_8(s) ((int) ((s) % 8) == 0 ? (s) : ((s) - (s) % 8 + 8)) #define A68_SOUND_BYTES(s) ((int) (BITS_PER_SAMPLE (s)) / 8 + (int) (BITS_PER_SAMPLE (s) % 8 == 0 ? 0 : 1)) #define A68_SOUND_DATA_SIZE(s) ((int) (NUM_SAMPLES (s)) * (int) (NUM_CHANNELS (s)) * (int) (A68_SOUND_BYTES (s))) #define ABS(n) ((n) >= 0 ? (n) : -(n)) #define ALIGNED_SIZE_OF(p) ((int) A68_ALIGN (sizeof (p))) #define BACKWARD(p) (p = PREVIOUS (p)) #define BITS_WIDTH ((int) (1 + ceil (log ((double) A68_MAX_INT) / log((double) 2)))) #define DEFLEX(p) (DEFLEXED (p) != NO_MOID ? DEFLEXED(p) : (p)) #define EXP_WIDTH ((int) (1 + log10 ((double) DBL_MAX_10_EXP))) #define FORWARD(p) ((p) = NEXT (p)) #define INT_WIDTH ((int) (1 + floor (log ((double) A68_MAX_INT) / log ((double) 10)))) #define LONGLONG_INT_WIDTH (1 + LONGLONG_WIDTH) #define LONGLONG_REAL_WIDTH ((varying_mp_digits - 1) * LOG_MP_BASE) #define LONGLONG_WIDTH (varying_mp_digits * LOG_MP_BASE) #define LONG_INT_WIDTH (1 + LONG_WIDTH) #define LONG_REAL_WIDTH ((LONG_MP_DIGITS - 1) * LOG_MP_BASE) #define LONG_WIDTH (LONG_MP_DIGITS * LOG_MP_BASE) #define MP_BITS_WIDTH(k) ((int) ceil((k) * LOG_MP_BASE * LOG2_10) - 1) #define MP_BITS_WORDS(k) ((int) ceil ((double) MP_BITS_WIDTH (k) / (double) MP_BITS_BITS)) #define PM(m) (moid_to_string (m, 132, NO_NODE)) #define SIGN(n) ((n) == 0 ? 0 : ((n) > 0 ? 1 : -1)) #define STATUS_CLEAR(p, q) {STATUS (p) &= (~(q));} #define STATUS_SET(p, q) {STATUS (p) |= (q);} #define STATUS_TEST(p, q) ((STATUS (p) & (q)) != (unsigned) 0) #define WIS(p) where_in_source (STDOUT_FILENO, (p)) #define WRITE(f, s) io_write_string ((f), (s)); #define WRITELN(f, s) {io_close_tty_line (); WRITE ((f), (s));} /* Access macros */ #define A(p) ((p)->a) #define A68G_STANDENV_PROC(p) ((p)->a68g_standenv_proc) #define ACTION(p) ((p)->action) #define ACTIVE(p) ((p)->active) #define ADDR(p) ((p)->addr) #define ALTS(p) ((p)->alts) #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 BL_END(p) ((p)->bl_end) #define BL_START(p) ((p)->bl_start) #define BODY(p) ((p)->body) #define BSTATE(p) ((p)->bstate) #define BYTES(p) ((p)->bytes) #define C(p) ((p)->c) #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 COL(p) ((p)->col) #define COL0(p) ((p)->col0) #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 CURR(p) ((p)->curr) #define CURS(p) ((p)->curs) #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 DIM(p) ((p)->dim) #define DISPLAY(p) ((p)->display) #define DL(p) ((p)->dl) #define DL0(p) ((p)->dl0) #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 EDIT_EXIT_LABEL(p) ((p)->edit_exit_label) #define ELEM_SIZE(p) ((p)->elem_size) #define END(p) ((p)->end) #define END_OF_FILE(p) ((p)->end_of_file) #define ENVIRON(p) ((p)->environ) #define EQUIVALENT(p) ((p)->equivalent_mode) #define EQUIVALENT_MODE(p) ((p)->equivalent_mode) #define ERROR_COUNT(p) ((p)->error_count) #define RENDEZ_VOUS(p) ((p)->rendez_vous) #define EXPR(p) ((p)->expr) #define F(p) ((p)->f) #define FACTOR(p) ((p)->factor) #define FD(p) ((p)->fd) #define FIELD_OFFSET(p) ((p)->field_offset) #define FILENAME(p) ((p)->filename) #define FILES(p) ((p)->files) #define FILE_BINARY_NAME(p) (FILES (p).binary.name) #define FILE_BINARY_OPENED(p) (FILES (p).binary.opened) #define FILE_BINARY_WRITEMOOD(p) (FILES (p).binary.writemood) #define FILE_DIAGS_FD(p) (FILES (p).diags.fd) #define FILE_DIAGS_NAME(p) (FILES (p).diags.name) #define FILE_DIAGS_OPENED(p) (FILES (p).diags.opened) #define FILE_DIAGS_WRITEMOOD(p) (FILES (p).diags.writemood) #define FILE_END_MENDED(p) ((p)->file_end_mended) #define FILE_ENTRY(p) ((p)->file_entry) #define FILE_GENERIC_NAME(p) (FILES (p).generic_name) #define FILE_INITIAL_NAME(p) (FILES (p).initial_name) #define FILE_LIBRARY_NAME(p) (FILES (p).library.name) #define FILE_LIBRARY_OPENED(p) (FILES (p).library.opened) #define FILE_LIBRARY_WRITEMOOD(p) (FILES (p).library.writemood) #define FILE_LISTING_FD(p) (FILES (p).listing.fd) #define FILE_LISTING_NAME(p) (FILES (p).listing.name) #define FILE_LISTING_OPENED(p) (FILES (p).listing.opened) #define FILE_LISTING_WRITEMOOD(p) (FILES (p).listing.writemood) #define FILE_OBJECT_FD(p) (FILES (p).object.fd) #define FILE_OBJECT_NAME(p) (FILES (p).object.name) #define FILE_OBJECT_OPENED(p) (FILES (p).object.opened) #define FILE_OBJECT_WRITEMOOD(p) (FILES (p).object.writemood) #define FILE_PATH(p) (FILES (p).path) #define FILE_PRETTY_FD(p) (FILES (p).pretty.fd) #define FILE_PRETTY_NAME(p) (FILES (p).pretty.name) #define FILE_PRETTY_OPENED(p) (FILES (p).pretty.opened) #define FILE_PRETTY_WRITEMOOD(p) (FILES (p).pretty.writemood) #define FILE_SCRIPT_NAME(p) (FILES (p).script.name) #define FILE_SCRIPT_OPENED(p) (FILES (p).script.opened) #define FILE_SCRIPT_WRITEMOOD(p) (FILES (p).script.writemood) #define FILE_SOURCE_FD(p) (FILES (p).source.fd) #define FILE_SOURCE_NAME(p) (FILES (p).source.name) #define FILE_SOURCE_OPENED(p) (FILES (p).source.opened) #define FILE_SOURCE_WRITEMOOD(p) (FILES (p).source.writemood) #define FIND(p) ((p)->find) #define FORMAT(p) ((p)->format) #define FORMAT_END_MENDED(p) ((p)->format_end_mended) #define FORMAT_ERROR_MENDED(p) ((p)->format_error_mended) #define FRAME(p) ((p)->frame) #define FRAME_LEVEL(p) ((p)->frame_level) #define FRAME_NO(p) ((p)->frame_no) #define FRAME_POINTER(p) ((p)->frame_pointer) #define FUNCTION(p) ((p)->function) #define G(p) ((p)->g) #define GINFO(p) ((p)->genie) #define GET(p) ((p)->get) #define GLOBAL_PROP(p) ((p)->global_prop) #define GPARENT(p) (PARENT (GINFO (p))) #define GREEN(p) ((p)->green) #define H(p) ((p)->h) #define HANDLE(p) ((p)->handle) #define HAS_ROWS(p) ((p)->has_rows) #define HEAP(p) ((p)->heap) #define HEAP_POINTER(p) ((p)->heap_pointer) #define H_ADDR(p) ((p)->h_addr) #define H_LENGTH(p) ((p)->h_length) #define ID(p) ((p)->id) #define IDENTIFICATION(p) ((p)->identification) #define IDENTIFIERS(p) ((p)->identifiers) #define IDF(p) ((p)->idf) #define IM(z) (VALUE (&(z)[1])) #define IN(p) ((p)->in) #define INDEX(p) ((p)->index) #define INDICANTS(p) ((p)->indicants) #define INFO(p) ((p)->info) #define INITIALISE_ANON(p) ((p)->initialise_anon) #define INITIALISE_FRAME(p) ((p)->initialise_frame) #define INI_PTR(p) ((p)->ini_ptr) #define INS_MODE(p) ((p)->ins_mode) #define IN_CMD(p) ((p)->in_cmd) #define IN_FORBIDDEN(p) ((p)->in_forbidden) #define IN_PREFIX(p) ((p)->in_prefix) #define IN_PROC(p) ((p)->in_proc) #define IN_TEXT(p) ((p)->in_text) #define IS_COMPILED(p) ((p)->is_compiled) #define IS_OPEN(p) ((p)->is_open) #define IS_TMP(p) ((p)->is_tmp) #define JUMP_STAT(p) ((p)->jump_stat) #define JUMP_TO(p) ((p)->jump_to) #define K(q) ((q)->k) #define LABELS(p) ((p)->labels) #define LAST(p) ((p)->last) #define LAST_LINE(p) ((p)->last_line) #define LESS(p) ((p)->less) #define LEVEL(p) ((p)->level) #define LEX_LEVEL(p) (LEVEL (TABLE (p))) #define LINBUF(p) ((p)->linbuf) #define LINE(p) ((p)->line) #define LINE_APPLIED(p) ((p)->line_applied) #define LINE_DEFINED(p) ((p)->line_defined) #define LINE_END_MENDED(p) ((p)->line_end_mended) #define LINE_NUMBER(p) (NUMBER (LINE (INFO (p)))) #define LINSIZ(p) ((p)->linsiz) #define LIST(p) ((p)->list) #define LOCALE(p) ((p)->locale) #define LOC_ASSIGNED(p) ((p)->loc_assigned) #define LOWER_BOUND(p) ((p)->lower_bound) #define LWB(p) ((p)->lower_bound) #define MARKER(p) ((p)->marker) #define MATCH(p) ((p)->match) #define MODE(p) (a68_modes.p) #define MODIFIED(p) ((p)->modified) #define MOID(p) ((p)->type) #define MOID_SIZE(p) A68_ALIGN ((p)->size) #define MORE(p) ((p)->more) #define MSGS(p) ((p)->msgs) #define MULTIPLE(p) ((p)->multiple_mode) #define MULTIPLE_MODE(p) ((p)->multiple_mode) #define M_EO(p) ((p)->m_eo) #define M_MATCH(p) ((p)->match) #define M_SO(p) ((p)->m_so) #define NAME(p) ((p)->name) #define NEED_DNS(p) ((p)->need_dns) #define NEGATE(p) ((p)->negate) #define NEST(p) ((p)->nest) #define NEW_FILE(p) ((p)->new_file) #define NEXT(p) ((p)->next) #define NEXT_NEXT(p) (NEXT (NEXT (p))) #define NEXT_NEXT_NEXT(p) (NEXT (NEXT_NEXT (p))) #define NEXT_SUB(p) (NEXT (SUB (p))) #define NF(p) ((p)->nf) #define NODE(p) ((p)->node) #define NODE_DEFINED(p) ((p)->node_defined) #define NODE_PACK(p) ((p)->pack) #define NON_LOCAL(p) ((p)->non_local) #define NCHAR_IN_LINE(p) (CHAR_IN_LINE (INFO (p))) #define NPRAGMENT(p) (PRAGMENT (INFO (p))) #define NPRAGMENT_TYPE(p) (PRAGMENT_TYPE (INFO (p))) #define NSYMBOL(p) (SYMBOL (INFO (p))) #define NUM(p) ((p)->num) #define NUMBER(p) ((p)->number) #define NUM_CHANNELS(p) ((p)->num_channels) #define NUM_MATCH(p) ((p)->num_match) #define NUM_SAMPLES(p) ((p)->num_samples) #define OFFSET(p) ((p)->offset) #define OPENED(p) ((p)->opened) #define OPEN_ERROR_MENDED(p) ((p)->open_error_mended) #define OPEN_EXCLUSIVE(p) ((p)->open_exclusive) #define OPER(p) ((p)->oper) #define OPERATORS(p) ((p)->operators) #define OPTIONS(p) ((p)->options) #define OPTION_BACKTRACE(p) (OPTIONS (p).backtrace) #define OPTION_BRACKETS(p) (OPTIONS (p).brackets) #define OPTION_CHECK_ONLY(p) (OPTIONS (p).check_only) #define OPTION_CLOCK(p) (OPTIONS (p).clock) #define OPTION_COMPILE(p) (OPTIONS (p).compile) #define OPTION_CROSS_REFERENCE(p) (OPTIONS (p).cross_reference) #define OPTION_DEBUG(p) (OPTIONS (p).debug) #define OPTION_EDIT(p) (OPTIONS (p).edit) #define OPTION_FOLD(p) (OPTIONS (p).fold) #define OPTION_INDENT(p) (OPTIONS (p).indent) #define OPTION_KEEP(p) (OPTIONS (p).keep) #define OPTION_LIST(p) (OPTIONS (p).list) #define OPTION_LOCAL(p) (OPTIONS (p).local) #define OPTION_MOID_LISTING(p) (OPTIONS (p).moid_listing) #define OPTION_NODEMASK(p) (OPTIONS (p).nodemask) #define OPTION_NO_WARNINGS(p) (OPTIONS (p).no_warnings) #define OPTION_OBJECT_LISTING(p) (OPTIONS (p).object_listing) #define OPTION_OPTIMISE(p) (OPTIONS (p).optimise) #define OPTION_OPT_LEVEL(p) (OPTIONS (p).opt_level) #define OPTION_PORTCHECK(p) (OPTIONS (p).portcheck) #define OPTION_PRAGMAT_SEMA(p) (OPTIONS (p).pragmat_sema) #define OPTION_PRETTY(p) (OPTIONS (p).pretty) #define OPTION_QUIET(p) (OPTIONS (p).quiet) #define OPTION_REDUCTIONS(p) (OPTIONS (p).reductions) #define OPTION_REGRESSION_TEST(p) (OPTIONS (p).regression_test) #define OPTION_RERUN(p) (OPTIONS (p).rerun) #define OPTION_RUN(p) (OPTIONS (p).run) #define OPTION_RUN_SCRIPT(p) (OPTIONS (p).run_script) #define OPTION_SOURCE_LISTING(p) (OPTIONS (p).source_listing) #define OPTION_STANDARD_PRELUDE_LISTING(p) (OPTIONS (p).standard_prelude_listing) #define OPTION_STATISTICS_LISTING(p) (OPTIONS (p).statistics_listing) #define OPTION_STRICT(p) (OPTIONS (p).strict) #define OPTION_STROPPING(p) (OPTIONS (p).stropping) #define OPTION_TARGET(p) (OPTIONS (p).target) #define OPTION_TIME_LIMIT(p) (OPTIONS (p).time_limit) #define OPTION_TRACE(p) (OPTIONS (p).trace) #define OPTION_TREE_LISTING(p) (OPTIONS (p).tree_listing) #define OPTION_UNUSED(p) (OPTIONS (p).unused) #define OPTION_VERBOSE(p) (OPTIONS (p).verbose) #define OPTION_VERSION(p) (OPTIONS (p).version) #define OUT(p) ((p)->out) #define OUTER(p) ((p)->outer) #define P(q) ((q)->p) #define PACK(p) ((p)->pack) #define PAGE_END_MENDED(p) ((p)->page_end_mended) #define A68_PAGE_SIZE(p) ((p)->page_size) #define PARAMETERS(p) ((p)->parameters) #define PARAMETER_LEVEL(p) ((p)->parameter_level) #define GSL_PARAMS(p) ((p)->params) #define PARENT(p) ((p)->parent) #define PARTIAL_LOCALE(p) ((p)->partial_locale) #define PARTIAL_PROC(p) ((p)->partial_proc) #define PAR_LEVEL(p) ((p)->par_level) #define PATTERN(p) ((p)->pattern) #define PERM(p) ((p)->perm) #define PERMS(p) ((p)->perms) #define IDF_ROW(p) ((p)->idf_row) #define PHASE(p) ((p)->phase) #define PLOTTER(p) ((p)->plotter) #define PLOTTER_PARAMS(p) ((p)->plotter_params) #define POINTER(p) ((p)->pointer) #define PORTABLE(p) ((p)->portable) #define POS(p) ((p)->pos) #define PRAGMENT(p) ((p)->pragment) #define PRAGMENT_TYPE(p) ((p)->pragment_type) #define PRECMD(p) ((p)->precmd) #define PREVIOUS(p) ((p)->previous) #define PRINT_STATUS(p) ((p)->print_status) #define PRIO(p) ((p)->priority) #define PROCEDURE(p) ((p)->procedure) #define PROCEDURE_LEVEL(p) ((p)->procedure_level) #define PROCESSED(p) ((p)->processed) #define PROC_FRAME(p) ((p)->proc_frame) #define PROC_OPS(p) ((p)->proc_ops) #define GPROP(p) (GINFO (p)->propagator) #define PROP(p) ((p)->propagator) #define PS(p) ((p)->ps) #define PUT(p) ((p)->put) #define P_PROTO(p) ((p)->p_proto) #define R(p) ((p)->r) #define RE(z) (VALUE (&(z)[0])) #define READ_MOOD(p) ((p)->read_mood) #define RED(p) ((p)->red) #define REPL(p) ((p)->repl) #define RESERVED(p) ((p)->reserved) #define RESET(p) ((p)->reset) #define RESET_ERRNO {errno = 0;} #define RESULT(p) ((p)->result) #define RE_NSUB(p) ((p)->re_nsub) #define RLIM_CUR(p) ((p)->rlim_cur) #define RLIM_MAX(p) ((p)->rlim_max) #define RM_EO(p) ((p)->rm_eo) #define RM_SO(p) ((p)->rm_so) #define ROW(p) ((p)->row) #define ROW0(p) ((p)->row0) #define ROWED(p) ((p)->rowed) #define S(p) ((p)->s) #define SAMPLE_RATE(p) ((p)->sample_rate) #define SCAN_STATE_C(p) ((p)->scan_state.save_c) #define SCAN_STATE_L(p) ((p)->scan_state.save_l) #define SCAN_STATE_S(p) ((p)->scan_state.save_s) #define SCALE_ROW(p) ((p)->scale_row) #define SCAN(p) ((p)->scan) #define SCAN_ERROR(c, u, v, txt) if (c) {scan_error (u, v, txt);} #define SCOPE(p) ((p)->scope) #define SCOPE_ASSIGNED(p) ((p)->scope_assigned) #define SEARCH(p) ((p)->search) #define SELECT(p) ((p)->select) #define SEQUENCE(p) ((p)->sequence) #define SET(p) ((p)->set) #define SHIFT(p) ((p)->shift) #define SHORT_ID(p) ((p)->short_id) #define SIN_ADDR(p) ((p)->sin_addr) #define SIN_FAMILY(p) ((p)->sin_family) #define SIN_PORT(p) ((p)->sin_port) #define SIZE(p) ((p)->size) #define SIZE1(p) ((p)->size1) #define SIZE2(p) ((p)->size2) #define 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 TARG(p) ((p)->targ) #define TARG1(p) ((p)->targ1) #define TARG2(p) ((p)->targ2) #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 (ALIGNED_SIZE_OF (A68_UNION)) #define UNIT(p) ((p)->unit) #define UPB(p) ((p)->upper_bound) #define UPPER_BOUND(p) ((p)->upper_bound) #define USE(p) ((p)->use) #define VAL(p) ((p)->val) #define VALUE(p) ((p)->value) #define VALUE_ERROR_MENDED(p) ((p)->value_error_mended) #define WARNING_COUNT(p) ((p)->warning_count) #define WHERE(p) ((p)->where) #define IS(p, s) (ATTRIBUTE (p) == (s)) #define IS_COERCION(p) ((p)->is_coercion) #define IS_LITERALLY(p, s) (strcmp (NSYMBOL (p), s) == 0) #define IS_NEW_LEXICAL_LEVEL(p) ((p)->is_new_lexical_level) #define ISNT(p, s) (! IS (p, s)) #define IS_REF_FLEX(m)\ (IS (m, REF_SYMBOL) && IS (SUB (m), FLEX_SYMBOL)) #define WINDOW_X_SIZE(p) ((p)->window_x_size) #define WINDOW_Y_SIZE(p) ((p)->window_y_size) #define WRITE_MOOD(p) ((p)->write_mood) #define X(p) ((p)->x) #define X_COORD(p) ((p)->x_coord) #define Y(p) ((p)->y) #define YOUNGEST_ENVIRON(p) ((p)->youngest_environ) #define Y_COORD(p) ((p)->y_coord) /***********************************/ /* Interpreter related definitions */ /***********************************/ /* Prelude errors can also occur in the constant folder */ #define PRELUDE_ERROR(cond, p, txt, add)\ if (cond) {\ errno = ERANGE;\ if (in_execution) {\ diagnostic_node (A68_RUNTIME_ERROR, p, txt, add);\ exit_genie (p, A68_RUNTIME_ERROR);\ } else {\ diagnostic_node (A68_MATH_ERROR, p, txt, add);\ }} /* Check on a NIL name */ #define CHECK_REF(p, z, m)\ if (! INITIALISED (&z)) {\ diagnostic_node (A68_RUNTIME_ERROR, (p), ERROR_EMPTY_VALUE_FROM, (m));\ exit_genie ((p), A68_RUNTIME_ERROR);\ } else if (IS_NIL (z)) {\ diagnostic_node (A68_RUNTIME_ERROR, (p), ERROR_ACCESSING_NIL, (m));\ exit_genie ((p), A68_RUNTIME_ERROR);\ } /***************************/ /* Macros for row-handling */ /***************************/ #define GET_DESCRIPTOR(a, t, p)\ a = (A68_ARRAY *) ARRAY_ADDRESS (p);\ t = (A68_TUPLE *) & (((BYTE_T *) (a)) [ALIGNED_SIZE_OF (A68_ARRAY)]); #define GET_DESCRIPTOR2(a, t1, t2, p)\ a = (A68_ARRAY *) ARRAY_ADDRESS (p);\ t1 = (A68_TUPLE *) & (((BYTE_T *) (a)) [ALIGNED_SIZE_OF (A68_ARRAY)]);\ t2 = (A68_TUPLE *) & (((BYTE_T *) (a)) [ALIGNED_SIZE_OF (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)) [ALIGNED_SIZE_OF (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)) [ALIGNED_SIZE_OF (A68_ARRAY)]) = (t1);\ *(A68_TUPLE *) &(((BYTE_T *) (a_p)) [ALIGNED_SIZE_OF (A68_ARRAY) + sizeof (A68_TUPLE)]) = (t2);\ } #define ROW_SIZE(t) ((UPB (t) >= LWB (t)) ? (UPB (t) - LWB (t) + 1) : 0) #define ROW_ELEMENT(a, k) (((ADDR_T) k + SLICE_OFFSET (a)) * ELEM_SIZE (a) + FIELD_OFFSET (a)) #define INDEX_1_DIM(a, t, k) ROW_ELEMENT (a, (SPAN (t) * (int) k - SHIFT (t))) /*************/ /* Execution */ /*************/ #define EXECUTE_UNIT_2(p, dest) {\ PROP_T *_prop_ = &GPROP (p);\ last_unit = p;\ dest = (*(UNIT (_prop_))) (SOURCE (_prop_));} #define EXECUTE_UNIT(p) {\ PROP_T *_prop_ = &GPROP (p);\ last_unit = p;\ (void) (*(UNIT (_prop_))) (SOURCE (_prop_));} #define EXECUTE_UNIT_TRACE(p) {\ if (STATUS_TEST (p, (BREAKPOINT_MASK | BREAKPOINT_TEMPORARY_MASK | \ BREAKPOINT_INTERRUPT_MASK | BREAKPOINT_WATCH_MASK | BREAKPOINT_TRACE_MASK))) {\ single_step ((p), STATUS (p));\ }\ EXECUTE_UNIT (p);} /***********************************/ /* Stuff for the garbage collector */ /***********************************/ /* Check whether the heap fills */ #define PREEMPTIVE_GC {\ double f = (double) heap_pointer / (double) heap_size;\ double h = (double) free_handle_count / (double) max_handle_count;\ if ((f > 0.8 || h < 0.2) && stack_pointer == stack_start) {\ gc_heap ((NODE_T *) p, frame_pointer);\ }} /* Save a handle from the GC */ #define BLOCK_GC_HANDLE(z) {\ if (IS_IN_HEAP (z)) {\ STATUS_SET (REF_HANDLE(z), BLOCK_GC_MASK);\ }} #define UNBLOCK_GC_HANDLE(z) {\ if (IS_IN_HEAP (z)) {\ STATUS_CLEAR (REF_HANDLE (z), BLOCK_GC_MASK);\ }} /* Tests for objects of mode INT */ #if defined HAVE_IEEE_754 #define CHECK_INT_ADDITION(p, i, j)\ PRELUDE_ERROR (ABS ((double) (i) + (double) (j)) > (double) INT_MAX, p, ERROR_MATH, MODE (INT)) #define CHECK_INT_SUBTRACTION(p, i, j)\ PRELUDE_ERROR (ABS ((double) (i) - (double) (j)) > (double) INT_MAX, p, ERROR_MATH, MODE (INT)) #define CHECK_INT_MULTIPLICATION(p, i, j)\ PRELUDE_ERROR (ABS ((double) (i) * (double) (j)) > (double) INT_MAX, p, ERROR_MATH, MODE (INT)) #define CHECK_INT_DIVISION(p, i, j)\ PRELUDE_ERROR ((j) == 0, p, ERROR_DIVISION_BY_ZERO, MODE (INT)) #else #define CHECK_INT_ADDITION(p, i, j) {;} #define CHECK_INT_SUBTRACTION(p, i, j) {;} #define CHECK_INT_MULTIPLICATION(p, i, j) {;} #define CHECK_INT_DIVISION(p, i, j) {;} #endif #define CHECK_INDEX(p, k, t) {\ if (VALUE (k) < LWB (t) || VALUE (k) > UPB (t)) {\ diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_INDEX_OUT_OF_BOUNDS);\ exit_genie (p, A68_RUNTIME_ERROR);\ }} /* Tests for objects of mode REAL */ #if defined HAVE_IEEE_754 #define NOT_A_REAL(x) (!finite (x)) #define CHECK_REAL_REPRESENTATION(p, u) PRELUDE_ERROR (NOT_A_REAL (u), p, ERROR_MATH, MODE (REAL)) #define CHECK_REAL_ADDITION(p, u, v) CHECK_REAL_REPRESENTATION (p, (u) + (v)) #define CHECK_REAL_SUBTRACTION(p, u, v) CHECK_REAL_REPRESENTATION (p, (u) - (v)) #define CHECK_REAL_MULTIPLICATION(p, u, v) CHECK_REAL_REPRESENTATION (p, (u) * (v)) #define CHECK_REAL_DIVISION(p, u, v)\ PRELUDE_ERROR ((v) == 0, p, ERROR_DIVISION_BY_ZERO, MODE (REAL)) #define CHECK_COMPLEX_REPRESENTATION(p, u, v)\ PRELUDE_ERROR (NOT_A_REAL (u) || NOT_A_REAL (v), p, ERROR_MATH, MODE (COMPLEX)) #else #define CHECK_REAL_REPRESENTATION(p, u) {;} #define CHECK_REAL_ADDITION(p, u, v) {;} #define CHECK_REAL_SUBTRACTION(p, u, v) {;} #define CHECK_REAL_MULTIPLICATION(p, u, v) {;} #define CHECK_REAL_DIVISION(p, u, v) {;} #define CHECK_COMPLEX_REPRESENTATION(p, u, v) {;} #endif #define MATH_RTE(p, z, m, t)\ PRELUDE_ERROR (z, (p), (t == NO_TEXT ? ERROR_MATH : t), (m)) /* Macro's for stack checking. Since the stacks grow by small amounts at a time (A68 rows are in the heap), we check the stacks only at certain points: where A68 recursion may set in, or in the garbage collector. We check whether there still is sufficient overhead to make it to the next check. */ #define TOO_COMPLEX "program too complex" #define SYSTEM_STACK_USED (ABS ((int) (system_stack_offset - &stack_offset))) #define LOW_SYSTEM_STACK_ALERT(p) {\ BYTE_T stack_offset;\ if (stack_size > 0 && SYSTEM_STACK_USED >= stack_limit) {\ errno = 0;\ if ((p) == NO_NODE) {\ ABEND (A68_TRUE, TOO_COMPLEX, ERROR_STACK_OVERFLOW);\ } else {\ diagnostic_node (A68_RUNTIME_ERROR, (p), ERROR_STACK_OVERFLOW);\ exit_genie ((p), A68_RUNTIME_ERROR);\ }}} #define LOW_STACK_ALERT(p) {\ LOW_SYSTEM_STACK_ALERT (p);\ if ((p) != NO_NODE && (frame_pointer >= frame_stack_limit || stack_pointer >= expr_stack_limit)) { \ errno = 0;\ diagnostic_node (A68_RUNTIME_ERROR, (p), ERROR_STACK_OVERFLOW);\ exit_genie ((p), A68_RUNTIME_ERROR);\ }} /******************************/ /* Operations on stack frames */ /******************************/ #define FRAME_ADDRESS(n) ((BYTE_T *) &(stack_segment[n])) #define FACT(n) ((ACTIVATION_RECORD *) FRAME_ADDRESS (n)) #define FRAME_CLEAR(m) FILL ((BYTE_T *) FRAME_OFFSET (FRAME_INFO_SIZE), 0, (m)) #define FRAME_BLOCKS(n) (BLOCKS (FACT (n))) #define FRAME_DYNAMIC_LINK(n) (DYNAMIC_LINK (FACT (n))) #define FRAME_DNS(n) (DYNAMIC_SCOPE (FACT (n))) #define FRAME_INCREMENT(n) (AP_INCREMENT (TABLE (FRAME_TREE(n)))) #define FRAME_INFO_SIZE (A68_ALIGN_8 ((int) sizeof (ACTIVATION_RECORD))) #define FRAME_JUMP_STAT(n) (JUMP_STAT (FACT (n))) #define FRAME_LEXICAL_LEVEL(n) (FRAME_LEVEL (FACT (n))) #define FRAME_LOCAL(n, m) (FRAME_ADDRESS ((n) + FRAME_INFO_SIZE + (m))) #define FRAME_NUMBER(n) (FRAME_NO (FACT (n))) #define FRAME_OBJECT(n) (FRAME_OFFSET (FRAME_INFO_SIZE + (n))) #define FRAME_OFFSET(n) (FRAME_ADDRESS (frame_pointer + (n))) #define FRAME_PARAMETER_LEVEL(n) (PARAMETER_LEVEL (FACT (n))) #define FRAME_PARAMETERS(n) (PARAMETERS (FACT (n))) #define FRAME_PROC_FRAME(n) (PROC_FRAME (FACT (n))) #define FRAME_SIZE(fp) (FRAME_INFO_SIZE + FRAME_INCREMENT (fp)) #define FRAME_STATIC_LINK(n) (STATIC_LINK (FACT (n))) #define FRAME_TREE(n) (NODE (FACT (n))) #if defined HAVE_PARALLEL_CLAUSE #define FRAME_THREAD_ID(n) (THREAD_ID (FACT (n))) #endif #define FOLLOW_SL(dest, l) {\ (dest) = frame_pointer;\ if ((l) <= FRAME_PARAMETER_LEVEL ((dest))) {\ (dest) = FRAME_PARAMETERS ((dest));\ }\ while ((l) != FRAME_LEXICAL_LEVEL ((dest))) {\ (dest) = FRAME_STATIC_LINK ((dest));\ }} #define FOLLOW_STATIC_LINK(dest, l) {\ if ((l) == global_level && global_pointer > 0) {\ (dest) = global_pointer;\ } else {\ FOLLOW_SL (dest, l)\ }} #define FRAME_GET(dest, cast, p) {\ ADDR_T _m_z;\ FOLLOW_STATIC_LINK (_m_z, LEVEL (GINFO (p)));\ (dest) = (cast *) & (OFFSET (GINFO (p))[_m_z]);\ } #define GET_FRAME(dest, cast, level, offset) {\ ADDR_T _m_z;\ FOLLOW_SL (_m_z, (level));\ (dest) = (cast *) & (stack_segment [_m_z + FRAME_INFO_SIZE + (offset)]);\ } #define GET_GLOBAL(dest, cast, offset) {\ (dest) = (cast *) & (stack_segment [global_pointer + FRAME_INFO_SIZE + (offset)]);\ } /* Opening of stack frames is in-line */ /* STATIC_LINK_FOR_FRAME: determine static link for stack frame. new_lex_lvl: lexical level of new stack frame. returns: static link for stack frame at 'new_lex_lvl'. */ #define STATIC_LINK_FOR_FRAME(dest, new_lex_lvl) {\ int _m_cur_lex_lvl = FRAME_LEXICAL_LEVEL (frame_pointer);\ if (_m_cur_lex_lvl == (new_lex_lvl)) {\ (dest) = FRAME_STATIC_LINK (frame_pointer);\ } else if (_m_cur_lex_lvl > (new_lex_lvl)) {\ ADDR_T _m_static_link = frame_pointer;\ while (FRAME_LEXICAL_LEVEL (_m_static_link) >= (new_lex_lvl)) {\ _m_static_link = FRAME_STATIC_LINK (_m_static_link);\ }\ (dest) = _m_static_link;\ } else {\ (dest) = frame_pointer;\ }} #define INIT_STATIC_FRAME(p) {\ FRAME_CLEAR (AP_INCREMENT (TABLE (p)));\ if (INITIALISE_FRAME (TABLE (p))) {\ initialise_frame (p);\ }} #define INIT_GLOBAL_POINTER(p) {\ if (LEX_LEVEL (p) == global_level) {\ global_pointer = frame_pointer;\ }} #if defined HAVE_PARALLEL_CLAUSE #define OPEN_STATIC_FRAME(p) {\ ADDR_T dynamic_link = frame_pointer, static_link;\ ACTIVATION_RECORD *act, *pre;\ STATIC_LINK_FOR_FRAME (static_link, LEX_LEVEL (p));\ pre = FACT (frame_pointer);\ frame_pointer += FRAME_SIZE (dynamic_link);\ act = FACT (frame_pointer);\ FRAME_NO (act) = FRAME_NO (pre) + 1;\ FRAME_LEVEL (act) = LEX_LEVEL (p);\ PARAMETER_LEVEL (act) = PARAMETER_LEVEL (pre);\ PARAMETERS (act) = PARAMETERS (pre);\ STATIC_LINK (act) = static_link;\ DYNAMIC_LINK (act) = dynamic_link;\ DYNAMIC_SCOPE (act) = frame_pointer;\ NODE (act) = p;\ JUMP_STAT (act) = NO_JMP_BUF;\ PROC_FRAME (act) = A68_FALSE;\ THREAD_ID (act) = pthread_self ();\ } #else #define OPEN_STATIC_FRAME(p) {\ ADDR_T dynamic_link = frame_pointer, static_link;\ ACTIVATION_RECORD *act, *pre;\ STATIC_LINK_FOR_FRAME (static_link, LEX_LEVEL (p));\ pre = FACT (frame_pointer);\ frame_pointer += FRAME_SIZE (dynamic_link);\ act = FACT (frame_pointer);\ FRAME_NO (act) = FRAME_NO (pre) + 1;\ FRAME_LEVEL (act) = LEX_LEVEL (p);\ PARAMETER_LEVEL (act) = PARAMETER_LEVEL (pre);\ PARAMETERS (act) = PARAMETERS (pre);\ STATIC_LINK (act) = static_link;\ DYNAMIC_LINK (act) = dynamic_link;\ DYNAMIC_SCOPE (act) = frame_pointer;\ NODE (act) = p;\ JUMP_STAT (act) = NO_JMP_BUF;\ PROC_FRAME (act) = A68_FALSE;\ } #endif #if defined HAVE_PARALLEL_CLAUSE #define OPEN_PROC_FRAME(p, environ) {\ ADDR_T dynamic_link = frame_pointer, static_link;\ ACTIVATION_RECORD *act;\ LOW_STACK_ALERT (p);\ static_link = (environ > 0 ? environ : frame_pointer);\ if (frame_pointer < static_link) {\ diagnostic_node (A68_RUNTIME_ERROR, (p), ERROR_SCOPE_DYNAMIC_0);\ exit_genie (p, A68_RUNTIME_ERROR);\ }\ frame_pointer += FRAME_SIZE (dynamic_link);\ act = FACT (frame_pointer);\ FRAME_NO (act) = FRAME_NUMBER (dynamic_link) + 1;\ FRAME_LEVEL (act) = LEX_LEVEL (p);\ PARAMETER_LEVEL (act) = LEX_LEVEL (p);\ PARAMETERS (act) = frame_pointer;\ STATIC_LINK (act) = static_link;\ DYNAMIC_LINK (act) = dynamic_link;\ DYNAMIC_SCOPE (act) = frame_pointer;\ NODE (act) = p;\ JUMP_STAT (act) = NO_JMP_BUF;\ PROC_FRAME (act) = A68_TRUE;\ THREAD_ID (act) = pthread_self ();\ } #else #define OPEN_PROC_FRAME(p, environ) {\ ADDR_T dynamic_link = frame_pointer, static_link;\ ACTIVATION_RECORD *act;\ LOW_STACK_ALERT (p);\ static_link = (environ > 0 ? environ : frame_pointer);\ if (frame_pointer < static_link) {\ diagnostic_node (A68_RUNTIME_ERROR, (p), ERROR_SCOPE_DYNAMIC_0);\ exit_genie (p, A68_RUNTIME_ERROR);\ }\ frame_pointer += FRAME_SIZE (dynamic_link);\ act = FACT (frame_pointer);\ FRAME_NO (act) = FRAME_NUMBER (dynamic_link) + 1;\ FRAME_LEVEL (act) = LEX_LEVEL (p);\ PARAMETER_LEVEL (act) = LEX_LEVEL (p);\ PARAMETERS (act) = frame_pointer;\ STATIC_LINK (act) = static_link;\ DYNAMIC_LINK (act) = dynamic_link;\ DYNAMIC_SCOPE (act) = frame_pointer;\ NODE (act) = p;\ JUMP_STAT (act) = NO_JMP_BUF;\ PROC_FRAME (act) = A68_TRUE;\ } #endif #define CLOSE_FRAME {\ ACTIVATION_RECORD *act = FACT (frame_pointer);\ frame_pointer = DYNAMIC_LINK (act);\ } /* Macros for check on initialisation of values */ #define CHECK_INIT(p, c, q)\ if (!(c)) {\ diagnostic_node (A68_RUNTIME_ERROR, (p), ERROR_EMPTY_VALUE_FROM, (q));\ exit_genie ((p), A68_RUNTIME_ERROR);\ } #define CHECK_DNS2(p, scope, limit, mode)\ if (scope > limit) {\ char txt[BUFFER_SIZE];\ ASSERT (snprintf (txt, SNPRINTF_SIZE, ERROR_SCOPE_DYNAMIC_1) >= 0);\ diagnostic_node (A68_RUNTIME_ERROR, p, txt, mode);\ exit_genie (p, A68_RUNTIME_ERROR);\ } #define CHECK_DNS(p, m, w, limit)\ if (NEED_DNS (GINFO (p))) {\ ADDR_T _lim = ((limit) < global_pointer ? global_pointer : (limit));\ if (IS ((m), REF_SYMBOL)) {\ CHECK_DNS2 (p, (REF_SCOPE ((A68_REF *) (w))), _lim, (m));\ } else if (IS ((m), PROC_SYMBOL)) {\ CHECK_DNS2 (p, ENVIRON ((A68_PROCEDURE *) (w)), _lim, (m));\ } else if (IS ((m), FORMAT_SYMBOL)) {\ CHECK_DNS2 (p, ENVIRON ((A68_FORMAT *) w), _lim, (m));\ }} /* The void * cast in next macro is to stop warnings about dropping a volatile qualifier to a pointer. This is safe here. */ #define STACK_DNS(p, m, limit)\ if (p != NO_NODE && GINFO (p) != NO_GINFO) {\ CHECK_DNS ((NODE_T *)(void *)(p), (m),\ (STACK_OFFSET (-MOID_SIZE (m))), (limit));\ } /***********************************/ /* Macros for the evaluation stack */ /***********************************/ #define INCREMENT_STACK_POINTER(err, i)\ {stack_pointer += (ADDR_T) A68_ALIGN (i); (void) (err);} #define DECREMENT_STACK_POINTER(err, i)\ {stack_pointer -= A68_ALIGN (i); (void) (err);} #define PUSH(p, addr, size) {\ BYTE_T *_sp_ = STACK_TOP;\ INCREMENT_STACK_POINTER ((p), (int) (size));\ COPY (_sp_, (BYTE_T *) (addr), (int) (size));\ } #define POP(p, addr, size) {\ DECREMENT_STACK_POINTER((p), (int) (size));\ COPY ((BYTE_T *) (addr), STACK_TOP, (int) (size));\ } #define POP_ALIGNED(p, addr, size) {\ DECREMENT_STACK_POINTER((p), (int) (size));\ COPY_ALIGNED ((BYTE_T *) (addr), STACK_TOP, (int) (size));\ } #define POP_ADDRESS(p, addr, type) {\ DECREMENT_STACK_POINTER((p), (int) ALIGNED_SIZE_OF (type));\ (addr) = (type *) STACK_TOP;\ } #define POP_OPERAND_ADDRESS(p, i, type) {\ (void) (p);\ (i) = (type *) (STACK_OFFSET (-ALIGNED_SIZE_OF (type)));\ } #define POP_OPERAND_ADDRESSES(p, i, j, type) {\ DECREMENT_STACK_POINTER ((p), (int) ALIGNED_SIZE_OF (type));\ (j) = (type *) STACK_TOP;\ (i) = (type *) (STACK_OFFSET (-ALIGNED_SIZE_OF (type)));\ } #define POP_3_OPERAND_ADDRESSES(p, i, j, k, type) {\ DECREMENT_STACK_POINTER ((p), (int) (2 * ALIGNED_SIZE_OF (type)));\ (k) = (type *) (STACK_OFFSET (ALIGNED_SIZE_OF (type)));\ (j) = (type *) STACK_TOP;\ (i) = (type *) (STACK_OFFSET (-ALIGNED_SIZE_OF (type)));\ } #define PUSH_PRIMITIVE(p, z, mode) {\ mode *_x_ = (mode *) STACK_TOP;\ STATUS (_x_) = INIT_MASK;\ VALUE (_x_) = (z);\ INCREMENT_STACK_POINTER ((p), ALIGNED_SIZE_OF (mode));\ } #define PUSH_PRIMAL(p, z, m) {\ A68_##m *_x_ = (A68_##m *) STACK_TOP;\ int _size_ = ALIGNED_SIZE_OF (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, ALIGNED_SIZE_OF (mode));\ } #define POP_OBJECT(p, z, mode) {\ DECREMENT_STACK_POINTER((p), ALIGNED_SIZE_OF (mode));\ (*(z)) = *((mode *) STACK_TOP);\ } #define PUSH_COMPLEX(p, re, im) {\ PUSH_PRIMAL (p, re, REAL);\ PUSH_PRIMAL (p, im, REAL);\ } #define POP_COMPLEX(p, re, im) {\ POP_OBJECT (p, im, A68_REAL);\ POP_OBJECT (p, re, A68_REAL);\ } #define PUSH_BYTES(p, k) {\ A68_BYTES *_z_ = (A68_BYTES *) STACK_TOP;\ STATUS (_z_) = INIT_MASK;\ strncpy (VALUE (_z_), k, BYTES_WIDTH);\ INCREMENT_STACK_POINTER((p), ALIGNED_SIZE_OF (A68_BYTES));\ } #define PUSH_LONG_BYTES(p, k) {\ A68_LONG_BYTES *_z_ = (A68_LONG_BYTES *) STACK_TOP;\ STATUS (_z_) = INIT_MASK;\ strncpy (VALUE (_z_), k, LONG_BYTES_WIDTH);\ INCREMENT_STACK_POINTER((p), ALIGNED_SIZE_OF (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), ALIGNED_SIZE_OF (A68_UNION));\ } /* Macro's for standard environ */ #define A68_ENV_INT(n, k) void n (NODE_T *p) {PUSH_PRIMAL (p, (k), INT);} #define A68_ENV_REAL(n, z) void n (NODE_T *p) {PUSH_PRIMAL (p, (z), REAL);} /* Interpreter macros */ #define INITIALISED(z) ((BOOL_T) (STATUS (z) & INIT_MASK)) #define LHS_MODE(p) (MOID (PACK (MOID (p)))) #define RHS_MODE(p) (MOID (NEXT (PACK (MOID (p))))) /* Transput related macros */ #define IS_NIL_FORMAT(f) ((BOOL_T) (BODY (f) == NO_NODE && ENVIRON (f) == 0)) /* MP Macros */ #define MP_STATUS(z) ((z)[0]) #define MP_EXPONENT(z) ((z)[1]) #define MP_DIGIT(z, n) ((z)[(n) + 1]) #define SIZE_MP(digits) ((2 + digits) * ALIGNED_SIZE_OF (MP_T)) #define IS_ZERO_MP(z) (MP_DIGIT (z, 1) == (MP_T) 0) #define MOVE_MP(z, x, digits) {\ MP_T *_m_d = (z), *_m_s = (x); int _m_k = digits + 2;\ while (_m_k--) {*_m_d++ = *_m_s++;}\ } #define MOVE_DIGITS(z, x, digits) {\ MP_T *_m_d = (z), *_m_s = (x); int _m_k = digits;\ while (_m_k--) {*_m_d++ = *_m_s++;}\ } #define CHECK_MP_EXPONENT(p, z) {\ MP_T _expo_ = fabs (MP_EXPONENT (z));\ if (_expo_ > MAX_MP_EXPONENT || (_expo_ == MAX_MP_EXPONENT && ABS (MP_DIGIT (z, 1)) > 1.0)) {\ errno = ERANGE;\ diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_MP_OUT_OF_BOUNDS, NULL);\ exit_genie (p, A68_RUNTIME_ERROR);\ }} #define SET_MP_ZERO(z, digits) {\ MP_T *_m_d = &MP_DIGIT ((z), 1); int _m_k = digits;\ MP_STATUS (z) = (MP_T) INIT_MASK;\ MP_EXPONENT (z) = 0.0;\ while (_m_k--) {*_m_d++ = 0.0;}\ } /* stack_mp: allocate temporary space in the evaluation stack */ #define STACK_MP(dest, p, digits) {\ ADDR_T stack_mp_sp = stack_pointer;\ if ((stack_pointer += SIZE_MP (digits)) > expr_stack_limit) {\ diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_STACK_OVERFLOW);\ exit_genie (p, A68_RUNTIME_ERROR);\ }\ dest = (MP_T *) STACK_ADDRESS (stack_mp_sp);\ } /******************************/ /* Library for code generator */ /*****************************/ /* Operators that are inlined in compiled code */ #define a68g_eq_complex(/* A68_REAL * */ x, y) (RE (x) == RE (y) && IM (x) == IM (y)) #define a68g_ne_complex(/* A68_REAL * */ x, y) (! a68g_eq_complex (x, y)) #define a68g_mod_int(/* int */ i, j) (((i) % (j)) >= 0 ? ((i) % (j)) : ((i) % (j)) + labs (j)) #define a68g_plusab_int(/* A68_REF * */ i, /* int */ j) (VALUE ((A68_INT *) ADDRESS (i)) += (j), (i)) #define a68g_minusab_int(/* A68_REF * */ i, /* int */ j) (VALUE ((A68_INT *) ADDRESS (i)) -= (j), (i)) #define a68g_timesab_int(/* A68_REF * */ i, /* int */ j) (VALUE ((A68_INT *) ADDRESS (i)) *= (j), (i)) #define a68g_overab_int(/* A68_REF * */ i, /* int */ j) (VALUE ((A68_INT *) ADDRESS (i)) /= (j), (i)) #define a68g_entier(/* double */ x) ((int) floor (x)) #define a68g_plusab_real(/* A68_REF * */ i, /* double */ j) (VALUE ((A68_REAL *) ADDRESS (i)) += (j), (i)) #define a68g_minusab_real(/* A68_REF * */ i, /* double */ j) (VALUE ((A68_REAL *) ADDRESS (i)) -= (j), (i)) #define a68g_timesab_real(/* A68_REF * */ i, /* double */ j) (VALUE ((A68_REAL *) ADDRESS (i)) *= (j), (i)) #define a68g_divab_real(/* A68_REF * */ i, /* double */ j) (VALUE ((A68_REAL *) ADDRESS (i)) /= (j), (i)) #define a68g_re_complex(/* A68_REAL * */ z) (RE (z)) #define a68g_im_complex(/* A68_REAL * */ z) (IM (z)) #define a68g_abs_complex(/* A68_REAL * */ z) a68g_hypot (RE (z), IM (z)) #define a68g_arg_complex(/* A68_REAL * */ z) atan2 (IM (z), RE (z)) #define a68g_i_complex(/* A68_REAL * */ z, /* double */ re, im) {\ STATUS_RE (z) = INIT_MASK;\ STATUS_IM (z) = INIT_MASK;\ RE (z) = re;\ IM (z) = im;} #define a68g_minus_complex(/* A68_REAL * */ z, x) {\ STATUS_RE (z) = INIT_MASK;\ STATUS_IM (z) = INIT_MASK;\ RE (z) = -RE (x);\ IM (z) = -IM (x);} #define a68g_conj_complex(/* A68_REAL * */ z, x) {\ STATUS_RE (z) = INIT_MASK;\ STATUS_IM (z) = INIT_MASK;\ RE (z) = RE (x);\ IM (z) = -IM (x);} #define a68g_add_complex(/* A68_REAL * */ z, x, y) {\ STATUS_RE (z) = INIT_MASK;\ STATUS_IM (z) = INIT_MASK;\ RE (z) = RE (x) + RE (y);\ IM (z) = IM (x) + IM (y);} #define a68g_sub_complex(/* A68_REAL * */ z, x, y) {\ STATUS_RE (z) = INIT_MASK;\ STATUS_IM (z) = INIT_MASK;\ RE (z) = RE (x) - RE (y);\ IM (z) = IM (x) - IM (y);} #define a68g_mul_complex(/* A68_REAL * */ z, x, y) {\ STATUS_RE (z) = INIT_MASK;\ STATUS_IM (z) = INIT_MASK;\ RE (z) = RE (x) * RE (y) - IM (x) * IM (y);\ IM (z) = IM (x) * RE (y) + RE (x) * IM (y);} /********************************/ /* All kind of constants ex GSL */ /********************************/ #define GSL_CONST_NUM_FINE_STRUCTURE (7.297352533e-3) /* 1 */ #define GSL_CONST_NUM_AVOGADRO (6.02214199e23) /* 1 / mol */ #define GSL_CONST_NUM_YOTTA (1e24) /* 1 */ #define GSL_CONST_NUM_ZETTA (1e21) /* 1 */ #define GSL_CONST_NUM_EXA (1e18) /* 1 */ #define GSL_CONST_NUM_PETA (1e15) /* 1 */ #define GSL_CONST_NUM_TERA (1e12) /* 1 */ #define GSL_CONST_NUM_GIGA (1e9) /* 1 */ #define GSL_CONST_NUM_MEGA (1e6) /* 1 */ #define GSL_CONST_NUM_KILO (1e3) /* 1 */ #define GSL_CONST_NUM_MILLI (1e-3) /* 1 */ #define GSL_CONST_NUM_MICRO (1e-6) /* 1 */ #define GSL_CONST_NUM_NANO (1e-9) /* 1 */ #define GSL_CONST_NUM_PICO (1e-12) /* 1 */ #define GSL_CONST_NUM_FEMTO (1e-15) /* 1 */ #define GSL_CONST_NUM_ATTO (1e-18) /* 1 */ #define GSL_CONST_NUM_ZEPTO (1e-21) /* 1 */ #define GSL_CONST_NUM_YOCTO (1e-24) /* 1 */ #define GSL_CONST_CGSM_GAUSS (1.0) /* cm / A s^2 */ #define GSL_CONST_CGSM_SPEED_OF_LIGHT (2.99792458e10) /* cm / s */ #define GSL_CONST_CGSM_GRAVITATIONAL_CONSTANT (6.673e-8) /* cm^3 / g s^2 */ #define GSL_CONST_CGSM_ASTRONOMICAL_UNIT (1.49597870691e13) /* cm */ #define GSL_CONST_CGSM_LIGHT_YEAR (9.46053620707e17) /* cm */ #define GSL_CONST_CGSM_PARSEC (3.08567758135e18) /* cm */ #define GSL_CONST_CGSM_GRAV_ACCEL (9.80665e2) /* cm / s^2 */ #define GSL_CONST_CGSM_ELECTRON_VOLT (1.602176487e-12) /* g cm^2 / s^2 */ #define GSL_CONST_CGSM_MASS_ELECTRON (9.10938188e-28) /* g */ #define GSL_CONST_CGSM_MASS_MUON (1.88353109e-25) /* g */ #define GSL_CONST_CGSM_MASS_PROTON (1.67262158e-24) /* g */ #define GSL_CONST_CGSM_MASS_NEUTRON (1.67492716e-24) /* g */ #define GSL_CONST_CGSM_RYDBERG (2.17987196968e-11) /* g cm^2 / s^2 */ #define GSL_CONST_CGSM_BOLTZMANN (1.3806504e-16) /* g cm^2 / K s^2 */ #define GSL_CONST_CGSM_MOLAR_GAS (8.314472e7) /* g cm^2 / K mol s^2 */ #define GSL_CONST_CGSM_STANDARD_GAS_VOLUME (2.2710981e4) /* cm^3 / mol */ #define GSL_CONST_CGSM_MINUTE (6e1) /* s */ #define GSL_CONST_CGSM_HOUR (3.6e3) /* s */ #define GSL_CONST_CGSM_DAY (8.64e4) /* s */ #define GSL_CONST_CGSM_WEEK (6.048e5) /* s */ #define GSL_CONST_CGSM_INCH (2.54e0) /* cm */ #define GSL_CONST_CGSM_FOOT (3.048e1) /* cm */ #define GSL_CONST_CGSM_YARD (9.144e1) /* cm */ #define GSL_CONST_CGSM_MILE (1.609344e5) /* cm */ #define GSL_CONST_CGSM_NAUTICAL_MILE (1.852e5) /* cm */ #define GSL_CONST_CGSM_FATHOM (1.8288e2) /* cm */ #define GSL_CONST_CGSM_MIL (2.54e-3) /* cm */ #define GSL_CONST_CGSM_POINT (3.52777777778e-2) /* cm */ #define GSL_CONST_CGSM_TEXPOINT (3.51459803515e-2) /* cm */ #define GSL_CONST_CGSM_MICRON (1e-4) /* cm */ #define GSL_CONST_CGSM_ANGSTROM (1e-8) /* cm */ #define GSL_CONST_CGSM_HECTARE (1e8) /* cm^2 */ #define GSL_CONST_CGSM_ACRE (4.04685642241e7) /* cm^2 */ #define GSL_CONST_CGSM_BARN (1e-24) /* cm^2 */ #define GSL_CONST_CGSM_LITER (1e3) /* cm^3 */ #define GSL_CONST_CGSM_US_GALLON (3.78541178402e3) /* cm^3 */ #define GSL_CONST_CGSM_QUART (9.46352946004e2) /* cm^3 */ #define GSL_CONST_CGSM_PINT (4.73176473002e2) /* cm^3 */ #define GSL_CONST_CGSM_CUP (2.36588236501e2) /* cm^3 */ #define GSL_CONST_CGSM_FLUID_OUNCE (2.95735295626e1) /* cm^3 */ #define GSL_CONST_CGSM_TABLESPOON (1.47867647813e1) /* cm^3 */ #define GSL_CONST_CGSM_TEASPOON (4.92892159375e0) /* cm^3 */ #define GSL_CONST_CGSM_CANADIAN_GALLON (4.54609e3) /* cm^3 */ #define GSL_CONST_CGSM_UK_GALLON (4.546092e3) /* cm^3 */ #define GSL_CONST_CGSM_MILES_PER_HOUR (4.4704e1) /* cm / s */ #define GSL_CONST_CGSM_KILOMETERS_PER_HOUR (2.77777777778e1) /* cm / s */ #define GSL_CONST_CGSM_KNOT (5.14444444444e1) /* cm / s */ #define GSL_CONST_CGSM_POUND_MASS (4.5359237e2) /* g */ #define GSL_CONST_CGSM_OUNCE_MASS (2.8349523125e1) /* g */ #define GSL_CONST_CGSM_TON (9.0718474e5) /* g */ #define GSL_CONST_CGSM_METRIC_TON (1e6) /* g */ #define GSL_CONST_CGSM_UK_TON (1.0160469088e6) /* g */ #define GSL_CONST_CGSM_TROY_OUNCE (3.1103475e1) /* g */ #define GSL_CONST_CGSM_CARAT (2e-1) /* g */ #define GSL_CONST_CGSM_UNIFIED_ATOMIC_MASS (1.660538782e-24) /* g */ #define GSL_CONST_CGSM_GRAM_FORCE (9.80665e2) /* cm g / s^2 */ #define GSL_CONST_CGSM_POUND_FORCE (4.44822161526e5) /* cm g / s^2 */ #define GSL_CONST_CGSM_KILOPOUND_FORCE (4.44822161526e8) /* cm g / s^2 */ #define GSL_CONST_CGSM_POUNDAL (1.38255e4) /* cm g / s^2 */ #define GSL_CONST_CGSM_CALORIE (4.1868e7) /* g cm^2 / s^2 */ #define GSL_CONST_CGSM_BTU (1.05505585262e10) /* g cm^2 / s^2 */ #define GSL_CONST_CGSM_THERM (1.05506e15) /* g cm^2 / s^2 */ #define GSL_CONST_CGSM_HORSEPOWER (7.457e9) /* g cm^2 / s^3 */ #define GSL_CONST_CGSM_BAR (1e6) /* g / cm s^2 */ #define GSL_CONST_CGSM_STD_ATMOSPHERE (1.01325e6) /* g / cm s^2 */ #define GSL_CONST_CGSM_TORR (1.33322368421e3) /* g / cm s^2 */ #define GSL_CONST_CGSM_METER_OF_MERCURY (1.33322368421e6) /* g / cm s^2 */ #define GSL_CONST_CGSM_INCH_OF_MERCURY (3.38638815789e4) /* g / cm s^2 */ #define GSL_CONST_CGSM_INCH_OF_WATER (2.490889e3) /* g / cm s^2 */ #define GSL_CONST_CGSM_PSI (6.89475729317e4) /* g / cm s^2 */ #define GSL_CONST_CGSM_POISE (1e0) /* g / cm s */ #define GSL_CONST_CGSM_STOKES (1e0) /* cm^2 / s */ #define GSL_CONST_CGSM_STILB (1e0) /* cd / cm^2 */ #define GSL_CONST_CGSM_LUMEN (1e0) /* cd sr */ #define GSL_CONST_CGSM_LUX (1e-4) /* cd sr / cm^2 */ #define GSL_CONST_CGSM_PHOT (1e0) /* cd sr / cm^2 */ #define GSL_CONST_CGSM_FOOTCANDLE (1.076e-3) /* cd sr / cm^2 */ #define GSL_CONST_CGSM_LAMBERT (1e0) /* cd sr / cm^2 */ #define GSL_CONST_CGSM_FOOTLAMBERT (1.07639104e-3) /* cd sr / cm^2 */ #define GSL_CONST_CGSM_CURIE (3.7e10) /* 1 / s */ #define GSL_CONST_CGSM_ROENTGEN (2.58e-8) /* abamp s / g */ #define GSL_CONST_CGSM_RAD (1e2) /* cm^2 / s^2 */ #define GSL_CONST_CGSM_SOLAR_MASS (1.98892e33) /* g */ #define GSL_CONST_CGSM_BOHR_RADIUS (5.291772083e-9) /* cm */ #define GSL_CONST_CGSM_NEWTON (1e5) /* cm g / s^2 */ #define GSL_CONST_CGSM_DYNE (1e0) /* cm g / s^2 */ #define GSL_CONST_CGSM_JOULE (1e7) /* g cm^2 / s^2 */ #define GSL_CONST_CGSM_ERG (1e0) /* g cm^2 / s^2 */ #define GSL_CONST_CGSM_BOHR_MAGNETON (9.27400899e-21) /* abamp cm^2 */ #define GSL_CONST_CGSM_NUCLEAR_MAGNETON (5.05078317e-24) /* abamp cm^2 */ #define GSL_CONST_CGSM_ELECTRON_MAGNETIC_MOMENT (9.28476362e-21) /* abamp cm^2 */ #define GSL_CONST_CGSM_PROTON_MAGNETIC_MOMENT (1.410606633e-23) /* abamp cm^2 */ #define GSL_CONST_CGSM_FARADAY (9.64853429775e3) /* abamp s / mol */ #define GSL_CONST_CGSM_ELECTRON_CHARGE (1.602176487e-20) /* abamp s */ #define GSL_CONST_MKS_SPEED_OF_LIGHT (2.99792458e8) /* m / s */ #define GSL_CONST_MKS_GRAVITATIONAL_CONSTANT (6.673e-11) /* m^3 / kg s^2 */ #define GSL_CONST_MKS_ASTRONOMICAL_UNIT (1.49597870691e11) /* m */ #define GSL_CONST_MKS_LIGHT_YEAR (9.46053620707e15) /* m */ #define GSL_CONST_MKS_PARSEC (3.08567758135e16) /* m */ #define GSL_CONST_MKS_GRAV_ACCEL (9.80665e0) /* m / s^2 */ #define GSL_CONST_MKS_ELECTRON_VOLT (1.602176487e-19) /* kg m^2 / s^2 */ #define GSL_CONST_MKS_MASS_ELECTRON (9.10938188e-31) /* kg */ #define GSL_CONST_MKS_MASS_MUON (1.88353109e-28) /* kg */ #define GSL_CONST_MKS_MASS_PROTON (1.67262158e-27) /* kg */ #define GSL_CONST_MKS_MASS_NEUTRON (1.67492716e-27) /* kg */ #define GSL_CONST_MKS_RYDBERG (2.17987196968e-18) /* kg m^2 / s^2 */ #define GSL_CONST_MKS_BOLTZMANN (1.3806504e-23) /* kg m^2 / K s^2 */ #define GSL_CONST_MKS_MOLAR_GAS (8.314472e0) /* kg m^2 / K mol s^2 */ #define GSL_CONST_MKS_STANDARD_GAS_VOLUME (2.2710981e-2) /* m^3 / mol */ #define GSL_CONST_MKS_MINUTE (6e1) /* s */ #define GSL_CONST_MKS_HOUR (3.6e3) /* s */ #define GSL_CONST_MKS_DAY (8.64e4) /* s */ #define GSL_CONST_MKS_WEEK (6.048e5) /* s */ #define GSL_CONST_MKS_INCH (2.54e-2) /* m */ #define GSL_CONST_MKS_FOOT (3.048e-1) /* m */ #define GSL_CONST_MKS_YARD (9.144e-1) /* m */ #define GSL_CONST_MKS_MILE (1.609344e3) /* m */ #define GSL_CONST_MKS_NAUTICAL_MILE (1.852e3) /* m */ #define GSL_CONST_MKS_FATHOM (1.8288e0) /* m */ #define GSL_CONST_MKS_MIL (2.54e-5) /* m */ #define GSL_CONST_MKS_POINT (3.52777777778e-4) /* m */ #define GSL_CONST_MKS_TEXPOINT (3.51459803515e-4) /* m */ #define GSL_CONST_MKS_MICRON (1e-6) /* m */ #define GSL_CONST_MKS_ANGSTROM (1e-10) /* m */ #define GSL_CONST_MKS_HECTARE (1e4) /* m^2 */ #define GSL_CONST_MKS_ACRE (4.04685642241e3) /* m^2 */ #define GSL_CONST_MKS_BARN (1e-28) /* m^2 */ #define GSL_CONST_MKS_LITER (1e-3) /* m^3 */ #define GSL_CONST_MKS_US_GALLON (3.78541178402e-3) /* m^3 */ #define GSL_CONST_MKS_QUART (9.46352946004e-4) /* m^3 */ #define GSL_CONST_MKS_PINT (4.73176473002e-4) /* m^3 */ #define GSL_CONST_MKS_CUP (2.36588236501e-4) /* m^3 */ #define GSL_CONST_MKS_FLUID_OUNCE (2.95735295626e-5) /* m^3 */ #define GSL_CONST_MKS_TABLESPOON (1.47867647813e-5) /* m^3 */ #define GSL_CONST_MKS_TEASPOON (4.92892159375e-6) /* m^3 */ #define GSL_CONST_MKS_CANADIAN_GALLON (4.54609e-3) /* m^3 */ #define GSL_CONST_MKS_UK_GALLON (4.546092e-3) /* m^3 */ #define GSL_CONST_MKS_MILES_PER_HOUR (4.4704e-1) /* m / s */ #define GSL_CONST_MKS_KILOMETERS_PER_HOUR (2.77777777778e-1) /* m / s */ #define GSL_CONST_MKS_KNOT (5.14444444444e-1) /* m / s */ #define GSL_CONST_MKS_POUND_MASS (4.5359237e-1) /* kg */ #define GSL_CONST_MKS_OUNCE_MASS (2.8349523125e-2) /* kg */ #define GSL_CONST_MKS_TON (9.0718474e2) /* kg */ #define GSL_CONST_MKS_METRIC_TON (1e3) /* kg */ #define GSL_CONST_MKS_UK_TON (1.0160469088e3) /* kg */ #define GSL_CONST_MKS_TROY_OUNCE (3.1103475e-2) /* kg */ #define GSL_CONST_MKS_CARAT (2e-4) /* kg */ #define GSL_CONST_MKS_UNIFIED_ATOMIC_MASS (1.660538782e-27) /* kg */ #define GSL_CONST_MKS_GRAM_FORCE (9.80665e-3) /* kg m / s^2 */ #define GSL_CONST_MKS_POUND_FORCE (4.44822161526e0) /* kg m / s^2 */ #define GSL_CONST_MKS_KILOPOUND_FORCE (4.44822161526e3) /* kg m / s^2 */ #define GSL_CONST_MKS_POUNDAL (1.38255e-1) /* kg m / s^2 */ #define GSL_CONST_MKS_CALORIE (4.1868e0) /* kg m^2 / s^2 */ #define GSL_CONST_MKS_BTU (1.05505585262e3) /* kg m^2 / s^2 */ #define GSL_CONST_MKS_THERM (1.05506e8) /* kg m^2 / s^2 */ #define GSL_CONST_MKS_HORSEPOWER (7.457e2) /* kg m^2 / s^3 */ #define GSL_CONST_MKS_BAR (1e5) /* kg / m s^2 */ #define GSL_CONST_MKS_STD_ATMOSPHERE (1.01325e5) /* kg / m s^2 */ #define GSL_CONST_MKS_TORR (1.33322368421e2) /* kg / m s^2 */ #define GSL_CONST_MKS_METER_OF_MERCURY (1.33322368421e5) /* kg / m s^2 */ #define GSL_CONST_MKS_INCH_OF_MERCURY (3.38638815789e3) /* kg / m s^2 */ #define GSL_CONST_MKS_INCH_OF_WATER (2.490889e2) /* kg / m s^2 */ #define GSL_CONST_MKS_PSI (6.89475729317e3) /* kg / m s^2 */ #define GSL_CONST_MKS_POISE (1e-1) /* kg m^-1 s^-1 */ #define GSL_CONST_MKS_STOKES (1e-4) /* m^2 / s */ #define GSL_CONST_MKS_STILB (1e4) /* cd / m^2 */ #define GSL_CONST_MKS_LUMEN (1e0) /* cd sr */ #define GSL_CONST_MKS_LUX (1e0) /* cd sr / m^2 */ #define GSL_CONST_MKS_PHOT (1e4) /* cd sr / m^2 */ #define GSL_CONST_MKS_FOOTCANDLE (1.076e1) /* cd sr / m^2 */ #define GSL_CONST_MKS_LAMBERT (1e4) /* cd sr / m^2 */ #define GSL_CONST_MKS_FOOTLAMBERT (1.07639104e1) /* cd sr / m^2 */ #define GSL_CONST_MKS_CURIE (3.7e10) /* 1 / s */ #define GSL_CONST_MKS_ROENTGEN (2.58e-4) /* A s / kg */ #define GSL_CONST_MKS_RAD (1e-2) /* m^2 / s^2 */ #define GSL_CONST_MKS_SOLAR_MASS (1.98892e30) /* kg */ #define GSL_CONST_MKS_BOHR_RADIUS (5.291772083e-11) /* m */ #define GSL_CONST_MKS_NEWTON (1e0) /* kg m / s^2 */ #define GSL_CONST_MKS_DYNE (1e-5) /* kg m / s^2 */ #define GSL_CONST_MKS_JOULE (1e0) /* kg m^2 / s^2 */ #define GSL_CONST_MKS_ERG (1e-7) /* kg m^2 / s^2 */ #define GSL_CONST_MKS_BOHR_MAGNETON (9.27400899e-24) /* A m^2 */ #define GSL_CONST_MKS_NUCLEAR_MAGNETON (5.05078317e-27) /* A m^2 */ #define GSL_CONST_MKS_ELECTRON_MAGNETIC_MOMENT (9.28476362e-24) /* A m^2 */ #define GSL_CONST_MKS_PROTON_MAGNETIC_MOMENT (1.410606633e-26) /* A m^2 */ #define GSL_CONST_MKS_FARADAY (9.64853429775e4) /* A s / mol */ #define GSL_CONST_MKS_ELECTRON_CHARGE (1.602176487e-19) /* A s */ #define GSL_CONST_MKS_VACUUM_PERMITTIVITY (8.854187817e-12) /* A^2 s^4 / kg m^3 */ #define GSL_CONST_MKS_VACUUM_PERMEABILITY (1.25663706144e-6) /* kg m / A^2 s^2 */ #define GSL_CONST_MKS_GAUSS (1e-4) /* kg / A s^2 */ /***********************/ /* Global declarations */ /***********************/ extern A68_CHANNEL stand_in_channel, stand_out_channel, stand_draw_channel, stand_back_channel, stand_error_channel, associate_channel, skip_channel; extern A68_FORMAT nil_format; extern A68_HANDLE nil_handle, *free_handles, *busy_handles; extern A68_REF nil_ref, stand_in, stand_out, skip_file; extern ADDR_T fixed_heap_pointer, temp_heap_pointer, frame_pointer, stack_pointer, heap_pointer, handle_pointer, global_pointer, frame_start, frame_end, stack_start, stack_end, finish_frame_pointer; extern BOOL_T halt_typing, heap_is_fluid, in_execution, in_monitor, do_confirm_exit, no_warnings; extern BYTE_T *stack_segment, *heap_segment, *handle_segment, *system_stack_offset; extern KEYWORD_T *top_keyword; extern MODES_T a68_modes; extern MODULE_T program; extern NODE_T **node_register; extern POSTULATE_T *top_postulate, *top_postulate_list; extern TABLE_T *a68g_standenv; extern TAG_T *error_tag; extern TOKEN_T *top_token; extern char **global_argv, *watchpoint_expression, a68g_cmd_name[], output_line[], edit_line[], input_line[]; extern clock_t clock_res; extern double cputime_0, garbage_seconds; extern int frame_stack_size, expr_stack_size, heap_size, handle_pool_size, free_handle_count, max_handle_count, garbage_collects, global_argc, global_level, max_lex_lvl, new_nodes, new_modes, new_postulates, new_node_infos, new_genie_infos, stack_limit, frame_stack_limit, expr_stack_limit, stack_size, storage_overhead, symbol_table_count, mode_count, term_heigth, term_width, varying_mp_digits; extern jmp_buf genie_exit_label; #if defined HAVE_CURSES extern BOOL_T a68g_curses_mode; #endif #if defined HAVE_PARALLEL_CLAUSE extern pthread_t main_thread_id; extern int running_par_level; #endif #if defined HAVE_WIN32 extern int finite (double); #endif extern A68_REF genie_make_row (NODE_T *, MOID_T *, int, ADDR_T); extern A68_REF c_string_to_row_char (NODE_T *, char *, int); extern A68_REF c_to_a_string (NODE_T *, char *, int); extern A68_REF empty_row (NODE_T *, MOID_T *); extern A68_REF empty_string (NODE_T *); extern A68_REF heap_generator (NODE_T *, MOID_T *, int); extern ADDR_T calculate_internal_index (A68_TUPLE *, int); extern BOOL_T a68g_mkstemp(char *, int, mode_t); extern BOOL_T close_device (NODE_T *, A68_FILE *); extern BOOL_T genie_int_case_unit (NODE_T *, int, int *); extern BOOL_T genie_string_to_value_internal (NODE_T *, MOID_T *, char *, BYTE_T *); extern BOOL_T increment_internal_index (A68_TUPLE *, int); extern BOOL_T lexical_analyser (void); extern BOOL_T match_string (char *, char *, char); extern BOOL_T set_options (OPTION_LIST_T *, BOOL_T); extern BOOL_T whether (NODE_T * p, ...); extern BOOL_T is_coercion (NODE_T *); extern BOOL_T is_firm (MOID_T *, MOID_T *); extern BOOL_T is_modes_equivalent (MOID_T *, MOID_T *); extern BOOL_T is_new_lexical_level (NODE_T *); extern BOOL_T is_one_of (NODE_T * p, ...); extern BOOL_T is_subset (MOID_T *, MOID_T *, int); extern BOOL_T is_unitable (MOID_T *, MOID_T *, int); extern BYTE_T *get_fixed_heap_space (size_t); extern BYTE_T *get_heap_space (size_t); extern BYTE_T *get_temp_heap_space (size_t); extern FILE *a68g_fopen (char *, char *, char *); extern FILE_T open_physical_file (NODE_T *, A68_REF, int, mode_t); extern GINFO_T *new_genie_info (void); extern KEYWORD_T *find_keyword (KEYWORD_T *, char *); extern KEYWORD_T *find_keyword_from_attribute (KEYWORD_T *, int); extern MOID_T *add_mode (MOID_T **, int, int, NODE_T *, MOID_T *, PACK_T *); extern MOID_T *depref_completely (MOID_T *); extern MOID_T *new_moid (void); extern MOID_T *unites_to (MOID_T *, MOID_T *); extern NODE_INFO_T *new_node_info (void); extern NODE_T *get_next_format_pattern (NODE_T *, A68_REF, BOOL_T); extern NODE_T *last_unit; extern NODE_T *new_node (void); extern NODE_T *some_node (char *); extern PACK_T *new_pack (void); extern POSTULATE_T *is_postulated (POSTULATE_T *, MOID_T *); extern POSTULATE_T *is_postulated_pair (POSTULATE_T *, MOID_T *, MOID_T *); extern LINE_T *new_source_line (void); extern TABLE_T *find_level (NODE_T *, int); extern TABLE_T *new_symbol_table (TABLE_T *); extern TAG_T *add_tag (TABLE_T *, int, NODE_T *, MOID_T *, int); extern TAG_T *find_tag_global (TABLE_T *, int, char *); extern TAG_T *find_tag_local (TABLE_T *, int, char *); extern TAG_T *new_tag (void); extern TOKEN_T *add_token (TOKEN_T **, char *); extern char *a68g_strchr (char *, int); extern char *a_to_c_string (NODE_T *, char *, A68_REF); extern char *ctrl_char (int); extern char *error_chars (char *, int); extern char *error_specification (void); extern char *fixed (NODE_T * p); extern char *get_transput_buffer (int); extern char *moid_to_string (MOID_T *, int, NODE_T *); extern char *new_fixed_string (char *); extern char *new_string (char *, ...); extern char *new_temp_string (char *); extern char *non_terminal_string (char *, int); extern char *phrase_to_text (NODE_T *, NODE_T **); extern char *propagator_name (PROP_PROC *p); extern char *read_string_from_tty (char *); extern char *standard_environ_proc_name (GPROC); extern char *sub_fixed (NODE_T *, double, int, int); extern char *sub_whole (NODE_T *, int, int); extern char *whole (NODE_T * p); extern char digit_to_char (int); extern char pop_char_transput_buffer (int); extern double a68g_acosh (double); extern double a68g_asinh (double); extern double a68g_atan2 (double, double); extern double a68g_atanh (double); extern double a68g_exp (double); extern double a68g_hypot (double, double); extern double a68g_log1p (double); extern double a68g_pow_real (double, double); extern double a68g_pow_real_int (double, int); extern double curt (double); extern double inverf (double); extern double inverfc (double); extern double rng_53_bit (void); extern double seconds (void); extern double ten_up (int); extern int a68_string_size (NODE_T *, A68_REF); extern int a68g_round (double); extern int char_scanner (A68_FILE *); extern int count_pack_members (PACK_T *); extern int end_of_format (NODE_T *, A68_REF); extern int first_tag_global (TABLE_T *, char *); extern int get_replicator_value (NODE_T *, BOOL_T); extern int get_row_size (A68_TUPLE *, int); extern int get_transput_buffer_index (int); extern int get_transput_buffer_size (int); extern int get_unblocked_transput_buffer (NODE_T *); extern int grep_in_string (char *, char *, int *, int *); extern int heap_available (void); extern int iabs (int); extern int isign (int); extern int moid_size (MOID_T *); extern int store_file_entry (NODE_T *, FILE_T, char *, BOOL_T); extern int is_identifier_or_label_global (TABLE_T *, char *); extern ssize_t io_read (FILE_T, void *, size_t); extern ssize_t io_read_conv (FILE_T, void *, size_t); extern ssize_t io_write (FILE_T, const void *, size_t); extern ssize_t io_write_conv (FILE_T, const void *, size_t); extern unsigned a68g_strtoul (char *, char **, int); extern void a68g_cos_complex (A68_REAL *, A68_REAL *); extern void a68g_div_complex (A68_REAL *, A68_REAL *, A68_REAL *); extern void a68g_exit (int); extern void a68g_exp_complex (A68_REAL *, A68_REAL *); extern void a68g_getty (int *, int *); extern void a68g_ln_complex (A68_REAL *, A68_REAL *); extern void a68g_sin_complex (A68_REAL *, A68_REAL *); extern void a68g_sqrt_complex (A68_REAL *, A68_REAL *); extern void abend (char *, char *, char *, int); extern void acronym (char *, char *); extern void add_a_string_transput_buffer (NODE_T *, int, BYTE_T *); extern void add_char_transput_buffer (NODE_T *, int, char); extern void add_mode_to_pack (PACK_T **, MOID_T *, char *, NODE_T *); extern void add_mode_to_pack_end (PACK_T **, MOID_T *, char *, NODE_T *); extern void add_option_list (OPTION_LIST_T **, char *, LINE_T *); extern void add_string_from_stack_transput_buffer (NODE_T *, int); extern void add_string_transput_buffer (NODE_T *, int, char *); extern void apropos (FILE_T, char *, char *); extern void assign_offsets (NODE_T *); extern void assign_offsets_packs (MOID_T *); extern void assign_offsets_table (TABLE_T *); extern void bind_format_tags_to_tree (NODE_T *); extern void bind_routine_tags_to_tree (NODE_T *); extern void bottom_up_error_check (NODE_T *); extern void bottom_up_parser (NODE_T *); extern void bufcat (char *, char *, int); extern void bufcpy (char *, char *, int); extern void change_breakpoints (NODE_T *, unsigned, int, BOOL_T *, char *); extern void change_masks (NODE_T *, unsigned, BOOL_T); extern void check_parenthesis (NODE_T *); extern void coercion_inserter (NODE_T *); extern void collect_taxes (NODE_T *); extern void compiler (FILE_T); extern void default_options (MODULE_T *); extern void diagnostic_line (int, LINE_T *, char *, char *, ...); extern void diagnostic_node (int, NODE_T *, char *, ...); extern void diagnostics_to_terminal (LINE_T *, int); extern void discard_heap (void); extern void end_of_file_error (NODE_T * p, A68_REF ref_file); extern void enlarge_transput_buffer (NODE_T *, int, int); extern void exit_genie (NODE_T *, int); extern void fill_symbol_table_outer (NODE_T *, TABLE_T *); extern void finalise_symbol_table_setup (NODE_T *, int); extern void format_error (NODE_T *, A68_REF, char *); extern void free_file_entries (void); extern void free_genie_heap (NODE_T *); extern void free_postulate_list (POSTULATE_T *, POSTULATE_T *); extern void gc_heap (NODE_T *, ADDR_T); extern void genie (void *); extern void genie_argc (NODE_T *); extern void genie_argv (NODE_T *); extern void genie_call_operator (NODE_T *, ADDR_T); extern void genie_call_procedure (NODE_T *, MOID_T *, MOID_T *, MOID_T *, A68_PROCEDURE *, ADDR_T, ADDR_T); extern void genie_call_event_routine (NODE_T *, MOID_T *, A68_PROCEDURE *, ADDR_T, ADDR_T); extern void genie_check_initialisation (NODE_T *, BYTE_T *, MOID_T *); extern void genie_columns (NODE_T *); extern void genie_create_pipe (NODE_T *); extern void genie_declaration (NODE_T *); extern void genie_enquiry_clause (NODE_T *); extern void genie_errno (NODE_T *); extern void genie_execve (NODE_T *); extern void genie_execve_child (NODE_T *); extern void genie_execve_child_pipe (NODE_T *); extern void genie_execve_output (NODE_T *); extern void genie_f_and_becomes (NODE_T *, MOID_T *, GPROC *); extern void genie_find_proc_op (NODE_T *, int *); extern void genie_fork (NODE_T *); extern void genie_generator_bounds (NODE_T *); extern void genie_generator_internal (NODE_T *, MOID_T *, TAG_T *, LEAP_T, ADDR_T); extern void genie_getenv (NODE_T *); extern void genie_identity_dec (NODE_T *); extern void genie_init_heap (NODE_T *); extern void genie_init_rng (void); extern void genie_localtime (NODE_T *); extern void genie_operator_dec (NODE_T *); extern void genie_preprocess (NODE_T *, int *, void *); extern void genie_proc_variable_dec (NODE_T *); extern void genie_push_undefined (NODE_T *, MOID_T *); extern void genie_read_standard (NODE_T *, MOID_T *, BYTE_T *, A68_REF); extern void genie_reset_errno (NODE_T *); extern void genie_rows (NODE_T *); extern void genie_serial_clause (NODE_T *, jmp_buf *); extern void genie_serial_units (NODE_T *, NODE_T **, jmp_buf *, int); extern void genie_strerror (NODE_T *); extern void genie_string_to_value (NODE_T *, MOID_T *, BYTE_T *, A68_REF); extern void genie_subscript (NODE_T *, A68_TUPLE **, int *, NODE_T **); extern void genie_utctime (NODE_T *); extern void genie_value_to_string (NODE_T *, MOID_T *, BYTE_T *, int); extern void genie_variable_dec (NODE_T *, NODE_T **, ADDR_T); extern void genie_waitpid (NODE_T *); extern void genie_write_standard (NODE_T *, MOID_T *, BYTE_T *, A68_REF); extern void get_global_level (NODE_T *); extern void get_max_simplout_size (NODE_T *); extern void get_refinements (void); extern void get_stack_size (void); extern void indenter (MODULE_T *); extern BOOL_T folder_mode (MOID_T *); extern void push_unit (NODE_T *); extern BOOL_T constant_unit (NODE_T *); extern void init_curses (void); extern void init_file_entries (void); extern void init_file_entry (int); extern void init_heap (void); extern void init_options (void); extern void init_postulates (void); extern void init_rng (unsigned long); extern void init_tty (void); extern void initialise_frame (NODE_T *); extern void initialise_internal_index (A68_TUPLE *, int); extern void install_signal_handlers (void); extern void io_close_tty_line (void); extern void io_write_string (FILE_T, const char *); extern void isolate_options (char *, LINE_T *); extern void jumps_from_procs (NODE_T * p); extern void list_source_line (FILE_T, LINE_T *, BOOL_T); extern void make_postulate (POSTULATE_T **, MOID_T *, MOID_T *); extern void make_special_mode (MOID_T **, int); extern void make_standard_environ (void); extern void make_sub (NODE_T *, NODE_T *, int); extern void make_moid_list (MODULE_T *); extern void mark_auxilliary (NODE_T *); extern void mark_moids (NODE_T *); extern void mode_checker (NODE_T *); extern void monitor_error (char *, char *); extern void on_event_handler (NODE_T *, A68_PROCEDURE, A68_REF); extern void online_help (FILE_T); extern void open_error (NODE_T *, A68_REF, char *); extern void pattern_error (NODE_T *, MOID_T *, int); extern void portcheck (NODE_T *); extern void preliminary_symbol_table_setup (NODE_T *); extern void print_bytes (BYTE_T *, int); extern void print_internal_index (FILE_T, A68_TUPLE *, int); extern void print_item (NODE_T *, FILE_T, BYTE_T *, MOID_T *); extern void print_mode_flat (FILE_T, MOID_T *); extern void protect_from_gc (NODE_T *); extern void prune_echoes (OPTION_LIST_T *); extern void put_refinements (void); extern void read_env_options (void); extern void read_insertion (NODE_T *, A68_REF); extern void read_rc_options (void); extern void read_sound (NODE_T *, A68_REF, A68_SOUND *); extern void rearrange_goto_less_jumps (NODE_T *); extern void register_nodes (NODE_T *); extern void renumber_moids (MOID_T *, int); extern void renumber_nodes (NODE_T *, int *); extern void reset_symbol_table_nest_count (NODE_T *); extern void reset_transput_buffer (int); extern void scan_error (LINE_T *, char *, char *); extern void scope_checker (NODE_T *); extern void set_default_event_procedure (A68_PROCEDURE *); extern void set_default_event_procedures (A68_FILE *); extern void set_moid_sizes (MOID_T *); extern void set_nest (NODE_T *, NODE_T *); extern void set_par_level (NODE_T *, int); extern void set_proc_level (NODE_T *, int); extern void set_transput_buffer_index (int, int); extern void set_transput_buffer_size (int, int); extern void set_up_tables (void); extern void single_step (NODE_T *, unsigned); extern void stack_dump (FILE_T, ADDR_T, int, int *); extern void standardise (double *, int, int, int *); extern void state_license (FILE_T); extern void state_version (FILE_T); extern void substitute_brackets (NODE_T *); extern void tie_label_to_serial (NODE_T *); extern void tie_label_to_unit (NODE_T *); extern void top_down_parser (NODE_T *); extern void transput_error (NODE_T *, A68_REF, MOID_T *); extern void tree_listing (FILE_T, NODE_T *, int, LINE_T *, int *); extern void unchar_scanner (NODE_T *, A68_FILE *, char); extern void value_error (NODE_T *, MOID_T *, A68_REF); extern void victal_checker (NODE_T *); extern void warn_for_unused_tags (NODE_T *); extern void where_in_source (FILE_T, NODE_T *); extern void widen_denotation (NODE_T *); extern void write_insertion (NODE_T *, A68_REF, unsigned); extern void write_listing (void); extern void write_listing_header (void); extern void write_object_listing (void); extern void write_purge_buffer (NODE_T *, A68_REF, int); extern void write_sound (NODE_T *, A68_REF, A68_SOUND *); extern void write_source_line (FILE_T, LINE_T *, NODE_T *, int); extern void write_source_listing (void); extern void write_tree_listing (void); #if defined HAVE_CURSES extern void edit (char *); #endif #if defined HAVE_PARALLEL_CLAUSE extern BOOL_T is_main_thread (void); extern void genie_abend_all_threads (NODE_T *, jmp_buf *, NODE_T *); extern void genie_set_exit_from_threads (int); #endif /* External multi-precision procedures */ extern BOOL_T check_long_int (MP_T *); extern BOOL_T check_longlong_int (MP_T *); extern BOOL_T check_mp_int (MP_T *, MOID_T *); extern MP_T *abs_mp (NODE_T *, MP_T *, MP_T *, int); extern MP_T *minus_mp (NODE_T *, MP_T *, MP_T *, int); extern MP_T *round_mp (NODE_T *, MP_T *, MP_T *, int); extern MP_T *entier_mp (NODE_T *, MP_T *, MP_T *, int); extern void eq_mp (NODE_T *, A68_BOOL *, MP_T *, MP_T *, int); extern void ne_mp (NODE_T *, A68_BOOL *, MP_T *, MP_T *, int); extern void lt_mp (NODE_T *, A68_BOOL *, MP_T *, MP_T *, int); extern void le_mp (NODE_T *, A68_BOOL *, MP_T *, MP_T *, int); extern void gt_mp (NODE_T *, A68_BOOL *, MP_T *, MP_T *, int); extern void ge_mp (NODE_T *, A68_BOOL *, MP_T *, MP_T *, int); extern MP_T *acos_mp (NODE_T *, MP_T *, MP_T *, int); extern MP_T *acosh_mp (NODE_T *, MP_T *, MP_T *, int); extern MP_T *add_mp (NODE_T *, MP_T *, MP_T *, MP_T *, int); extern MP_T *asin_mp (NODE_T *, MP_T *, MP_T *, int); extern MP_T *asinh_mp (NODE_T *, MP_T *, MP_T *, int); extern MP_T *atan2_mp (NODE_T *, MP_T *, MP_T *, MP_T *, int); extern MP_T *atan_mp (NODE_T *, MP_T *, MP_T *, int); extern MP_T *atanh_mp (NODE_T *, MP_T *, MP_T *, int); extern MP_T *cacos_mp (NODE_T *, MP_T *, MP_T *, int); extern MP_T *casin_mp (NODE_T *, MP_T *, MP_T *, int); extern MP_T *catan_mp (NODE_T *, MP_T *, MP_T *, int); extern MP_T *ccos_mp (NODE_T *, MP_T *, MP_T *, int); extern MP_T *cdiv_mp (NODE_T *, MP_T *, MP_T *, MP_T *, MP_T *, int); extern MP_T *cexp_mp (NODE_T *, MP_T *, MP_T *, int); extern MP_T *cln_mp (NODE_T *, MP_T *, MP_T *, int); extern MP_T *cmul_mp (NODE_T *, MP_T *, MP_T *, MP_T *, MP_T *, int); extern MP_T *cos_mp (NODE_T *, MP_T *, MP_T *, int); extern MP_T *cosh_mp (NODE_T *, MP_T *, MP_T *, int); extern MP_T *csin_mp (NODE_T *, MP_T *, MP_T *, int); extern MP_T *csqrt_mp (NODE_T *, MP_T *, MP_T *, int); extern MP_T *ctan_mp (NODE_T *, MP_T *, MP_T *, int); extern MP_T *curt_mp (NODE_T *, MP_T *, MP_T *, int); extern MP_T *div_mp (NODE_T *, MP_T *, MP_T *, MP_T *, int); extern MP_T *div_mp_digit (NODE_T *, MP_T *, MP_T *, MP_T, int); extern MP_T *exp_mp (NODE_T *, MP_T *, MP_T *, int); extern MP_T *expm1_mp (NODE_T *, MP_T *, MP_T *, int); extern MP_T *hyp_mp (NODE_T *, MP_T *, MP_T *, MP_T *, int); extern MP_T *hypot_mp (NODE_T *, MP_T *, MP_T *, MP_T *, int); extern MP_T *int_to_mp (NODE_T *, MP_T *, int, int); extern MP_T *lengthen_mp (NODE_T *, MP_T *, int, MP_T *, int); extern MP_T *ln_mp (NODE_T *, MP_T *, MP_T *, int); extern MP_T *log_mp (NODE_T *, MP_T *, MP_T *, int); extern MP_T *mod_mp (NODE_T *, MP_T *, MP_T *, MP_T *, int); extern MP_T *mp_pi (NODE_T *, MP_T *, int, int); extern MP_T *mp_ten_up (NODE_T *, MP_T *, int, int); extern MP_T *mul_mp (NODE_T *, MP_T *, MP_T *, MP_T *, int); extern MP_T *mul_mp_digit (NODE_T *, MP_T *, MP_T *, MP_T, int); extern MP_T *over_mp (NODE_T *, MP_T *, MP_T *, MP_T *, int); extern MP_T *over_mp_digit (NODE_T *, MP_T *, MP_T *, MP_T, int); extern MP_T *pack_mp_bits (NODE_T *, MP_T *, unsigned *, MOID_T *); extern MP_T *pow_mp_int (NODE_T *, MP_T *, MP_T *, int, int); extern MP_T *real_to_mp (NODE_T *, MP_T *, double, int); extern MP_T *set_mp_short (MP_T *, MP_T, int, int); extern MP_T *shorten_mp (NODE_T *, MP_T *, int, MP_T *, int); extern MP_T *sin_mp (NODE_T *, MP_T *, MP_T *, int); extern MP_T *sinh_mp (NODE_T *, MP_T *, MP_T *, int); extern MP_T *sqrt_mp (NODE_T *, MP_T *, MP_T *, int); extern MP_T *string_to_mp (NODE_T *, MP_T *, char *, int); extern MP_T *sub_mp (NODE_T *, MP_T *, MP_T *, MP_T *, int); extern MP_T *tan_mp (NODE_T *, MP_T *, MP_T *, int); extern MP_T *tanh_mp (NODE_T *, MP_T *, MP_T *, int); extern MP_T *unsigned_to_mp (NODE_T *, MP_T *, unsigned, int); extern char *long_sub_fixed (NODE_T *, MP_T *, int, int, int); extern char *long_sub_whole (NODE_T *, MP_T *, int, int); extern double mp_to_real (NODE_T *, MP_T *, int); extern int get_mp_bits_width (MOID_T *); extern int get_mp_bits_words (MOID_T *); extern int get_mp_digits (MOID_T *); extern int get_mp_size (MOID_T *); extern int int_to_mp_digits (int); extern int long_mp_digits (void); extern int longlong_mp_digits (void); extern int mp_to_int (NODE_T *, MP_T *, int); extern size_t size_long_mp (void); extern size_t size_longlong_mp (void); extern unsigned *stack_mp_bits (NODE_T *, MP_T *, MOID_T *); extern unsigned mp_to_unsigned (NODE_T *, MP_T *, int); extern void check_long_bits_value (NODE_T *, MP_T *, MOID_T *); extern void long_standardise (NODE_T *, MP_T *, int, int, int, int *); extern void raw_write_mp (char *, MP_T *, int); extern void set_longlong_mp_digits (int); extern void trunc_mp (NODE_T *, MP_T *, MP_T *, int); /* Standard prelude RTS */ extern GPROC genie_abs_bits; extern GPROC genie_abs_bool; extern GPROC genie_abs_char; extern GPROC genie_abs_complex; extern GPROC genie_abs_int; extern GPROC genie_abs_long_complex; extern GPROC genie_abs_long_mp; extern GPROC genie_abs_real; extern GPROC genie_acos_long_complex; extern GPROC genie_acos_long_mp; extern GPROC genie_acronym; extern GPROC genie_add_bytes; extern GPROC genie_add_char; extern GPROC genie_add_complex; extern GPROC genie_add_int; extern GPROC genie_add_long_bytes; extern GPROC genie_add_long_complex; extern GPROC genie_add_long_int; extern GPROC genie_add_long_mp; extern GPROC genie_add_real; extern GPROC genie_add_string; extern GPROC genie_and_bits; extern GPROC genie_and_bool; extern GPROC genie_and_long_mp; extern GPROC genie_arccos_complex; extern GPROC genie_arccos_real; extern GPROC genie_arccosh_complex; extern GPROC genie_arccosh_long_mp; extern GPROC genie_arccosh_real; extern GPROC genie_arcsin_complex; extern GPROC genie_arcsin_real; extern GPROC genie_arcsinh_complex; extern GPROC genie_arcsinh_long_mp; extern GPROC genie_arcsinh_real; extern GPROC genie_arctan_complex; extern GPROC genie_arctan_real; extern GPROC genie_arctanh_complex; extern GPROC genie_arctanh_long_mp; extern GPROC genie_arctanh_real; extern GPROC genie_arg_complex; extern GPROC genie_arg_long_complex; extern GPROC genie_asin_long_complex; extern GPROC genie_asin_long_mp; extern GPROC genie_associate; extern GPROC genie_atan2_long_mp; extern GPROC genie_atan2_real; extern GPROC genie_atan_long_complex; extern GPROC genie_atan_long_mp; extern GPROC genie_backspace; extern GPROC genie_bin_int; extern GPROC genie_bin_long_mp; extern GPROC genie_bin_possible; extern GPROC genie_bits_lengths; extern GPROC genie_bits_pack; extern GPROC genie_bits_shorths; extern GPROC genie_bits_width; extern GPROC genie_blank_char; extern GPROC genie_block; extern GPROC genie_break; extern GPROC genie_bytes_lengths; extern GPROC genie_bytes_shorths; extern GPROC genie_bytes_width; extern GPROC genie_bytespack; extern GPROC genie_cd; extern GPROC genie_char_in_string; extern GPROC genie_clear_bits; extern GPROC genie_clear_long_bits; extern GPROC genie_clear_longlong_bits; extern GPROC genie_close; extern GPROC genie_complex_lengths; extern GPROC genie_complex_shorths; extern GPROC genie_compressible; extern GPROC genie_conj_complex; extern GPROC genie_conj_long_complex; extern GPROC genie_cos_complex; extern GPROC genie_cos_long_complex; extern GPROC genie_cos_long_mp; extern GPROC genie_cos_real; extern GPROC genie_cosh_complex; extern GPROC genie_cosh_long_mp; extern GPROC genie_cosh_real; extern GPROC genie_cputime; extern GPROC genie_create; extern GPROC genie_curt_long_mp; extern GPROC genie_curt_real; extern GPROC genie_debug; extern GPROC genie_directory; extern GPROC genie_div_complex; extern GPROC genie_div_int; extern GPROC genie_div_long_complex; extern GPROC genie_div_long_mp; extern GPROC genie_div_real; extern GPROC genie_divab_complex; extern GPROC genie_divab_long_complex; extern GPROC genie_divab_long_mp; extern GPROC genie_divab_real; extern GPROC genie_draw_possible; extern GPROC genie_dyad_elems; extern GPROC genie_dyad_lwb; extern GPROC genie_dyad_upb; extern GPROC genie_elem_bits; extern GPROC genie_elem_bytes; extern GPROC genie_elem_long_bits; extern GPROC genie_elem_long_bits; extern GPROC genie_elem_long_bytes; extern GPROC genie_elem_longlong_bits; extern GPROC genie_elem_string; extern GPROC genie_entier_long_mp; extern GPROC genie_entier_real; extern GPROC genie_eof; extern GPROC genie_eoln; extern GPROC genie_eq_bits; extern GPROC genie_eq_bool; extern GPROC genie_eq_bytes; extern GPROC genie_eq_char; extern GPROC genie_eq_complex; extern GPROC genie_eq_int; extern GPROC genie_eq_long_bytes; extern GPROC genie_eq_long_complex; extern GPROC genie_eq_long_mp; extern GPROC genie_eq_real; extern GPROC genie_eq_string; extern GPROC genie_erase; extern GPROC genie_erf_real; extern GPROC genie_erfc_real; extern GPROC genie_error_char; extern GPROC genie_establish; extern GPROC genie_evaluate; extern GPROC genie_exp_char; extern GPROC genie_exp_complex; extern GPROC genie_exp_long_complex; extern GPROC genie_exp_long_mp; extern GPROC genie_exp_real; extern GPROC genie_exp_width; extern GPROC genie_file_is_block_device; extern GPROC genie_file_is_char_device; extern GPROC genie_file_is_directory; extern GPROC genie_file_is_regular; extern GPROC genie_file_mode; extern GPROC genie_first_random; extern GPROC genie_fixed; extern GPROC genie_flip_char; extern GPROC genie_float; extern GPROC genie_flop_char; extern GPROC genie_formfeed_char; extern GPROC genie_garbage_collections; extern GPROC genie_garbage_freed; extern GPROC genie_garbage_seconds; extern GPROC genie_gc_heap; extern GPROC genie_ge_bits; extern GPROC genie_ge_bytes; extern GPROC genie_ge_char; extern GPROC genie_ge_int; extern GPROC genie_ge_long_bits; extern GPROC genie_ge_long_bytes; extern GPROC genie_ge_long_mp; extern GPROC genie_ge_real; extern GPROC genie_ge_string; extern GPROC genie_get_possible; extern GPROC genie_get_sound; extern GPROC genie_gt_bytes; extern GPROC genie_gt_char; extern GPROC genie_gt_int; extern GPROC genie_gt_long_bytes; extern GPROC genie_gt_long_mp; extern GPROC genie_gt_real; extern GPROC genie_gt_string; extern GPROC genie_icomplex; extern GPROC genie_idf; extern GPROC genie_idle; extern GPROC genie_iint_complex; extern GPROC genie_im_complex; extern GPROC genie_im_long_complex; extern GPROC genie_init_transput; extern GPROC genie_int_lengths; extern GPROC genie_int_shorths; extern GPROC genie_int_width; extern GPROC genie_inverf_real; extern GPROC genie_inverfc_real; extern GPROC genie_is_alnum; extern GPROC genie_is_alpha; extern GPROC genie_is_cntrl; extern GPROC genie_is_digit; extern GPROC genie_is_graph; extern GPROC genie_is_lower; extern GPROC genie_is_print; extern GPROC genie_is_punct; extern GPROC genie_is_space; extern GPROC genie_is_upper; extern GPROC genie_is_xdigit; extern GPROC genie_last_char_in_string; extern GPROC genie_le_bits; extern GPROC genie_le_bytes; extern GPROC genie_le_char; extern GPROC genie_le_int; extern GPROC genie_le_long_bits; extern GPROC genie_le_long_bytes; extern GPROC genie_le_long_mp; extern GPROC genie_le_real; extern GPROC genie_le_string; extern GPROC genie_leng_bytes; extern GPROC genie_lengthen_complex_to_long_complex; extern GPROC genie_lengthen_int_to_long_mp; extern GPROC genie_lengthen_long_complex_to_longlong_complex; extern GPROC genie_lengthen_long_mp_to_longlong_mp; extern GPROC genie_lengthen_real_to_long_mp; extern GPROC genie_lengthen_unsigned_to_long_mp; extern GPROC genie_lj_e_12_6; extern GPROC genie_lj_f_12_6; extern GPROC genie_ln_complex; extern GPROC genie_ln_long_complex; extern GPROC genie_ln_long_mp; extern GPROC genie_ln_real; extern GPROC genie_lock; extern GPROC genie_log_long_mp; extern GPROC genie_log_real; extern GPROC genie_long_bits_pack; extern GPROC genie_long_bits_width; extern GPROC genie_long_bytes_width; extern GPROC genie_long_bytespack; extern GPROC genie_long_exp_width; extern GPROC genie_long_int_width; extern GPROC genie_long_max_bits; extern GPROC genie_long_max_int; extern GPROC genie_long_max_real; extern GPROC genie_long_min_real; extern GPROC genie_long_next_random; extern GPROC genie_long_real_width; extern GPROC genie_long_small_real; extern GPROC genie_longlong_bits_width; extern GPROC genie_longlong_exp_width; extern GPROC genie_longlong_int_width; extern GPROC genie_longlong_max_bits; extern GPROC genie_longlong_max_int; extern GPROC genie_longlong_max_real; extern GPROC genie_longlong_min_real; extern GPROC genie_longlong_real_width; extern GPROC genie_longlong_small_real; extern GPROC genie_lt_bytes; extern GPROC genie_lt_char; extern GPROC genie_lt_int; extern GPROC genie_lt_long_bytes; extern GPROC genie_lt_long_mp; extern GPROC genie_lt_real; extern GPROC genie_lt_string; extern GPROC genie_make_term; extern GPROC genie_max_abs_char; extern GPROC genie_max_bits; extern GPROC genie_max_int; extern GPROC genie_max_real; extern GPROC genie_min_real; extern GPROC genie_minus_complex; extern GPROC genie_minus_int; extern GPROC genie_minus_long_complex; extern GPROC genie_minus_long_mp; extern GPROC genie_minus_real; extern GPROC genie_minusab_complex; extern GPROC genie_minusab_int; extern GPROC genie_minusab_long_complex; extern GPROC genie_minusab_long_int; extern GPROC genie_minusab_long_mp; extern GPROC genie_minusab_real; extern GPROC genie_mod_int; extern GPROC genie_mod_long_mp; extern GPROC genie_modab_int; extern GPROC genie_modab_long_mp; extern GPROC genie_monad_elems; extern GPROC genie_monad_lwb; extern GPROC genie_monad_upb; extern GPROC genie_mul_complex; extern GPROC genie_mul_int; extern GPROC genie_mul_long_complex; extern GPROC genie_mul_long_int; extern GPROC genie_mul_long_mp; extern GPROC genie_mul_real; extern GPROC genie_ne_bits; extern GPROC genie_ne_bool; extern GPROC genie_ne_bytes; extern GPROC genie_ne_char; extern GPROC genie_ne_complex; extern GPROC genie_ne_int; extern GPROC genie_ne_long_bytes; extern GPROC genie_ne_long_complex; extern GPROC genie_ne_long_mp; extern GPROC genie_ne_real; extern GPROC genie_ne_string; extern GPROC genie_new_line; extern GPROC genie_new_page; extern GPROC genie_new_sound; extern GPROC genie_newline_char; extern GPROC genie_next_random; extern GPROC genie_next_rnd; extern GPROC genie_not_bits; extern GPROC genie_not_bool; extern GPROC genie_not_long_mp; extern GPROC genie_null_char; extern GPROC genie_odd_int; extern GPROC genie_odd_long_mp; extern GPROC genie_on_file_end; extern GPROC genie_on_format_end; extern GPROC genie_on_format_error; extern GPROC genie_on_gc_event; extern GPROC genie_on_line_end; extern GPROC genie_on_open_error; extern GPROC genie_on_page_end; extern GPROC genie_on_transput_error; extern GPROC genie_on_value_error; extern GPROC genie_open; extern GPROC genie_or_bits; extern GPROC genie_or_bool; extern GPROC genie_or_long_mp; extern GPROC genie_over_int; extern GPROC genie_over_long_mp; extern GPROC genie_overab_int; extern GPROC genie_overab_long_mp; extern GPROC genie_pi; extern GPROC genie_pi_long_mp; extern GPROC genie_plusab_bytes; extern GPROC genie_plusab_complex; extern GPROC genie_plusab_int; extern GPROC genie_plusab_long_bytes; extern GPROC genie_plusab_long_complex; extern GPROC genie_plusab_long_int; extern GPROC genie_plusab_long_mp; extern GPROC genie_plusab_real; extern GPROC genie_plusab_string; extern GPROC genie_plusto_bytes; extern GPROC genie_plusto_long_bytes; extern GPROC genie_plusto_string; extern GPROC genie_pow_complex_int; extern GPROC genie_pow_int; extern GPROC genie_pow_long_complex_int; extern GPROC genie_pow_long_mp; extern GPROC genie_pow_long_mp_int; extern GPROC genie_pow_long_mp_int_int; extern GPROC genie_pow_real; extern GPROC genie_pow_real_int; extern GPROC genie_preemptive_gc_heap; extern GPROC genie_print_bits; extern GPROC genie_print_bool; extern GPROC genie_print_char; extern GPROC genie_print_complex; extern GPROC genie_print_int; extern GPROC genie_print_long_bits; extern GPROC genie_print_long_complex; extern GPROC genie_print_long_int; extern GPROC genie_print_long_real; extern GPROC genie_print_longlong_bits; extern GPROC genie_print_longlong_complex; extern GPROC genie_print_longlong_int; extern GPROC genie_print_longlong_real; extern GPROC genie_print_real; extern GPROC genie_print_string; extern GPROC genie_program_idf; extern GPROC genie_put_possible; extern GPROC genie_pwd; extern GPROC genie_re_complex; extern GPROC genie_re_long_complex; extern GPROC genie_read; extern GPROC genie_read_bin; extern GPROC genie_read_bin_file; extern GPROC genie_read_bits; extern GPROC genie_read_bool; extern GPROC genie_read_char; extern GPROC genie_read_complex; extern GPROC genie_read_file; extern GPROC genie_read_file_format; extern GPROC genie_read_format; extern GPROC genie_read_int; extern GPROC genie_read_long_bits; extern GPROC genie_read_long_complex; extern GPROC genie_read_long_int; extern GPROC genie_read_long_real; extern GPROC genie_read_longlong_bits; extern GPROC genie_read_longlong_complex; extern GPROC genie_read_longlong_int; extern GPROC genie_read_longlong_real; extern GPROC genie_read_real; extern GPROC genie_read_string; extern GPROC genie_read_line; extern GPROC genie_real; extern GPROC genie_real_lengths; extern GPROC genie_real_shorths; extern GPROC genie_real_width; extern GPROC genie_reidf_possible; extern GPROC genie_repr_char; extern GPROC genie_reset; extern GPROC genie_reset_possible; extern GPROC genie_round_long_mp; extern GPROC genie_round_real; extern GPROC genie_set; extern GPROC genie_set_bits; extern GPROC genie_set_long_bits; extern GPROC genie_set_longlong_bits; extern GPROC genie_set_possible; extern GPROC genie_set_sound; extern GPROC genie_shl_bits; extern GPROC genie_shl_long_mp; extern GPROC genie_shorten_bytes; extern GPROC genie_shorten_long_complex_to_complex; extern GPROC genie_shorten_long_mp_to_bits; extern GPROC genie_shorten_long_mp_to_int; extern GPROC genie_shorten_long_mp_to_real; extern GPROC genie_shorten_longlong_complex_to_long_complex; extern GPROC genie_shorten_longlong_mp_to_long_mp; extern GPROC genie_shr_bits; extern GPROC genie_shr_long_mp; extern GPROC genie_sign_int; extern GPROC genie_sign_long_mp; extern GPROC genie_sign_real; extern GPROC genie_sin_complex; extern GPROC genie_sin_long_complex; extern GPROC genie_sin_long_mp; extern GPROC genie_sin_real; extern GPROC genie_sinh_complex; extern GPROC genie_sinh_long_mp; extern GPROC genie_sinh_real; extern GPROC genie_small_real; extern GPROC genie_sort_row_string; extern GPROC genie_sound_channels; extern GPROC genie_sound_rate; extern GPROC genie_sound_resolution; extern GPROC genie_sound_samples; extern GPROC genie_space; extern GPROC genie_sqrt_complex; extern GPROC genie_sqrt_long_complex; extern GPROC genie_sqrt_long_mp; extern GPROC genie_sqrt_real; extern GPROC genie_stack_pointer; extern GPROC genie_stand_back; extern GPROC genie_stand_back_channel; extern GPROC genie_stand_draw_channel; extern GPROC genie_stand_error; extern GPROC genie_stand_error_channel; extern GPROC genie_stand_in; extern GPROC genie_stand_in_channel; extern GPROC genie_stand_out; extern GPROC genie_stand_out_channel; extern GPROC genie_string_in_string; extern GPROC genie_sub_complex; extern GPROC genie_sub_int; extern GPROC genie_sub_long_complex; extern GPROC genie_sub_long_int; extern GPROC genie_sub_long_mp; extern GPROC genie_sub_real; extern GPROC genie_system; extern GPROC genie_system_stack_pointer; extern GPROC genie_system_stack_size; extern GPROC genie_tab_char; extern GPROC genie_tan_complex; extern GPROC genie_tan_long_complex; extern GPROC genie_tan_long_mp; extern GPROC genie_tan_real; extern GPROC genie_tanh_complex; extern GPROC genie_tanh_long_mp; extern GPROC genie_tanh_real; extern GPROC genie_term; extern GPROC genie_times_char_int; extern GPROC genie_times_int_char; extern GPROC genie_times_int_string; extern GPROC genie_times_string_int; extern GPROC genie_timesab_complex; extern GPROC genie_timesab_int; extern GPROC genie_timesab_long_complex; extern GPROC genie_timesab_long_int; extern GPROC genie_timesab_long_mp; extern GPROC genie_timesab_real; extern GPROC genie_timesab_string; extern GPROC genie_to_lower; extern GPROC genie_to_upper; extern GPROC genie_unimplemented; extern GPROC genie_whole; extern GPROC genie_write; extern GPROC genie_write_bin; extern GPROC genie_write_bin_file; extern GPROC genie_write_file; extern GPROC genie_write_file_format; extern GPROC genie_write_format; extern GPROC genie_xor_bits; extern GPROC genie_xor_bool; extern GPROC genie_xor_long_mp; #if defined __S_IFIFO extern GPROC genie_file_is_fifo; #endif #if defined __S_IFLNK extern GPROC genie_file_is_link; #endif #if defined HAVE_PARALLEL_CLAUSE extern GPROC genie_down_sema; extern GPROC genie_level_int_sema; extern GPROC genie_level_sema_int; extern GPROC genie_up_sema; #endif #if defined HAVE_HTTP extern GPROC genie_http_content; extern GPROC genie_tcp_request; #endif #if defined HAVE_REGEX_H extern GPROC genie_grep_in_string; extern GPROC genie_grep_in_substring; extern GPROC genie_sub_in_string; #endif /* Constants ex GSL */ extern GPROC genie_cgs_acre; extern GPROC genie_cgs_angstrom; extern GPROC genie_cgs_astronomical_unit; extern GPROC genie_cgs_bar; extern GPROC genie_cgs_barn; extern GPROC genie_cgs_bohr_magneton; extern GPROC genie_cgs_bohr_radius; extern GPROC genie_cgs_boltzmann; extern GPROC genie_cgs_btu; extern GPROC genie_cgs_calorie; extern GPROC genie_cgs_canadian_gallon; extern GPROC genie_cgs_carat; extern GPROC genie_cgs_cup; extern GPROC genie_cgs_curie; extern GPROC genie_cgs_day; extern GPROC genie_cgs_dyne; extern GPROC genie_cgs_electron_charge; extern GPROC genie_cgs_electron_magnetic_moment; extern GPROC genie_cgs_electron_volt; extern GPROC genie_cgs_erg; extern GPROC genie_cgs_faraday; extern GPROC genie_cgs_fathom; extern GPROC genie_cgs_fluid_ounce; extern GPROC genie_cgs_foot; extern GPROC genie_cgs_footcandle; extern GPROC genie_cgs_footlambert; extern GPROC genie_cgs_gauss; extern GPROC genie_cgs_gram_force; extern GPROC genie_cgs_grav_accel; extern GPROC genie_cgs_gravitational_constant; extern GPROC genie_cgs_hectare; extern GPROC genie_cgs_horsepower; extern GPROC genie_cgs_hour; extern GPROC genie_cgs_inch; extern GPROC genie_cgs_inch_of_mercury; extern GPROC genie_cgs_inch_of_water; extern GPROC genie_cgs_joule; extern GPROC genie_cgs_kilometers_per_hour; extern GPROC genie_cgs_kilopound_force; extern GPROC genie_cgs_knot; extern GPROC genie_cgs_lambert; extern GPROC genie_cgs_light_year; extern GPROC genie_cgs_liter; extern GPROC genie_cgs_lumen; extern GPROC genie_cgs_lux; extern GPROC genie_cgs_mass_electron; extern GPROC genie_cgs_mass_muon; extern GPROC genie_cgs_mass_neutron; extern GPROC genie_cgs_mass_proton; extern GPROC genie_cgs_meter_of_mercury; extern GPROC genie_cgs_metric_ton; extern GPROC genie_cgs_micron; extern GPROC genie_cgs_mil; extern GPROC genie_cgs_mile; extern GPROC genie_cgs_miles_per_hour; extern GPROC genie_cgs_minute; extern GPROC genie_cgs_molar_gas; extern GPROC genie_cgs_nautical_mile; extern GPROC genie_cgs_newton; extern GPROC genie_cgs_nuclear_magneton; extern GPROC genie_cgs_ounce_mass; extern GPROC genie_cgs_parsec; extern GPROC genie_cgs_phot; extern GPROC genie_cgs_pint; extern GPROC genie_cgs_planck_constant_h; extern GPROC genie_cgs_planck_constant_hbar; extern GPROC genie_cgs_point; extern GPROC genie_cgs_poise; extern GPROC genie_cgs_pound_force; extern GPROC genie_cgs_pound_mass; extern GPROC genie_cgs_poundal; extern GPROC genie_cgs_proton_magnetic_moment; extern GPROC genie_cgs_psi; extern GPROC genie_cgs_quart; extern GPROC genie_cgs_rad; extern GPROC genie_cgs_roentgen; extern GPROC genie_cgs_rydberg; extern GPROC genie_cgs_solar_mass; extern GPROC genie_cgs_speed_of_light; extern GPROC genie_cgs_standard_gas_volume; extern GPROC genie_cgs_std_atmosphere; extern GPROC genie_cgs_stilb; extern GPROC genie_cgs_stokes; extern GPROC genie_cgs_tablespoon; extern GPROC genie_cgs_teaspoon; extern GPROC genie_cgs_texpoint; extern GPROC genie_cgs_therm; extern GPROC genie_cgs_ton; extern GPROC genie_cgs_torr; extern GPROC genie_cgs_troy_ounce; extern GPROC genie_cgs_uk_gallon; extern GPROC genie_cgs_uk_ton; extern GPROC genie_cgs_unified_atomic_mass; extern GPROC genie_cgs_us_gallon; extern GPROC genie_cgs_week; extern GPROC genie_cgs_yard; extern GPROC genie_mks_acre; extern GPROC genie_mks_angstrom; extern GPROC genie_mks_astronomical_unit; extern GPROC genie_mks_bar; extern GPROC genie_mks_barn; extern GPROC genie_mks_bohr_magneton; extern GPROC genie_mks_bohr_radius; extern GPROC genie_mks_boltzmann; extern GPROC genie_mks_btu; extern GPROC genie_mks_calorie; extern GPROC genie_mks_canadian_gallon; extern GPROC genie_mks_carat; extern GPROC genie_mks_cup; extern GPROC genie_mks_curie; extern GPROC genie_mks_day; extern GPROC genie_mks_dyne; extern GPROC genie_mks_electron_charge; extern GPROC genie_mks_electron_magnetic_moment; extern GPROC genie_mks_electron_volt; extern GPROC genie_mks_erg; extern GPROC genie_mks_faraday; extern GPROC genie_mks_fathom; extern GPROC genie_mks_fluid_ounce; extern GPROC genie_mks_foot; extern GPROC genie_mks_footcandle; extern GPROC genie_mks_footlambert; extern GPROC genie_mks_gauss; extern GPROC genie_mks_gram_force; extern GPROC genie_mks_grav_accel; extern GPROC genie_mks_gravitational_constant; extern GPROC genie_mks_hectare; extern GPROC genie_mks_horsepower; extern GPROC genie_mks_hour; extern GPROC genie_mks_inch; extern GPROC genie_mks_inch_of_mercury; extern GPROC genie_mks_inch_of_water; extern GPROC genie_mks_joule; extern GPROC genie_mks_kilometers_per_hour; extern GPROC genie_mks_kilopound_force; extern GPROC genie_mks_knot; extern GPROC genie_mks_lambert; extern GPROC genie_mks_light_year; extern GPROC genie_mks_liter; extern GPROC genie_mks_lumen; extern GPROC genie_mks_lux; extern GPROC genie_mks_mass_electron; extern GPROC genie_mks_mass_muon; extern GPROC genie_mks_mass_neutron; extern GPROC genie_mks_mass_proton; extern GPROC genie_mks_meter_of_mercury; extern GPROC genie_mks_metric_ton; extern GPROC genie_mks_micron; extern GPROC genie_mks_mil; extern GPROC genie_mks_mile; extern GPROC genie_mks_miles_per_hour; extern GPROC genie_mks_minute; extern GPROC genie_mks_molar_gas; extern GPROC genie_mks_nautical_mile; extern GPROC genie_mks_newton; extern GPROC genie_mks_nuclear_magneton; extern GPROC genie_mks_ounce_mass; extern GPROC genie_mks_parsec; extern GPROC genie_mks_phot; extern GPROC genie_mks_pint; extern GPROC genie_mks_planck_constant_h; extern GPROC genie_mks_planck_constant_hbar; extern GPROC genie_mks_point; extern GPROC genie_mks_poise; extern GPROC genie_mks_pound_force; extern GPROC genie_mks_pound_mass; extern GPROC genie_mks_poundal; extern GPROC genie_mks_proton_magnetic_moment; extern GPROC genie_mks_psi; extern GPROC genie_mks_quart; extern GPROC genie_mks_rad; extern GPROC genie_mks_roentgen; extern GPROC genie_mks_rydberg; extern GPROC genie_mks_solar_mass; extern GPROC genie_mks_speed_of_light; extern GPROC genie_mks_standard_gas_volume; extern GPROC genie_mks_std_atmosphere; extern GPROC genie_mks_stilb; extern GPROC genie_mks_stokes; extern GPROC genie_mks_tablespoon; extern GPROC genie_mks_teaspoon; extern GPROC genie_mks_texpoint; extern GPROC genie_mks_therm; extern GPROC genie_mks_ton; extern GPROC genie_mks_torr; extern GPROC genie_mks_troy_ounce; extern GPROC genie_mks_uk_gallon; extern GPROC genie_mks_uk_ton; extern GPROC genie_mks_unified_atomic_mass; extern GPROC genie_mks_us_gallon; extern GPROC genie_mks_vacuum_permeability; extern GPROC genie_mks_vacuum_permittivity; extern GPROC genie_mks_week; extern GPROC genie_mks_yard; extern GPROC genie_num_atto; extern GPROC genie_num_avogadro; extern GPROC genie_num_exa; extern GPROC genie_num_femto; extern GPROC genie_num_fine_structure; extern GPROC genie_num_giga; extern GPROC genie_num_kilo; extern GPROC genie_num_mega; extern GPROC genie_num_micro; extern GPROC genie_num_milli; extern GPROC genie_num_nano; extern GPROC genie_num_peta; extern GPROC genie_num_pico; extern GPROC genie_num_tera; extern GPROC genie_num_yocto; extern GPROC genie_num_yotta; extern GPROC genie_num_zepto; extern GPROC genie_num_zetta; #if defined HAVE_GNU_PLOTUTILS extern GPROC genie_draw_aspect; extern GPROC genie_draw_atom; extern GPROC genie_draw_background_colour; extern GPROC genie_draw_background_colour_name; extern GPROC genie_draw_circle; extern GPROC genie_draw_clear; extern GPROC genie_draw_colour; extern GPROC genie_draw_colour_name; extern GPROC genie_draw_fillstyle; extern GPROC genie_draw_fontname; extern GPROC genie_draw_fontsize; extern GPROC genie_draw_get_colour_name; extern GPROC genie_draw_line; extern GPROC genie_draw_linestyle; extern GPROC genie_draw_linewidth; extern GPROC genie_draw_move; extern GPROC genie_draw_point; extern GPROC genie_draw_rect; extern GPROC genie_draw_show; extern GPROC genie_draw_star; extern GPROC genie_draw_text; extern GPROC genie_draw_textangle; extern GPROC genie_make_device; #endif #if defined HAVE_GNU_GSL extern GPROC genie_airy_ai_deriv_real; extern GPROC genie_airy_ai_real; extern GPROC genie_airy_bi_deriv_real; extern GPROC genie_airy_bi_real; extern GPROC genie_bessel_exp_il_real; extern GPROC genie_bessel_exp_in_real; extern GPROC genie_bessel_exp_inu_real; extern GPROC genie_bessel_exp_kl_real; extern GPROC genie_bessel_exp_kn_real; extern GPROC genie_bessel_exp_knu_real; extern GPROC genie_bessel_in_real; extern GPROC genie_bessel_inu_real; extern GPROC genie_bessel_jl_real; extern GPROC genie_bessel_jn_real; extern GPROC genie_bessel_jnu_real; extern GPROC genie_bessel_kn_real; extern GPROC genie_bessel_knu_real; extern GPROC genie_bessel_yl_real; extern GPROC genie_bessel_yn_real; extern GPROC genie_bessel_ynu_real; extern GPROC genie_beta_inc_real; extern GPROC genie_beta_real; extern GPROC genie_complex_scale_matrix_complex; extern GPROC genie_complex_scale_vector_complex; extern GPROC genie_elliptic_integral_e_real; extern GPROC genie_elliptic_integral_k_real; extern GPROC genie_elliptic_integral_rc_real; extern GPROC genie_elliptic_integral_rd_real; extern GPROC genie_elliptic_integral_rf_real; extern GPROC genie_elliptic_integral_rj_real; extern GPROC genie_factorial_real; extern GPROC genie_fft_backward; extern GPROC genie_fft_complex_backward; extern GPROC genie_fft_complex_forward; extern GPROC genie_fft_complex_inverse; extern GPROC genie_fft_forward; extern GPROC genie_fft_inverse; extern GPROC genie_gamma_inc_real; extern GPROC genie_gamma_real; extern GPROC genie_laplace; extern GPROC genie_lngamma_real; extern GPROC genie_matrix_add; extern GPROC genie_matrix_ch; extern GPROC genie_matrix_ch_solve; extern GPROC genie_matrix_complex_add; extern GPROC genie_matrix_complex_det; extern GPROC genie_matrix_complex_div_complex; extern GPROC genie_matrix_complex_div_complex_ab; extern GPROC genie_matrix_complex_echo; extern GPROC genie_matrix_complex_eq; extern GPROC genie_matrix_complex_inv; extern GPROC genie_matrix_complex_lu; extern GPROC genie_matrix_complex_lu_det; extern GPROC genie_matrix_complex_lu_inv; extern GPROC genie_matrix_complex_lu_solve; extern GPROC genie_matrix_complex_minus; extern GPROC genie_matrix_complex_minusab; extern GPROC genie_matrix_complex_ne; extern GPROC genie_matrix_complex_plusab; extern GPROC genie_matrix_complex_scale_complex; extern GPROC genie_matrix_complex_scale_complex_ab; extern GPROC genie_matrix_complex_sub; extern GPROC genie_matrix_complex_times_matrix; extern GPROC genie_matrix_complex_times_vector; extern GPROC genie_matrix_complex_trace; extern GPROC genie_matrix_complex_transpose; extern GPROC genie_matrix_det; extern GPROC genie_matrix_div_real; extern GPROC genie_matrix_div_real_ab; extern GPROC genie_matrix_echo; extern GPROC genie_matrix_eq; extern GPROC genie_matrix_inv; extern GPROC genie_matrix_lu; extern GPROC genie_matrix_lu_det; extern GPROC genie_matrix_lu_inv; extern GPROC genie_matrix_lu_solve; extern GPROC genie_matrix_minus; extern GPROC genie_matrix_minusab; extern GPROC genie_matrix_ne; extern GPROC genie_matrix_plusab; extern GPROC genie_matrix_qr; extern GPROC genie_matrix_qr_ls_solve; extern GPROC genie_matrix_qr_solve; extern GPROC genie_matrix_scale_real; extern GPROC genie_matrix_scale_real_ab; extern GPROC genie_matrix_sub; extern GPROC genie_matrix_svd; extern GPROC genie_matrix_svd_solve; extern GPROC genie_matrix_times_matrix; extern GPROC genie_matrix_times_vector; extern GPROC genie_matrix_trace; extern GPROC genie_matrix_transpose; extern GPROC genie_prime_factors; extern GPROC genie_real_scale_matrix; extern GPROC genie_real_scale_vector; extern GPROC genie_vector_add; extern GPROC genie_vector_complex_add; extern GPROC genie_vector_complex_div_complex; extern GPROC genie_vector_complex_div_complex_ab; extern GPROC genie_vector_complex_dot; extern GPROC genie_vector_complex_dyad; extern GPROC genie_vector_complex_echo; extern GPROC genie_vector_complex_eq; extern GPROC genie_vector_complex_minus; extern GPROC genie_vector_complex_minusab; extern GPROC genie_vector_complex_ne; extern GPROC genie_vector_complex_norm; extern GPROC genie_vector_complex_plusab; extern GPROC genie_vector_complex_scale_complex; extern GPROC genie_vector_complex_scale_complex_ab; extern GPROC genie_vector_complex_sub; extern GPROC genie_vector_complex_times_matrix; extern GPROC genie_vector_div_real; extern GPROC genie_vector_div_real_ab; extern GPROC genie_vector_dot; extern GPROC genie_vector_dyad; extern GPROC genie_vector_echo; extern GPROC genie_vector_eq; extern GPROC genie_vector_minus; extern GPROC genie_vector_minusab; extern GPROC genie_vector_ne; extern GPROC genie_vector_norm; extern GPROC genie_vector_plusab; extern GPROC genie_vector_scale_real; extern GPROC genie_vector_scale_real_ab; extern GPROC genie_vector_sub; extern GPROC genie_vector_times_matrix; #endif #if defined HAVE_CURSES extern GPROC genie_curses_clear; extern GPROC genie_curses_del_char; extern GPROC genie_curses_green; extern GPROC genie_curses_cyan; extern GPROC genie_curses_white; extern GPROC genie_curses_red; extern GPROC genie_curses_yellow; extern GPROC genie_curses_magenta; extern GPROC genie_curses_blue; extern GPROC genie_curses_green_inverse; extern GPROC genie_curses_cyan_inverse; extern GPROC genie_curses_white_inverse; extern GPROC genie_curses_red_inverse; extern GPROC genie_curses_yellow_inverse; extern GPROC genie_curses_magenta_inverse; extern GPROC genie_curses_blue_inverse; extern GPROC genie_curses_columns; extern GPROC genie_curses_end; extern GPROC genie_curses_getchar; extern GPROC genie_curses_lines; extern GPROC genie_curses_move; extern GPROC genie_curses_putchar; extern GPROC genie_curses_refresh; extern GPROC genie_curses_start; #endif #if defined HAVE_POSTGRESQL extern GPROC genie_pq_backendpid; extern GPROC genie_pq_cmdstatus; extern GPROC genie_pq_cmdtuples; extern GPROC genie_pq_connectdb; extern GPROC genie_pq_db; extern GPROC genie_pq_errormessage; extern GPROC genie_pq_exec; extern GPROC genie_pq_fformat; extern GPROC genie_pq_finish; extern GPROC genie_pq_fname; extern GPROC genie_pq_fnumber; extern GPROC genie_pq_getisnull; extern GPROC genie_pq_getvalue; extern GPROC genie_pq_host; extern GPROC genie_pq_nfields; extern GPROC genie_pq_ntuples; extern GPROC genie_pq_options; extern GPROC genie_pq_parameterstatus; extern GPROC genie_pq_pass; extern GPROC genie_pq_port; extern GPROC genie_pq_protocolversion; extern GPROC genie_pq_reset; extern GPROC genie_pq_resulterrormessage; extern GPROC genie_pq_serverversion; extern GPROC genie_pq_socket; extern GPROC genie_pq_tty; extern GPROC genie_pq_user; #endif /********************/ /* Diagnostic texts */ /********************/ #define ERROR_ACCESSING_NIL "attempt to access N" #define ERROR_ALIGNMENT "alignment error" #define ERROR_ARGUMENT_NUMBER "incorrect number of arguments for M" #define ERROR_CANNOT_OPEN_NAME "cannot open Z" #define ERROR_CANNOT_WIDEN "cannot widen M to M" #define ERROR_CANNOT_WRITE_LISTING "cannot write listing file" #define ERROR_CHANNEL_DOES_NOT_ALLOW "channel does not allow Y" #define ERROR_CLAUSE_WITHOUT_VALUE "clause does not yield a value" #define ERROR_CLOSING_DEVICE "error while closing device" #define ERROR_CLOSING_FILE "error while closing file" #define ERROR_CODE "clause should be compiled" #define ERROR_COMMA_MUST_SEPARATE "A and A must be separated by a comma-symbol" #define ERROR_COMPONENT_NUMBER "M must have at least two components" #define ERROR_COMPONENT_RELATED "M has firmly related components" #define ERROR_CURSES "error in curses operation" #define ERROR_CURSES_OFF_SCREEN "curses operation moves cursor off the screen" #define ERROR_DEVICE_ALREADY_SET "device parameters already set" #define ERROR_DEVICE_CANNOT_ALLOCATE "cannot allocate device parameters" #define ERROR_DEVICE_CANNOT_OPEN "cannot open device" #define ERROR_DEVICE_NOT_OPEN "device is not open" #define ERROR_DEVICE_NOT_SET "device parameters not set" #define ERROR_DIFFERENT_BOUNDS "rows have different bounds" #define ERROR_DIVISION_BY_ZERO "attempt at M division by zero" #define ERROR_DYADIC_PRIORITY "dyadic S has no priority declaration" #define ERROR_EMPTY_ARGUMENT "empty argument" #define ERROR_EMPTY_VALUE "attempt to use an uninitialised M value" #define ERROR_EMPTY_VALUE_FROM (ERROR_EMPTY_VALUE) #define ERROR_EXPECTED "Y expected" #define ERROR_EXPECTED_NEAR "B expected in A, near Z L" #define ERROR_EXPONENT_DIGIT "invalid exponent digit" #define ERROR_EXPONENT_INVALID "invalid M exponent" #define ERROR_FALSE_ASSERTION "false assertion" #define ERROR_FFT "fourier transform error; U; U" #define ERROR_FILE_ACCESS "file access error" #define ERROR_FILE_ALREADY_OPEN "file is already open" #define ERROR_FILE_CANNOT_OPEN_FOR "cannot open Z for Y" #define ERROR_FILE_CANT_RESET "cannot reset file" #define ERROR_FILE_CANT_SET "cannot set file" #define ERROR_FILE_CLOSE "error while closing file" #define ERROR_FILE_ENDED "end of file reached" #define ERROR_FILE_INCLUDE_CTRL "control characters in include file" #define ERROR_FILE_LOCK "error while locking file" #define ERROR_FILE_NOT_OPEN "file is not open" #define ERROR_FILE_NO_TEMP "cannot create unique temporary file name" #define ERROR_FILE_READ "error while reading file" #define ERROR_FILE_RESET "error while resetting file" #define ERROR_FILE_SCRATCH "error while scratching file" #define ERROR_FILE_SET "error while setting file" #define ERROR_FILE_SOURCE_CTRL "control characters in source file" #define ERROR_FILE_TRANSPUT "error transputting M value" #define ERROR_FILE_TRANSPUT_SIGN "error transputting sign in M value" #define ERROR_FILE_WRONG_MOOD "file is in Y mood" #define ERROR_FORMAT_CANNOT_TRANSPUT "cannot transput M value with A" #define ERROR_FORMAT_EXHAUSTED "patterns exhausted in format" #define ERROR_FORMAT_INTS_REQUIRED "1 .. 3 M arguments required" #define ERROR_FORMAT_INVALID_REPLICATOR "negative replicator" #define ERROR_FORMAT_PICTURES "number of pictures does not match number of arguments" #define ERROR_FORMAT_PICTURE_NUMBER "incorrect number of pictures for A" #define ERROR_FORMAT_UNDEFINED "cannot use undefined format" #define ERROR_INCORRECT_FILENAME "incorrect filename" #define ERROR_INDEXER_NUMBER "incorrect number of indexers for M" #define ERROR_INDEX_OUT_OF_BOUNDS "index out of bounds" #define ERROR_INTERNAL_CONSISTENCY "internal consistency check failure" #define ERROR_INVALID_ARGUMENT "invalid M argument" #define ERROR_INVALID_DIMENSION "invalid dimension D" #define ERROR_INVALID_OPERAND "M construct is an invalid operand" #define ERROR_INVALID_OPERATOR_TAG "invalid operator tag" #define ERROR_INVALID_PARAMETER "invalid parameter (U Z)" #define ERROR_INVALID_PRIORITY "invalid priority declaration" #define ERROR_INVALID_RADIX "invalid radix D" #define ERROR_INVALID_SEQUENCE "U is not a valid A" #define ERROR_INVALID_SIZE "object of invalid size" #define ERROR_IN_DENOTATION "error in M denotation" #define ERROR_KEYWORD "check for missing or unmatched keyword in clause starting at S" #define ERROR_LABELED_UNIT_MUST_FOLLOW "S must be followed by a labeled unit" #define ERROR_LABEL_BEFORE_DECLARATION "declaration cannot follow a labeled unit" #define ERROR_LABEL_IN_PAR_CLAUSE "target label is in another parallel unit" #define ERROR_LAPLACE "laplace transform error; U; U" #define ERROR_LONG_STRING "string exceeds end of line" #define ERROR_MATH "M math error" #define ERROR_MATH_EXCEPTION "math exception E" #define ERROR_MODE_SPECIFICATION "M construct must yield a routine, row or structured value" #define ERROR_MP_OUT_OF_BOUNDS "multiprecision value out of bounds" #define ERROR_MULTIPLE_FIELD "multiple declaration of field S" #define ERROR_MULTIPLE_TAG "multiple declaration of tag S" #define ERROR_NOT_WELL_FORMED "M does not specify a well formed mode" #define ERROR_NO_COMPONENT "M is neither component nor subset of M" #define ERROR_NO_DYADIC "dyadic operator O S O has not been declared" #define ERROR_NO_FIELD "M has no field Z" #define ERROR_NO_FLEX_ARGUMENT "M value from A cannot be flexible" #define ERROR_NO_MATRIX "M A does not yield a two-dimensional row" #define ERROR_NO_MONADIC "monadic operator S O has not been declared" #define ERROR_NO_NAME "M A does not yield a name" #define ERROR_NO_NAME_REQUIRED "context does not require a name" #define ERROR_NO_PARALLEL_CLAUSE "interpreter was compiled without support for the parallel-clause" #define ERROR_NO_PRIORITY "S has no priority declaration" #define ERROR_NO_ROW_OR_PROC "M A does not yield a row or procedure" #define ERROR_NO_SOURCE_FILE "no source file specified" #define ERROR_NO_SQUARE_MATRIX "M matrix is not square" #define ERROR_NO_STRUCT "M A does not yield a structured value" #define ERROR_NO_UNION "M is not a united mode" #define ERROR_NO_UNIQUE_MODE "construct has no unique mode" #define ERROR_NO_VECTOR "M A does not yield a one-dimensional row" #define ERROR_OPERAND_NUMBER "incorrect number of operands for S" #define ERROR_OPERATOR_INVALID "monadic S cannot start with a character from Z" #define ERROR_OPERATOR_INVALID_END "probably missing symbol near invalid operator S" #define ERROR_OPERATOR_RELATED "M Z is firmly related to M Z" #define ERROR_OUT_OF_BOUNDS "M value out of bounds" #define ERROR_OUT_OF_CORE "insufficient memory" #define ERROR_PAGE_SIZE "error in page size" #define ERROR_PARALLEL_CANNOT_CREATE "cannot create thread" #define ERROR_PARALLEL_OUTSIDE "invalid outside a parallel clause" #define ERROR_PARALLEL_OVERFLOW "too many parallel units" #define ERROR_PARENTHESIS "incorrect parenthesis nesting; check for Y" #define ERROR_PARENTHESIS_2 "incorrect parenthesis nesting; encountered X L but expected X; check for Y" #define ERROR_PRAGMENT "error in pragment" #define ERROR_QUOTED_BOLD_TAG "error in quoted bold tag" #define ERROR_REDEFINED_KEYWORD "attempt to redefine keyword U in A" #define ERROR_REFINEMENT_APPLIED "refinement is applied more than once" #define ERROR_REFINEMENT_DEFINED "refinement already defined" #define ERROR_REFINEMENT_EMPTY "empty refinement at end of source" #define ERROR_REFINEMENT_INVALID "invalid refinement" #define ERROR_REFINEMENT_NOT_APPLIED "refinement is not applied" #define ERROR_SCOPE_DYNAMIC_0 "value is exported out of its scope" #define ERROR_SCOPE_DYNAMIC_1 "M value is exported out of its scope" #define ERROR_SCOPE_DYNAMIC_2 "M value from %s is exported out of its scope" #define ERROR_SHELL_SCRIPT "source is a shell script" #define ERROR_SOUND_INTERNAL "error while processing M value (Y)" #define ERROR_SOUND_INTERNAL_STRING "error while processing M value (Y \"Y\")" #define ERROR_SOURCE_FILE_OPEN "error while opening source file" #define ERROR_STACK_OVERFLOW "stack overflow" #define ERROR_SUBSET_RELATED "M has firmly related subset M" #define ERROR_SYNTAX "detected in A" #define ERROR_SYNTAX_EXPECTED "expected A" #define ERROR_SYNTAX_MIXED_DECLARATION "possibly mixed identity and variable declaration" #define ERROR_SYNTAX_STRANGE_SEPARATOR "possibly a missing or erroneous separator nearby" #define ERROR_SYNTAX_STRANGE_TOKENS "possibly a missing or erroneous symbol nearby" #define ERROR_TIME_LIMIT_EXCEEDED "time limit exceeded" #define ERROR_TOO_MANY_ARGUMENTS "too many arguments" #define ERROR_TOO_MANY_OPEN_FILES "too many open files" #define ERROR_TORRIX "linear algebra error; U; U" #define ERROR_TRANSIENT_NAME "attempt at storing a transient name" #define ERROR_UNBALANCED_KEYWORD "missing or unbalanced keyword in A, near Z L" #define ERROR_UNDECLARED_TAG "tag S has not been declared properly" #define ERROR_UNDECLARED_TAG_2 "tag Z has not been declared properly" #define ERROR_UNDEFINED_TRANSPUT "transput of M value by this procedure is not defined" #define ERROR_UNIMPLEMENTED "S is either not implemented or not compiled" #define ERROR_UNSPECIFIED "unspecified error" #define ERROR_UNTERMINATED_COMMENT "unterminated comment" #define ERROR_UNTERMINATED_PRAGMAT "unterminated pragmat" #define ERROR_UNTERMINATED_PRAGMENT "unterminated pragment" #define ERROR_UNTERMINATED_STRING "unterminated string" #define ERROR_UNWORTHY_CHARACTER "unworthy character" #define ERROR_VACUUM "vacuum cannot have row elements (use a U M generator)" #define INFO_APPROPRIATE_DECLARER "appropriate declarer" #define INFO_MISSING_KEYWORDS "missing or unmatched keyword" #define WARNING_EXTENSION "@ is an extension" #define WARNING_HIDES "declaration hides a declaration of S with larger reach" #define WARNING_HIDES_PRELUDE "declaration hides prelude declaration of M S" #define WARNING_OPTIMISATION "optimisation has no effect on this platform" #define WARNING_OVERFLOW "M constant overflow" #define WARNING_SCOPE_STATIC "M A is a potential scope violation" #define WARNING_SKIPPED_SUPERFLUOUS "skipped superfluous A" #define WARNING_TAG_NOT_PORTABLE "tag S is not portable" #define WARNING_TAG_UNUSED "tag S is not used" #define WARNING_TRAILING "ignoring trailing character H in A" #define WARNING_UNDERFLOW "M constant underflow" #define WARNING_UNINITIALISED "identifier S might be used before being initialised" #define WARNING_UNINTENDED "possibly unintended M A in M A" #define WARNING_VOIDED "value of M @ will be voided" #define WARNING_WIDENING_NOT_PORTABLE "implicit widening is not portable" #endif /* ! defined A68G_ALGOL68G_H */ extern A68_PROCEDURE on_gc_event; algol68g-2.4.1/source/mp.c0000644000175000001440000032035311770153020012140 00000000000000/*! \file mp.c \brief multiprecision arithmetic library */ /* This file is part of Algol68G - an Algol 68 interpreter. Copyright (C) 2001-2012 J. Marcel van der Veer . 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 MULTIPRECISION ARITHMETIC LIBRARY FOR ALGOL68G The question that is often raised is what applications justify multiprecision calculations. A number of applications, some of them practical, have surfaced over the years. Most common application of multiprecision calculations are numerically unstable calculations, that require many significant digits to arrive at a reliable result. Multiprecision calculations are used in "experimental mathematics". An increasingly important application of computers is in doing experiments on mathematical systems, when such system is not easily, or not at all, tractable by analysis. One important area of applications is in pure mathematics. Although numerical calculations cannot substitute a formal proof, calculations can be used to explore conjectures and reject those that are not sound, before a lengthy attempt at such proof is undertaken. Multiprecision calculations are especially useful in the study of mathematical constants. One of the oldest applications of multiprecision computation is to explore whether the expansions of classical constants such as "pi", "e" or "sqrt(2)" are random in some sense. For example, digits of "pi" have not shown statistical anomalies even now that billions of digits have been calculated. A practical application of multiprecision computation is the emerging field of public-key cryptography, that has spawned much research into advanced algorithms for factoring large integers. An indirect application of multiprecision computation is integrity testing. A unique feature of multiprecision calculations is that they are unforgiving of hardware, program or compiler error. Even a single computational error will almost certainly result in a completely incorrect outcome after a possibly correct start. The routines in this library follow algorithms as described in the literature, notably D.M. Smith, "Efficient Multiple-Precision Evaluation of Elementary Functions" Mathematics of Computation 52 (1989) 131-134 D.M. Smith, "A Multiple-Precision Division Algorithm" Mathematics of Computation 66 (1996) 157-163 There are multiprecision libraries (freely) available, but this one is particularly designed to work with Algol68G. It implements following modes: LONG INT, LONG REAL, LONG COMPLEX, LONG BITS LONG LONG INT, LONG LONG REAL, LONG LONG COMPLEX, LONG LONG BITS Currently, LONG modes have a fixed precision, and LONG LONG modes have user-definable precision. Precisions span about 30 decimal digits for LONG modes up to (default) about 60 decimal digits for LONG LONG modes, a range that is said to be adequate for most multiprecision applications. Although the maximum length of a mp number is unbound, this implementation is not particularly designed for more than about a thousand digits. It will work at higher precisions, but with a performance penalty with respect to state of the art implementations that may for instance use convolution for multiplication. This library takes a sloppy approach towards LONG INT and LONG BITS which are implemented as LONG REAL and truncated where appropriate. This keeps the code short at the penalty of some performance loss. As is common practice, mp numbers are represented by a row of digits in a large base. Layout of a mp number "z" is: MP_T *z; MP_STATUS (z) Status word MP_EXPONENT (z) Exponent with base MP_RADIX MP_DIGIT (z, 1 .. N) Digits 1 .. N Note that this library assumes IEEE 754 compatible implementation of type "double". It also assumes 32 (or 64) bit type "int". Most "vintage" multiple precision libraries stored numbers as [] int. However, since division and multiplication are O (N ** 2) operations, it is advantageous to keep the base as high as possible. Modern computers handle doubles at similar or better speed as integers, therefore this library opts for storing numbers as [] double, trading space for speed. This may change when 64 bit integers become commonplace. Set a base such that "base ** 2" can be exactly represented by "double". To facilitate transput, we require a base that is a power of 10. If we choose the base right then in multiplication and division we do not need to normalise intermediate results at each step since a number of additions can be made before overflow occurs. That is why we specify "MAX_REPR_INT". Mind that the precision of a mp number is at worst just (LONG_MP_DIGITS - 1) * LOG_MP_BASE + 1, since the most significant mp digit is also in range [0 .. MP_RADIX>. Do not specify less than 2 digits. Since this software is distributed without any warranty, it is your responsibility to validate the behaviour of the routines and their accuracy using the source code provided. See the GNU General Public License for details. */ #if defined HAVE_CONFIG_H #include "a68g-config.h" #endif #include "a68g.h" /* If DOUBLE_PRECISION is defined functions are evaluated in double precision */ #undef DOUBLE_PRECISION /* Internal mp constants */ static MP_T *ref_mp_pi = NO_MP; static int mp_pi_size = -1; static MP_T *ref_mp_ln_scale = NO_MP; static int mp_ln_scale_size = -1; static MP_T *ref_mp_ln_10 = NO_MP; static int mp_ln_10_size = -1; int varying_mp_digits = 10; static int _j1_, _j2_; #define MINIMUM(x, y) (_j1_ = (x), _j2_ = (y), _j1_ < _j2_ ? _j1_ : _j2_) /* GUARD_DIGITS: number of guard digits. In calculations using intermediate results we will use guard digits. We follow D.M. Smith in his recommendations for precisions greater than LONG. */ #if defined DOUBLE_PRECISION #define GUARD_DIGITS(digits) (digits) #else #define GUARD_DIGITS(digits) (((digits) == LONG_MP_DIGITS) ? 2 : (LOG_MP_BASE <= 5) ? 3 : 2) #endif #define FUN_DIGITS(n) ((n) + GUARD_DIGITS (n)) /*! \brief length in bytes of a long mp number \return length in bytes of a long mp number **/ size_t size_long_mp (void) { return ((size_t) SIZE_MP (LONG_MP_DIGITS)); } /*! \brief length in digits of a long mp number \return length in digits of a long mp number **/ int long_mp_digits (void) { return (LONG_MP_DIGITS); } /*! \brief length in bytes of a long long mp number \return length in bytes of a long long mp number **/ size_t size_longlong_mp (void) { return ((size_t) (SIZE_MP (varying_mp_digits))); } /*! \brief length in digits of a long long mp number \return length in digits of a long long mp number **/ int longlong_mp_digits (void) { return (varying_mp_digits); } /*! \brief length in digits of mode \param m mode \return length in digits of mode m **/ int get_mp_digits (MOID_T * m) { if (m == MODE (LONG_INT) || m == MODE (LONG_REAL) || m == MODE (LONG_COMPLEX) || m == MODE (LONG_BITS)) { return (long_mp_digits ()); } else if (m == MODE (LONGLONG_INT) || m == MODE (LONGLONG_REAL) || m == MODE (LONGLONG_COMPLEX) || m == MODE (LONGLONG_BITS)) { return (longlong_mp_digits ()); } return (0); } /*! \brief length in bytes of mode \param m mode \return length in bytes of mode m **/ int get_mp_size (MOID_T * m) { if (m == MODE (LONG_INT) || m == MODE (LONG_REAL) || m == MODE (LONG_COMPLEX) || m == MODE (LONG_BITS)) { return ((int) size_long_mp ()); } else if (m == MODE (LONGLONG_INT) || m == MODE (LONGLONG_REAL) || m == MODE (LONGLONG_COMPLEX) || m == MODE (LONGLONG_BITS)) { return ((int) size_longlong_mp ()); } return (0); } /*! \brief length in bits of mode \param m mode \return length in bits of mode m **/ int get_mp_bits_width (MOID_T * m) { if (m == MODE (LONG_BITS)) { return (MP_BITS_WIDTH (LONG_MP_DIGITS)); } else if (m == MODE (LONGLONG_BITS)) { return (MP_BITS_WIDTH (varying_mp_digits)); } return (0); } /*! \brief length in words of mode \param m mode \return length in words of mode m **/ int get_mp_bits_words (MOID_T * m) { if (m == MODE (LONG_BITS)) { return (MP_BITS_WORDS (LONG_MP_DIGITS)); } else if (m == MODE (LONGLONG_BITS)) { return (MP_BITS_WORDS (varying_mp_digits)); } return (0); } /*! \brief whether z is a valid LONG INT \param z mp number \return same **/ BOOL_T check_long_int (MP_T * z) { return ((BOOL_T) ((MP_EXPONENT (z) >= (MP_T) 0) && (MP_EXPONENT (z) < (MP_T) LONG_MP_DIGITS))); } /*! \brief whether z is a valid LONG LONG INT \param z mp number \return same **/ BOOL_T check_longlong_int (MP_T * z) { return ((BOOL_T) ((MP_EXPONENT (z) >= (MP_T) 0) && (MP_EXPONENT (z) < (MP_T) varying_mp_digits))); } /*! \brief whether z is a valid representation for its mode \param z mp number \param m mode \return same **/ BOOL_T check_mp_int (MP_T * z, MOID_T * m) { if (m == MODE (LONG_INT) || m == MODE (LONG_BITS)) { return (check_long_int (z)); } else if (m == MODE (LONGLONG_INT) || m == MODE (LONGLONG_BITS)) { return (check_longlong_int (z)); } return (A68_FALSE); } /*! \brief convert precision to digits for long long number \param n precision to convert \return same **/ int int_to_mp_digits (int n) { return (2 + (int) ceil ((double) n / (double) LOG_MP_BASE)); } /*! \brief set number of digits for long long numbers \param n number of digits **/ void set_longlong_mp_digits (int n) { varying_mp_digits = n; } /*! \brief set "z" to short value x * MP_RADIX ** x_expo \param z mp number to set \param x most significant mp digit \param x_expo mp exponent \param digits precision in mp-digits \return result "z" **/ MP_T *set_mp_short (MP_T * z, MP_T x, int x_expo, int digits) { MP_T *d = &MP_DIGIT ((z), 2); MP_STATUS (z) = (MP_T) INIT_MASK; MP_EXPONENT (z) = (MP_T) x_expo; MP_DIGIT (z, 1) = (MP_T) x; while (--digits) { *d++ = (MP_T) 0; } return (z); } /*! \brief test whether x = y \param p position in tree \param x mp number 1 \param y mp number 2 \param digits precision in mp-digits \return same **/ static BOOL_T same_mp (NODE_T * p, MP_T * x, MP_T * y, int digits) { int k; (void) p; if (MP_EXPONENT (x) == MP_EXPONENT (y)) { for (k = digits; k >= 1; k--) { if (MP_DIGIT (x, k) != MP_DIGIT (y, k)) { return (A68_FALSE); } } return (A68_TRUE); } else { return (A68_FALSE); } } /*! \brief align 10-base z in a MP_RADIX mantissa \param z mp number \param expo \param digits precision in mp-digits \return result "z" **/ static MP_T *align_mp (MP_T * z, int *expo, int digits) { int i, shift; if (*expo >= 0) { shift = LOG_MP_BASE - *expo % LOG_MP_BASE - 1; *expo /= LOG_MP_BASE; } else { shift = (-*expo - 1) % LOG_MP_BASE; *expo = (*expo + 1) / LOG_MP_BASE; (*expo)--; } /* Now normalise "z" */ for (i = 1; i <= shift; i++) { int j, carry = 0; for (j = 1; j <= digits; j++) { int k = (int) MP_DIGIT (z, j) % 10; MP_DIGIT (z, j) = (MP_T) ((int) (MP_DIGIT (z, j) / 10) + carry * (MP_RADIX / 10)); carry = k; } } return (z); } /*! \brief transform string into multi-precision number \param p position in tree \param z mp number \param s string to convert \param digits precision in mp-digits \return result "z" **/ MP_T *string_to_mp (NODE_T * p, MP_T * z, char *s, int digits) { int i, j, sign, weight, sum, comma, power; int expo; BOOL_T ok = A68_TRUE; RESET_ERRNO; SET_MP_ZERO (z, digits); while (IS_SPACE (s[0])) { s++; } /* Get the sign */ sign = (s[0] == '-' ? -1 : 1); if (s[0] == '+' || s[0] == '-') { s++; } /* Scan mantissa digits and put them into "z" */ while (s[0] == '0') { s++; } i = 0; j = 1; sum = 0; comma = -1; power = 0; weight = MP_RADIX / 10; while (s[i] != NULL_CHAR && j <= digits && (IS_DIGIT (s[i]) || s[i] == POINT_CHAR)) { if (s[i] == POINT_CHAR) { comma = i; } else { int value = (int) s[i] - (int) '0'; sum += weight * value; weight /= 10; power++; if (weight < 1) { MP_DIGIT (z, j++) = (MP_T) sum; sum = 0; weight = MP_RADIX / 10; } } i++; } /* Store the last digits */ if (j <= digits) { MP_DIGIT (z, j++) = (MP_T) sum; } /* See if there is an exponent */ expo = 0; if (s[i] != NULL_CHAR && TO_UPPER (s[i]) == TO_UPPER (EXPONENT_CHAR)) { char *end; expo = (int) strtol (&(s[++i]), &end, 10); ok = (BOOL_T) (end[0] == NULL_CHAR); } else { ok = (BOOL_T) (s[i] == NULL_CHAR); } /* Calculate effective exponent */ expo += (comma >= 0 ? comma - 1 : power - 1); (void) align_mp (z, &expo, digits); MP_EXPONENT (z) = (MP_DIGIT (z, 1) == 0 ? 0 : (double) expo); MP_DIGIT (z, 1) *= sign; CHECK_MP_EXPONENT (p, z); if (errno == 0 && ok) { return (z); } else { return (NO_MP); } } /*! \brief convert integer to multi-precison number \param p position in tree \param z mp number \param k integer to convert \param digits precision in mp-digits \return result "z" **/ MP_T *int_to_mp (NODE_T * p, MP_T * z, int k, int digits) { int n = 0, j, sign_k = SIGN (k); int k2 = k; if (k < 0) { k = -k; } while ((k2 /= MP_RADIX) != 0) { n++; } SET_MP_ZERO (z, digits); MP_EXPONENT (z) = (MP_T) n; for (j = 1 + n; j >= 1; j--) { MP_DIGIT (z, j) = (MP_T) (k % MP_RADIX); k /= MP_RADIX; } MP_DIGIT (z, 1) = sign_k * MP_DIGIT (z, 1); CHECK_MP_EXPONENT (p, z); return (z); } /*! \brief convert unsigned to multi-precison number \param p position in tree \param z mp number \param k unsigned to convert \param digits precision in mp-digits \return result "z" **/ MP_T *unsigned_to_mp (NODE_T * p, MP_T * z, unsigned k, int digits) { int n = 0, j; unsigned k2 = k; while ((k2 /= MP_RADIX) != 0) { n++; } SET_MP_ZERO (z, digits); MP_EXPONENT (z) = (MP_T) n; for (j = 1 + n; j >= 1; j--) { MP_DIGIT (z, j) = (MP_T) (k % MP_RADIX); k /= MP_RADIX; } CHECK_MP_EXPONENT (p, z); return (z); } /*! \brief convert multi-precision number to integer \param p position in tree \param z mp number \param digits precision in mp-digits \return result "z" **/ int mp_to_int (NODE_T * p, MP_T * z, int digits) { /* This routines looks a lot like "strtol". We do not use "mp_to_real" since int could be wider than 2 ** 52. */ int j, expo = (int) MP_EXPONENT (z); int sum = 0, weight = 1; BOOL_T negative; if (expo >= digits) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_OUT_OF_BOUNDS, MOID (p)); exit_genie (p, A68_RUNTIME_ERROR); } negative = (BOOL_T) (MP_DIGIT (z, 1) < 0); if (negative) { MP_DIGIT (z, 1) = -MP_DIGIT (z, 1); } for (j = 1 + expo; j >= 1; j--) { int term; if ((int) MP_DIGIT (z, j) > A68_MAX_INT / weight) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_OUT_OF_BOUNDS, MODE (INT)); exit_genie (p, A68_RUNTIME_ERROR); } term = (int) MP_DIGIT (z, j) * weight; if (sum > A68_MAX_INT - term) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_OUT_OF_BOUNDS, MODE (INT)); exit_genie (p, A68_RUNTIME_ERROR); } sum += term; weight *= MP_RADIX; } return (negative ? -sum : sum); } /*! \brief convert multi-precision number to unsigned \param p position in tree \param z mp number \param digits precision in mp-digits \return result "z" **/ unsigned mp_to_unsigned (NODE_T * p, MP_T * z, int digits) { /* This routines looks a lot like "strtol". We do not use "mp_to_real" since int could be wider than 2 ** 52. */ int j, expo = (int) MP_EXPONENT (z); unsigned sum = 0, weight = 1; if (expo >= digits) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_OUT_OF_BOUNDS, MOID (p)); exit_genie (p, A68_RUNTIME_ERROR); } for (j = 1 + expo; j >= 1; j--) { unsigned term; if ((unsigned) MP_DIGIT (z, j) > A68_MAX_UNT / weight) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_OUT_OF_BOUNDS, MODE (BITS)); exit_genie (p, A68_RUNTIME_ERROR); } term = (unsigned) MP_DIGIT (z, j) * weight; if (sum > A68_MAX_UNT - term) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_OUT_OF_BOUNDS, MODE (BITS)); exit_genie (p, A68_RUNTIME_ERROR); } sum += term; weight *= MP_RADIX; } return (sum); } /*! \brief convert double to multi-precison number \param p position in tree \param z mp number \param x mp number \param digits precision in mp-digits \return result "z" **/ MP_T *real_to_mp (NODE_T * p, MP_T * z, double x, int digits) { int j, k, sign_x, sum, weight; int expo; double a; MP_T *u; SET_MP_ZERO (z, digits); if (x == 0.0) { return (z); } /* Small integers can be done better by int_to_mp */ if (ABS (x) < MP_RADIX && (double) (int) x == x) { return (int_to_mp (p, z, (int) x, digits)); } sign_x = SIGN (x); /* Scale to [0, 0.1> */ a = x = ABS (x); expo = (int) log10 (a); a /= ten_up (expo); expo--; if (a >= 1) { a /= 10; expo++; } /* Transport digits of x to the mantissa of z */ k = 0; j = 1; sum = 0; weight = (MP_RADIX / 10); u = &MP_DIGIT (z, 1); while (j <= digits && k < DBL_DIG) { double y = floor (a * 10); int value = (int) y; a = a * 10 - y; sum += weight * value; weight /= 10; if (weight < 1) { (u++)[0] = (MP_T) sum; sum = 0; weight = (MP_RADIX / 10); } k++; } /* Store the last digits */ if (j <= digits) { u[0] = (MP_T) sum; } (void) align_mp (z, &expo, digits); MP_EXPONENT (z) = (MP_T) expo; MP_DIGIT (z, 1) *= sign_x; CHECK_MP_EXPONENT (p, z); return (z); } /*! \brief convert multi-precision number to double \param p position in tree \param z mp number \param digits precision in mp-digits \return result "z" **/ double mp_to_real (NODE_T * p, MP_T * z, int digits) { /* This routine looks a lot like "strtod" */ (void) p; if (MP_EXPONENT (z) * (MP_T) LOG_MP_BASE <= (MP_T) DBL_MIN_10_EXP) { return (0); } else { int j; double sum = 0, weight; weight = ten_up ((int) (MP_EXPONENT (z) * LOG_MP_BASE)); for (j = 1; j <= digits && (j - 2) * LOG_MP_BASE <= DBL_DIG; j++) { sum += ABS (MP_DIGIT (z, j)) * weight; weight /= MP_RADIX; } CHECK_REAL_REPRESENTATION (p, sum); return (MP_DIGIT (z, 1) >= 0 ? sum : -sum); } } /*! \brief convert z to a row of unsigned in the stack \param p position in tree \param z mp number \param m mode of "z" \return result "z" **/ unsigned *stack_mp_bits (NODE_T * p, MP_T * z, MOID_T * m) { int digits = get_mp_digits (m), words = get_mp_bits_words (m), k, lim; unsigned *row, mask; MP_T *u, *v, *w; row = (unsigned *) STACK_ADDRESS (stack_pointer); INCREMENT_STACK_POINTER (p, words * ALIGNED_SIZE_OF (unsigned)); STACK_MP (u, p, digits); STACK_MP (v, p, digits); STACK_MP (w, p, digits); MOVE_MP (u, z, digits); /* Argument check */ if (MP_DIGIT (u, 1) < 0.0) { errno = EDOM; diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_OUT_OF_BOUNDS, (m == MODE (LONG_BITS) ? MODE (LONG_INT) : MODE (LONGLONG_INT))); exit_genie (p, A68_RUNTIME_ERROR); } /* Convert radix MP_BITS_RADIX number */ for (k = words - 1; k >= 0; k--) { MOVE_MP (w, u, digits); (void) over_mp_digit (p, u, u, (MP_T) MP_BITS_RADIX, digits); (void) mul_mp_digit (p, v, u, (MP_T) MP_BITS_RADIX, digits); (void) sub_mp (p, v, w, v, digits); row[k] = (unsigned) MP_DIGIT (v, 1); } /* Test on overflow: too many bits or not reduced to 0 */ mask = 0x1; lim = get_mp_bits_width (m) % MP_BITS_BITS; for (k = 1; k < lim; k++) { mask <<= 1; mask |= 0x1; } if ((row[0] & ~mask) != 0x0 || MP_DIGIT (u, 1) != 0.0) { errno = ERANGE; diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_OUT_OF_BOUNDS, m); exit_genie (p, A68_RUNTIME_ERROR); } /* Exit */ return (row); } /*! \brief whether LONG BITS value is in range \param p position in tree \param u mp number \param m mode of "u" **/ void check_long_bits_value (NODE_T * p, MP_T * u, MOID_T * m) { if (MP_EXPONENT (u) >= (MP_T) (get_mp_digits (m) - 1)) { ADDR_T pop_sp = stack_pointer; (void) stack_mp_bits (p, u, m); stack_pointer = pop_sp; } } /*! \brief convert row of unsigned to LONG BITS \param p position in tree \param u mp number \param row \param m mode of "u" \return result "u" **/ MP_T *pack_mp_bits (NODE_T * p, MP_T * u, unsigned *row, MOID_T * m) { int digits = get_mp_digits (m), words = get_mp_bits_words (m), k, lim; ADDR_T pop_sp = stack_pointer; MP_T *v, *w; /* Discard excess bits */ unsigned mask = 0x1, musk = 0x0; STACK_MP (v, p, digits); STACK_MP (w, p, digits); lim = get_mp_bits_width (m) % MP_BITS_BITS; for (k = 1; k < lim; k++) { mask <<= 1; mask |= 0x1; } row[0] &= mask; for (k = 1; k < (BITS_WIDTH - MP_BITS_BITS); k++) { musk <<= 1; } for (k = 0; k < MP_BITS_BITS; k++) { musk <<= 1; musk |= 0x1; } /* Convert */ SET_MP_ZERO (u, digits); (void) set_mp_short (v, (MP_T) 1, 0, digits); for (k = words - 1; k >= 0; k--) { (void) mul_mp_digit (p, w, v, (MP_T) (musk & row[k]), digits); (void) add_mp (p, u, u, w, digits); if (k != 0) { (void) mul_mp_digit (p, v, v, (MP_T) MP_BITS_RADIX, digits); } } MP_STATUS (u) = (MP_T) INIT_MASK; stack_pointer = pop_sp; return (u); } /*! \brief normalise positive intermediate, fast \param w argument \param k last digit to normalise \param digits precision in mp-digits **/ static void norm_mp_light (MP_T * w, int k, int digits) { /* Bring every digit back to [0 .. MP_RADIX> */ int j; MP_T *z; for (j = digits, z = &MP_DIGIT (w, digits); j >= k; j--, z--) { if (z[0] >= MP_RADIX) { z[0] -= (MP_T) MP_RADIX; z[-1] += 1; } else if (z[0] < 0) { z[0] += (MP_T) MP_RADIX; z[-1] -= 1; } } } /*! \brief normalise positive intermediate \param w argument \param k last digit to normalise \param digits precision in mp-digits **/ static void norm_mp (MP_T * w, int k, int digits) { /* Bring every digit back to [0 .. MP_RADIX> */ int j; MP_T *z; for (j = digits, z = &MP_DIGIT (w, digits); j >= k; j--, z--) { if (z[0] >= (MP_T) MP_RADIX) { MP_T carry = (MP_T) ((int) (z[0] / (MP_T) MP_RADIX)); z[0] -= carry * (MP_T) MP_RADIX; z[-1] += carry; } else if (z[0] < (MP_T) 0) { MP_T carry = (MP_T) 1 + (MP_T) ((int) ((-z[0] - 1) / (MP_T) MP_RADIX)); z[0] += carry * (MP_T) MP_RADIX; z[-1] -= carry; } } } /*! \brief round multi-precision number \param z result \param w argument, must be positive \param digits precision in mp-digits **/ static void round_internal_mp (MP_T * z, MP_T * w, int digits) { /* Assume that w has precision of at least 2 + digits */ int last = (MP_DIGIT (w, 1) == 0 ? 2 + digits : 1 + digits); if (MP_DIGIT (w, last) >= MP_RADIX / 2) { MP_DIGIT (w, last - 1) += 1; } if (MP_DIGIT (w, last - 1) >= MP_RADIX) { norm_mp (w, 2, last); } if (MP_DIGIT (w, 1) == 0) { MOVE_DIGITS (&MP_DIGIT (z, 1), &MP_DIGIT (w, 2), digits); MP_EXPONENT (z) = MP_EXPONENT (w) - 1; } else { /* Normally z != w, so no test on this */ MOVE_DIGITS (&MP_EXPONENT (z), &MP_EXPONENT (w), (1 + digits)); } /* Zero is zero is zero */ if (MP_DIGIT (z, 1) == 0) { MP_EXPONENT (z) = (MP_T) 0; } } /*! \brief truncate at decimal point \param p position in tree \param z result \param x argument \param digits precision in mp-digits **/ void trunc_mp (NODE_T * p, MP_T * z, MP_T * x, int digits) { if (MP_EXPONENT (x) < 0) { SET_MP_ZERO (z, digits); } else if (MP_EXPONENT (x) >= (MP_T) digits) { errno = EDOM; diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_OUT_OF_BOUNDS, (IS (MOID (p), PROC_SYMBOL) ? SUB_MOID (p) : MOID (p))); exit_genie (p, A68_RUNTIME_ERROR); } else { int k; MOVE_MP (z, x, digits); for (k = (int) (MP_EXPONENT (x) + 2); k <= digits; k++) { MP_DIGIT (z, k) = (MP_T) 0; } } } /*! \brief shorten and round \param p position in tree \param z result \param digits precision in mp-digits \param x mp number \param digits precision in mp-digits_x \return result "z" **/ MP_T *shorten_mp (NODE_T * p, MP_T * z, int digits, MP_T * x, int digits_x) { if (digits >= digits_x) { errno = EDOM; return (NO_MP); } else { /* Reserve extra digits for proper rounding */ int pop_sp = stack_pointer, digits_h = digits + 2; MP_T *w; BOOL_T negative = (BOOL_T) (MP_DIGIT (x, 1) < 0); STACK_MP (w, p, digits_h); if (negative) { MP_DIGIT (x, 1) = -MP_DIGIT (x, 1); } MP_STATUS (w) = (MP_T) 0; MP_EXPONENT (w) = MP_EXPONENT (x) + 1; MP_DIGIT (w, 1) = (MP_T) 0; MOVE_DIGITS (&MP_DIGIT (w, 2), &MP_DIGIT (x, 1), digits + 1); round_internal_mp (z, w, digits); if (negative) { MP_DIGIT (z, 1) = -MP_DIGIT (z, 1); } stack_pointer = pop_sp; return (z); } } /*! \brief lengthen x and assign to z \param p position in tree \param z mp number \param digits precision in mp-digits of "z" \param x mp number \param digits precision in mp-digits of "x" \return result "z" **/ MP_T *lengthen_mp (NODE_T * p, MP_T * z, int digits_z, MP_T * x, int digits_x) { int j; (void) p; if (digits_z > digits_x) { if (z != x) { MOVE_DIGITS (&MP_DIGIT (z, 1), &MP_DIGIT (x, 1), digits_x); MP_EXPONENT (z) = MP_EXPONENT (x); MP_STATUS (z) = MP_STATUS (x); } for (j = 1 + digits_x; j <= digits_z; j++) { MP_DIGIT (z, j) = (MP_T) 0; } } return (z); } /*! \brief set "z" to the sum of positive "x" and positive "y" \param p position in tree \param z mp number \param x mp number \param y mp number \param digits precision in mp-digits \return result "z" **/ MP_T *add_mp (NODE_T * p, MP_T * z, MP_T * x, MP_T * y, int digits) { ADDR_T pop_sp = stack_pointer; MP_T *w, z_1, x_1 = MP_DIGIT (x, 1), y_1 = MP_DIGIT (y, 1); MP_STATUS (z) = (MP_T) INIT_MASK; /* Trivial cases */ if (MP_DIGIT (x, 1) == (MP_T) 0) { MOVE_MP (z, y, digits); return (z); } else if (MP_DIGIT (y, 1) == 0) { MOVE_MP (z, x, digits); return (z); } /* We want positive arguments */ MP_DIGIT (x, 1) = ABS (x_1); MP_DIGIT (y, 1) = ABS (y_1); if (x_1 >= 0 && y_1 < 0) { (void) sub_mp (p, z, x, y, digits); } else if (x_1 < 0 && y_1 >= 0) { (void) sub_mp (p, z, y, x, digits); } else if (x_1 < 0 && y_1 < 0) { (void) add_mp (p, z, x, y, digits); MP_DIGIT (z, 1) = -MP_DIGIT (z, 1); } else { /* Add */ int j, digits_h = 2 + digits; STACK_MP (w, p, digits_h); MP_DIGIT (w, 1) = (MP_T) 0; if (MP_EXPONENT (x) == MP_EXPONENT (y)) { MP_EXPONENT (w) = (MP_T) 1 + MP_EXPONENT (x); for (j = 1; j <= digits; j++) { MP_DIGIT (w, j + 1) = MP_DIGIT (x, j) + MP_DIGIT (y, j); } MP_DIGIT (w, digits_h) = (MP_T) 0; } else if (MP_EXPONENT (x) > MP_EXPONENT (y)) { int shl_y = (int) MP_EXPONENT (x) - (int) MP_EXPONENT (y); MP_EXPONENT (w) = (MP_T) 1 + MP_EXPONENT (x); for (j = 1; j < digits_h; j++) { int i_y = j - (int) shl_y; MP_T x_j = (j > digits ? 0 : MP_DIGIT (x, j)); MP_T y_j = (i_y <= 0 || i_y > digits ? 0 : MP_DIGIT (y, i_y)); MP_DIGIT (w, j + 1) = x_j + y_j; } } else { int shl_x = (int) MP_EXPONENT (y) - (int) MP_EXPONENT (x); MP_EXPONENT (w) = (MP_T) 1 + MP_EXPONENT (y); for (j = 1; j < digits_h; j++) { int i_x = j - (int) shl_x; MP_T x_j = (i_x <= 0 || i_x > digits ? 0 : MP_DIGIT (x, i_x)); MP_T y_j = (j > digits ? 0 : MP_DIGIT (y, j)); MP_DIGIT (w, j + 1) = x_j + y_j; } } norm_mp_light (w, 2, digits_h); round_internal_mp (z, w, digits); CHECK_MP_EXPONENT (p, z); } /* Restore and exit */ stack_pointer = pop_sp; z_1 = MP_DIGIT (z, 1); MP_DIGIT (x, 1) = x_1; MP_DIGIT (y, 1) = y_1; MP_DIGIT (z, 1) = z_1; /* In case z IS x OR z IS y */ return (z); } /*! \brief set "z" to the difference of positive "x" and positive "y" \param p position in tree \param z mp number \param x mp number \param y mp number \param digits precision in mp-digits \return result "z" **/ MP_T *sub_mp (NODE_T * p, MP_T * z, MP_T * x, MP_T * y, int digits) { ADDR_T pop_sp = stack_pointer; int fnz, k; MP_T *w, z_1, x_1 = MP_DIGIT (x, 1), y_1 = MP_DIGIT (y, 1); BOOL_T negative = A68_FALSE; MP_STATUS (z) = (MP_T) INIT_MASK; /* Trivial cases */ if (MP_DIGIT (x, 1) == (MP_T) 0) { MOVE_MP (z, y, digits); MP_DIGIT (z, 1) = -MP_DIGIT (z, 1); return (z); } else if (MP_DIGIT (y, 1) == (MP_T) 0) { MOVE_MP (z, x, digits); return (z); } MP_DIGIT (x, 1) = ABS (x_1); MP_DIGIT (y, 1) = ABS (y_1); /* We want positive arguments */ if (x_1 >= 0 && y_1 < 0) { (void) add_mp (p, z, x, y, digits); } else if (x_1 < 0 && y_1 >= 0) { (void) add_mp (p, z, y, x, digits); MP_DIGIT (z, 1) = -MP_DIGIT (z, 1); } else if (x_1 < 0 && y_1 < 0) { (void) sub_mp (p, z, y, x, digits); } else { /* Subtract */ int j, digits_h = 2 + digits; STACK_MP (w, p, digits_h); MP_DIGIT (w, 1) = (MP_T) 0; if (MP_EXPONENT (x) == MP_EXPONENT (y)) { MP_EXPONENT (w) = (MP_T) 1 + MP_EXPONENT (x); for (j = 1; j <= digits; j++) { MP_DIGIT (w, j + 1) = MP_DIGIT (x, j) - MP_DIGIT (y, j); } MP_DIGIT (w, digits_h) = (MP_T) 0; } else if (MP_EXPONENT (x) > MP_EXPONENT (y)) { int shl_y = (int) MP_EXPONENT (x) - (int) MP_EXPONENT (y); MP_EXPONENT (w) = (MP_T) 1 + MP_EXPONENT (x); for (j = 1; j < digits_h; j++) { int i_y = j - (int) shl_y; MP_T x_j = (j > digits ? 0 : MP_DIGIT (x, j)); MP_T y_j = (i_y <= 0 || i_y > digits ? 0 : MP_DIGIT (y, i_y)); MP_DIGIT (w, j + 1) = x_j - y_j; } } else { int shl_x = (int) MP_EXPONENT (y) - (int) MP_EXPONENT (x); MP_EXPONENT (w) = (MP_T) 1 + MP_EXPONENT (y); for (j = 1; j < digits_h; j++) { int i_x = j - (int) shl_x; MP_T x_j = (i_x <= 0 || i_x > digits ? 0 : MP_DIGIT (x, i_x)); MP_T y_j = (j > digits ? 0 : MP_DIGIT (y, j)); MP_DIGIT (w, j + 1) = x_j - y_j; } } /* Correct if we subtract large from small */ if (MP_DIGIT (w, 2) <= 0) { fnz = -1; for (j = 2; j <= digits_h && fnz < 0; j++) { if (MP_DIGIT (w, j) != 0) { fnz = j; } } negative = (BOOL_T) (MP_DIGIT (w, fnz) < 0); if (negative) { for (j = fnz; j <= digits_h; j++) { MP_DIGIT (w, j) = -MP_DIGIT (w, j); } } } /* Normalise */ norm_mp_light (w, 2, digits_h); fnz = -1; for (j = 1; j <= digits_h && fnz < 0; j++) { if (MP_DIGIT (w, j) != 0) { fnz = j; } } if (fnz > 1) { int j2 = fnz - 1; for (k = 1; k <= digits_h - j2; k++) { MP_DIGIT (w, k) = MP_DIGIT (w, k + j2); MP_DIGIT (w, k + j2) = (MP_T) 0; } MP_EXPONENT (w) -= j2; } /* Round */ round_internal_mp (z, w, digits); if (negative) { MP_DIGIT (z, 1) = -MP_DIGIT (z, 1); } CHECK_MP_EXPONENT (p, z); } /* Restore and exit */ stack_pointer = pop_sp; z_1 = MP_DIGIT (z, 1); MP_DIGIT (x, 1) = x_1; MP_DIGIT (y, 1) = y_1; MP_DIGIT (z, 1) = z_1; /* In case z IS x OR z IS y */ return (z); } /*! \brief set "z" to the product of "x" and "y" \param p position in tree \param z mp number \param x mp number \param y mp number \param digits precision in mp-digits \return result "z" **/ MP_T *mul_mp (NODE_T * p, MP_T * z, MP_T * x, MP_T * y, int digits) { MP_T *w, z_1, x_1 = MP_DIGIT (x, 1), y_1 = MP_DIGIT (y, 1); int i, oflow, digits_h = 2 + digits; ADDR_T pop_sp = stack_pointer; MP_DIGIT (x, 1) = ABS (x_1); MP_DIGIT (y, 1) = ABS (y_1); MP_STATUS (z) = (MP_T) INIT_MASK; if (x_1 == 0 || y_1 == 0) { stack_pointer = pop_sp; MP_DIGIT (x, 1) = x_1; MP_DIGIT (y, 1) = y_1; SET_MP_ZERO (z, digits); return (z); } /* Calculate z = x * y */ STACK_MP (w, p, digits_h); SET_MP_ZERO (w, digits_h); MP_EXPONENT (w) = MP_EXPONENT (x) + MP_EXPONENT (y) + 1; oflow = (int) (floor) ((double) MAX_REPR_INT / (2 * (double) MP_RADIX * (double) MP_RADIX)) - 1; ABEND (oflow <= 1, "inadequate MP_RADIX", NO_TEXT); if (digits < oflow) { for (i = digits; i >= 1; i--) { MP_T yi = MP_DIGIT (y, i); if (yi != 0) { int k = digits_h - i; int j = (k > digits ? digits : k); MP_T *u = &MP_DIGIT (w, i + j); MP_T *v = &MP_DIGIT (x, j); while (j-- >= 1) { (u--)[0] += yi * (v--)[0]; } } } } else { for (i = digits; i >= 1; i--) { MP_T yi = MP_DIGIT (y, i); if (yi != 0) { int k = digits_h - i; int j = (k > digits ? digits : k); MP_T *u = &MP_DIGIT (w, i + j); MP_T *v = &MP_DIGIT (x, j); if ((digits - i + 1) % oflow == 0) { norm_mp (w, 2, digits_h); } while (j-- >= 1) { (u--)[0] += yi * (v--)[0]; } } } } norm_mp (w, 2, digits_h); round_internal_mp (z, w, digits); /* Restore and exit */ stack_pointer = pop_sp; z_1 = MP_DIGIT (z, 1); MP_DIGIT (x, 1) = x_1; MP_DIGIT (y, 1) = y_1; MP_DIGIT (z, 1) = ((x_1 * y_1) >= 0 ? z_1 : -z_1); CHECK_MP_EXPONENT (p, z); return (z); } /*! \brief set "z" to the quotient of "x" and "y" \param p position in tree \param z mp number \param x mp number \param y mp number \param digits precision in mp-digits \return result "z" **/ MP_T *div_mp (NODE_T * p, MP_T * z, MP_T * x, MP_T * y, int digits) { /* This routine is an implementation of D. M. Smith, "A Multiple-Precision Division Algorithm" Mathematics of Computation 66 (1996) 157-163. This algorithm is O(N ** 2) but runs faster than straightforward methods by skipping most of the intermediate normalisation and recovering from wrong guesses without separate correction steps. */ double xd; MP_T *t, *w, z_1, x_1 = MP_DIGIT (x, 1), y_1 = MP_DIGIT (y, 1); int k, oflow, digits_w = 4 + digits; ADDR_T pop_sp = stack_pointer; if (y_1 == 0) { errno = ERANGE; return (NO_MP); } /* Determine normalisation interval assuming that q < 2b in each step */ oflow = (int) (floor) ((double) MAX_REPR_INT / (3 * (double) MP_RADIX * (double) MP_RADIX)) - 1; ABEND (oflow <= 1, "inadequate MP_RADIX", NO_TEXT); MP_DIGIT (x, 1) = ABS (x_1); MP_DIGIT (y, 1) = ABS (y_1); MP_STATUS (z) = (MP_T) INIT_MASK; /* `w' will be the working nominator in which the quotient develops */ STACK_MP (w, p, digits_w); MP_EXPONENT (w) = MP_EXPONENT (x) - MP_EXPONENT (y); MP_DIGIT (w, 1) = (MP_T) 0; MOVE_DIGITS (&MP_DIGIT (w, 2), &MP_DIGIT (x, 1), digits); MP_DIGIT (w, digits + 2) = (MP_T) 0; MP_DIGIT (w, digits + 3) = (MP_T) 0; MP_DIGIT (w, digits + 4) = (MP_T) 0; /* Estimate the denominator. Take four terms to also suit small MP_RADIX */ xd = (MP_DIGIT (y, 1) * MP_RADIX + MP_DIGIT (y, 2)) * MP_RADIX + MP_DIGIT (y, 3) + MP_DIGIT (y, 4) / MP_RADIX; t = &MP_DIGIT (w, 2); if (digits + 2 < oflow) { for (k = 1; k <= digits + 2; k++, t++) { double xn, q; int first = k + 2; /* Estimate quotient digit */ xn = ((t[-1] * MP_RADIX + t[0]) * MP_RADIX + t[1]) * MP_RADIX + (digits_w >= (first + 2) ? t[2] : 0); q = (double) ((int) (xn / xd)); if (q != 0) { /* Correct the nominator */ int j, len = k + digits + 1; int lim = (len < digits_w ? len : digits_w); MP_T *u = t, *v = &MP_DIGIT (y, 1); for (j = first; j <= lim; j++) { (u++)[0] -= q * (v++)[0]; } } t[0] += (t[-1] * MP_RADIX); t[-1] = q; } } else { for (k = 1; k <= digits + 2; k++, t++) { double xn, q; int first = k + 2; if (k % oflow == 0) { norm_mp (w, first, digits_w); } /* Estimate quotient digit */ xn = ((t[-1] * MP_RADIX + t[0]) * MP_RADIX + t[1]) * MP_RADIX + (digits_w >= (first + 2) ? t[2] : 0); q = (double) ((int) (xn / xd)); if (q != 0) { /* Correct the nominator */ int j, len = k + digits + 1; int lim = (len < digits_w ? len : digits_w); MP_T *u = t, *v = &MP_DIGIT (y, 1); for (j = first; j <= lim; j++) { (u++)[0] -= q * (v++)[0]; } } t[0] += (t[-1] * MP_RADIX); t[-1] = q; } } norm_mp (w, 2, digits_w); round_internal_mp (z, w, digits); /* Restore and exit */ stack_pointer = pop_sp; z_1 = MP_DIGIT (z, 1); MP_DIGIT (x, 1) = x_1; MP_DIGIT (y, 1) = y_1; MP_DIGIT (z, 1) = ((x_1 * y_1) >= 0 ? z_1 : -z_1); CHECK_MP_EXPONENT (p, z); return (z); } /*! \brief set "z" to the integer quotient of "x" and "y" \param p position in tree \param z mp number \param x mp number \param y mp number \param digits precision in mp-digits \return result "z" **/ MP_T *over_mp (NODE_T * p, MP_T * z, MP_T * x, MP_T * y, int digits) { int digits_g = FUN_DIGITS (digits); MP_T *x_g, *y_g, *z_g; ADDR_T pop_sp = stack_pointer; if (MP_DIGIT (y, 1) == 0) { errno = ERANGE; return (NO_MP); } STACK_MP (x_g, p, digits_g); STACK_MP (y_g, p, digits_g); STACK_MP (z_g, p, digits_g); (void) lengthen_mp (p, x_g, digits_g, x, digits); (void) lengthen_mp (p, y_g, digits_g, y, digits); (void) div_mp (p, z_g, x_g, y_g, digits_g); trunc_mp (p, z_g, z_g, digits_g); (void) shorten_mp (p, z, digits, z_g, digits_g); MP_STATUS (z) = (MP_T) INIT_MASK; /* Restore and exit */ stack_pointer = pop_sp; return (z); } /*! \brief set "z" to x mod y \param p position in tree \param z mp number \param x mp number \param y mp number \param digits precision in mp-digits \return result "z" **/ MP_T *mod_mp (NODE_T * p, MP_T * z, MP_T * x, MP_T * y, int digits) { int digits_g = FUN_DIGITS (digits); ADDR_T pop_sp = stack_pointer; MP_T *x_g, *y_g, *z_g; if (MP_DIGIT (y, 1) == 0) { errno = EDOM; return (NO_MP); } STACK_MP (x_g, p, digits_g); STACK_MP (y_g, p, digits_g); STACK_MP (z_g, p, digits_g); (void) lengthen_mp (p, y_g, digits_g, y, digits); (void) lengthen_mp (p, x_g, digits_g, x, digits); /* x mod y = x - y * trunc (x / y) */ (void) over_mp (p, z_g, x_g, y_g, digits_g); (void) mul_mp (p, z_g, y_g, z_g, digits_g); (void) sub_mp (p, z_g, x_g, z_g, digits_g); (void) shorten_mp (p, z, digits, z_g, digits_g); /* Restore and exit */ stack_pointer = pop_sp; return (z); } /*! \brief set "z" to the product of x and digit y \param p position in tree \param z mp number \param x mp number \param y mp number \param digits precision in mp-digits \return result "z" **/ MP_T *mul_mp_digit (NODE_T * p, MP_T * z, MP_T * x, MP_T y, int digits) { /* This is an O(N) routine for multiplication by a short value */ MP_T *w, z_1, x_1 = MP_DIGIT (x, 1), y_1 = y, *u, *v; int j, digits_h = 2 + digits; ADDR_T pop_sp = stack_pointer; MP_DIGIT (x, 1) = ABS (x_1); MP_STATUS (z) = (MP_T) INIT_MASK; y = ABS (y_1); STACK_MP (w, p, digits_h); SET_MP_ZERO (w, digits_h); MP_EXPONENT (w) = MP_EXPONENT (x) + 1; j = digits; u = &MP_DIGIT (w, 1 + digits); v = &MP_DIGIT (x, digits); while (j-- >= 1) { (u--)[0] += y * (v--)[0]; } norm_mp (w, 2, digits_h); round_internal_mp (z, w, digits); /* Restore and exit */ stack_pointer = pop_sp; z_1 = MP_DIGIT (z, 1); MP_DIGIT (x, 1) = x_1; MP_DIGIT (z, 1) = ((x_1 * y_1) >= 0 ? z_1 : -z_1); CHECK_MP_EXPONENT (p, z); return (z); } /*! \brief set "z" to x/2 \param p position in tree \param z mp number \param x mp number \param digits precision in mp-digits \return result "z" **/ MP_T *half_mp (NODE_T * p, MP_T * z, MP_T * x, int digits) { MP_T *w, z_1, x_1 = MP_DIGIT (x, 1), *u, *v; int j, digits_h = 2 + digits; ADDR_T pop_sp = stack_pointer; MP_DIGIT (x, 1) = ABS (x_1); MP_STATUS (z) = (MP_T) INIT_MASK; STACK_MP (w, p, digits_h); SET_MP_ZERO (w, digits_h); /* Calculate x * 0.5 */ MP_EXPONENT (w) = MP_EXPONENT (x); j = digits; u = &MP_DIGIT (w, 1 + digits); v = &MP_DIGIT (x, digits); while (j-- >= 1) { (u--)[0] += (MP_RADIX / 2) * (v--)[0]; } norm_mp (w, 2, digits_h); round_internal_mp (z, w, digits); /* Restore and exit */ stack_pointer = pop_sp; z_1 = MP_DIGIT (z, 1); MP_DIGIT (x, 1) = x_1; MP_DIGIT (z, 1) = (x_1 >= 0 ? z_1 : -z_1); CHECK_MP_EXPONENT (p, z); return (z); } /*! \brief set "z" to the quotient of x and digit y \param p position in tree \param z mp number \param x mp number \param y mp number \param digits precision in mp-digits \return result "z" **/ MP_T *div_mp_digit (NODE_T * p, MP_T * z, MP_T * x, MP_T y, int digits) { double xd; MP_T *t, *w, z_1, x_1 = MP_DIGIT (x, 1), y_1 = y; int k, oflow, digits_w = 4 + digits; ADDR_T pop_sp = stack_pointer; if (y == 0) { errno = ERANGE; return (NO_MP); } /* Determine normalisation interval assuming that q < 2b in each step */ oflow = (int) (floor) ((double) MAX_REPR_INT / (3 * (double) MP_RADIX * (double) MP_RADIX)) - 1; ABEND (oflow <= 1, "inadequate MP_RADIX", NO_TEXT); /* Work with positive operands */ MP_DIGIT (x, 1) = ABS (x_1); MP_STATUS (z) = (MP_T) INIT_MASK; y = ABS (y_1); STACK_MP (w, p, digits_w); MP_EXPONENT (w) = MP_EXPONENT (x); MP_DIGIT (w, 1) = (MP_T) 0; MOVE_DIGITS (&MP_DIGIT (w, 2), &MP_DIGIT (x, 1), digits); MP_DIGIT (w, digits + 2) = (MP_T) 0; MP_DIGIT (w, digits + 3) = (MP_T) 0; MP_DIGIT (w, digits + 4) = (MP_T) 0; /* Estimate the denominator */ xd = (double) y *MP_RADIX * MP_RADIX; t = &MP_DIGIT (w, 2); if (digits + 2 < oflow) { for (k = 1; k <= digits + 2; k++, t++) { double xn, q; int first = k + 2; /* Estimate quotient digit and correct */ xn = ((t[-1] * MP_RADIX + t[0]) * MP_RADIX + t[1]) * MP_RADIX + (digits_w >= (first + 2) ? t[2] : 0); q = (double) ((int) (xn / xd)); t[0] += (t[-1] * MP_RADIX - q * y); t[-1] = q; } } else { for (k = 1; k <= digits + 2; k++, t++) { double xn, q; int first = k + 2; if (k % oflow == 0) { norm_mp (w, first, digits_w); } /* Estimate quotient digit and correct */ xn = ((t[-1] * MP_RADIX + t[0]) * MP_RADIX + t[1]) * MP_RADIX + (digits_w >= (first + 2) ? t[2] : 0); q = (double) ((int) (xn / xd)); t[0] += (t[-1] * MP_RADIX - q * y); t[-1] = q; } } norm_mp (w, 2, digits_w); round_internal_mp (z, w, digits); /* Restore and exit */ stack_pointer = pop_sp; z_1 = MP_DIGIT (z, 1); MP_DIGIT (x, 1) = x_1; MP_DIGIT (z, 1) = ((x_1 * y_1) >= 0 ? z_1 : -z_1); CHECK_MP_EXPONENT (p, z); return (z); } /*! \brief set "z" to the integer quotient of "x" and "y" \param p position in tree \param z mp number \param x mp number \param y mp number \param digits precision in mp-digits \return result "z" **/ MP_T *over_mp_digit (NODE_T * p, MP_T * z, MP_T * x, MP_T y, int digits) { int digits_g = FUN_DIGITS (digits); ADDR_T pop_sp = stack_pointer; MP_T *x_g, *z_g; if (y == 0) { errno = ERANGE; return (NO_MP); } STACK_MP (x_g, p, digits_g); STACK_MP (z_g, p, digits_g); (void) lengthen_mp (p, x_g, digits_g, x, digits); (void) div_mp_digit (p, z_g, x_g, y, digits_g); trunc_mp (p, z_g, z_g, digits_g); (void) shorten_mp (p, z, digits, z_g, digits_g); /* Restore and exit */ stack_pointer = pop_sp; return (z); } /*! \brief set "z" to the reciprocal of "x" \param p position in tree \param z mp number \param x mp number \param digits precision in mp-digits \return result "z" **/ MP_T *rec_mp (NODE_T * p, MP_T * z, MP_T * x, int digits) { ADDR_T pop_sp = stack_pointer; MP_T *one; if (MP_DIGIT (x, 1) == 0) { errno = ERANGE; return (NO_MP); } STACK_MP (one, p, digits); (void) set_mp_short (one, (MP_T) 1, 0, digits); (void) div_mp (p, z, one, x, digits); /* Restore and exit */ stack_pointer = pop_sp; return (z); } /*! \brief set "z" to "x" ** "n" \param p position in tree \param z mp number \param x mp number \param n integer power \param digits precision in mp-digits \return result "z" **/ MP_T *pow_mp_int (NODE_T * p, MP_T * z, MP_T * x, int n, int digits) { int pop_sp = stack_pointer, bit, digits_g = FUN_DIGITS (digits); BOOL_T negative; MP_T *z_g, *x_g; STACK_MP (z_g, p, digits_g); STACK_MP (x_g, p, digits_g); (void) set_mp_short (z_g, (MP_T) 1, 0, digits_g); (void) lengthen_mp (p, x_g, digits_g, x, digits); negative = (BOOL_T) (n < 0); if (negative) { n = -n; } bit = 1; while ((unsigned) bit <= (unsigned) n) { if (n & bit) { (void) mul_mp (p, z_g, z_g, x_g, digits_g); } (void) mul_mp (p, x_g, x_g, x_g, digits_g); bit *= 2; } (void) shorten_mp (p, z, digits, z_g, digits_g); stack_pointer = pop_sp; if (negative) { (void) rec_mp (p, z, z, digits); } CHECK_MP_EXPONENT (p, z); return (z); } /*! \brief set "z" to 10 ** "n" \param p position in tree \param z mp number \param x mp number \param n integer power \param digits precision in mp-digits \return result "z" **/ MP_T *mp_ten_up (NODE_T * p, MP_T * z, int n, int digits) { int pop_sp = stack_pointer, bit, digits_g = FUN_DIGITS (digits); BOOL_T negative; MP_T *z_g, *x_g; STACK_MP (z_g, p, digits_g); STACK_MP (x_g, p, digits_g); (void) set_mp_short (x_g, (MP_T) 10, 0, digits_g); (void) set_mp_short (z_g, (MP_T) 1, 0, digits_g); negative = (BOOL_T) (n < 0); if (negative) { n = -n; } bit = 1; while ((unsigned) bit <= (unsigned) n) { if (n & bit) { (void) mul_mp (p, z_g, z_g, x_g, digits_g); } (void) mul_mp (p, x_g, x_g, x_g, digits_g); bit *= 2; } (void) shorten_mp (p, z, digits, z_g, digits_g); stack_pointer = pop_sp; if (negative) { (void) rec_mp (p, z, z, digits); } CHECK_MP_EXPONENT (p, z); return (z); } /*! \brief test on |"z"| > 0.001 for argument reduction in "sin" and "exp" \param z mp number \param digits precision in mp-digits \return result "z" **/ static BOOL_T eps_mp (MP_T * z, int digits) { if (MP_DIGIT (z, 1) == 0) { return (A68_FALSE); } else if (MP_EXPONENT (z) > -1) { return (A68_TRUE); } else if (MP_EXPONENT (z) < -1) { return (A68_FALSE); } else { #if (MP_RADIX == DEFAULT_MP_RADIX) /* More or less optimised for LONG and default LONG LONG precisions */ return ((BOOL_T) (digits <= 10 ? ABS (MP_DIGIT (z, 1)) > 100000 : ABS (MP_DIGIT (z, 1)) > 10000)); #else switch (LOG_MP_BASE) { case 3: { return (ABS (MP_DIGIT (z, 1)) > 1); } case 4: { return (ABS (MP_DIGIT (z, 1)) > 10); } case 5: { return (ABS (MP_DIGIT (z, 1)) > 100); } case 6: { return (ABS (MP_DIGIT (z, 1)) > 1000); } default: { ABEND (A68_TRUE, "unexpected mp base", ""); return (A68_FALSE); } } #endif } } /*! \brief set "z" to sqrt ("x") \param p position in tree \param z mp number \param x mp number \param digits precision in mp-digits \return result "z" **/ MP_T *sqrt_mp (NODE_T * p, MP_T * z, MP_T * x, int digits) { int pop_sp = stack_pointer, digits_g = FUN_DIGITS (digits), digits_h; MP_T *tmp, *x_g, *z_g; BOOL_T reciprocal = A68_FALSE; if (MP_DIGIT (x, 1) == 0) { stack_pointer = pop_sp; SET_MP_ZERO (z, digits); return (z); } if (MP_DIGIT (x, 1) < 0) { stack_pointer = pop_sp; errno = EDOM; return (NO_MP); } STACK_MP (z_g, p, digits_g); STACK_MP (x_g, p, digits_g); STACK_MP (tmp, p, digits_g); (void) lengthen_mp (p, x_g, digits_g, x, digits); /* Scaling for small x; sqrt (x) = 1 / sqrt (1 / x) */ if ((reciprocal = (BOOL_T) (MP_EXPONENT (x_g) < 0)) == A68_TRUE) { (void) rec_mp (p, x_g, x_g, digits_g); } if (ABS (MP_EXPONENT (x_g)) >= 2) { /* For extreme arguments we want accurate results as well */ int expo = (int) MP_EXPONENT (x_g); MP_EXPONENT (x_g) = (MP_T) (expo % 2); (void) sqrt_mp (p, z_g, x_g, digits_g); MP_EXPONENT (z_g) += (MP_T) (expo / 2); } else { /* Argument is in range. Estimate the root as double */ int decimals; double x_d = mp_to_real (p, x_g, digits_g); (void) real_to_mp (p, z_g, sqrt (x_d), digits_g); /* Newton's method: x = (x + a / x) / 2 */ decimals = DOUBLE_ACCURACY; do { decimals <<= 1; digits_h = MINIMUM (1 + decimals / LOG_MP_BASE, digits_g); (void) div_mp (p, tmp, x_g, z_g, digits_h); (void) add_mp (p, tmp, z_g, tmp, digits_h); (void) half_mp (p, z_g, tmp, digits_h); } while (decimals < 2 * digits_g * LOG_MP_BASE); } if (reciprocal) { (void) rec_mp (p, z_g, z_g, digits); } (void) shorten_mp (p, z, digits, z_g, digits_g); /* Exit */ stack_pointer = pop_sp; return (z); } /*! \brief set "z" to curt ("x"), the cube root \param p position in tree \param z mp number \param x mp number \param digits precision in mp-digits \return result "z" **/ MP_T *curt_mp (NODE_T * p, MP_T * z, MP_T * x, int digits) { int pop_sp = stack_pointer, digits_g = FUN_DIGITS (digits), digits_h; MP_T *tmp, *x_g, *z_g; BOOL_T reciprocal = A68_FALSE, change_sign = A68_FALSE; if (MP_DIGIT (x, 1) == 0) { stack_pointer = pop_sp; SET_MP_ZERO (z, digits); return (z); } if (MP_DIGIT (x, 1) < 0) { change_sign = A68_TRUE; MP_DIGIT (x, 1) = -MP_DIGIT (x, 1); } STACK_MP (z_g, p, digits_g); STACK_MP (x_g, p, digits_g); STACK_MP (tmp, p, digits_g); (void) lengthen_mp (p, x_g, digits_g, x, digits); /* Scaling for small x; curt (x) = 1 / curt (1 / x) */ if ((reciprocal = (BOOL_T) (MP_EXPONENT (x_g) < 0)) == A68_TRUE) { (void) rec_mp (p, x_g, x_g, digits_g); } if (ABS (MP_EXPONENT (x_g)) >= 3) { /* For extreme arguments we want accurate results as well */ int expo = (int) MP_EXPONENT (x_g); MP_EXPONENT (x_g) = (MP_T) (expo % 3); (void) curt_mp (p, z_g, x_g, digits_g); MP_EXPONENT (z_g) += (MP_T) (expo / 3); } else { /* Argument is in range. Estimate the root as double */ int decimals; (void) real_to_mp (p, z_g, curt (mp_to_real (p, x_g, digits_g)), digits_g); /* Newton's method: x = (2 x + a / x ^ 2) / 3 */ decimals = DOUBLE_ACCURACY; do { decimals <<= 1; digits_h = MINIMUM (1 + decimals / LOG_MP_BASE, digits_g); (void) mul_mp (p, tmp, z_g, z_g, digits_h); (void) div_mp (p, tmp, x_g, tmp, digits_h); (void) add_mp (p, tmp, z_g, tmp, digits_h); (void) add_mp (p, tmp, z_g, tmp, digits_h); (void) div_mp_digit (p, z_g, tmp, (MP_T) 3, digits_h); } while (decimals < digits_g * LOG_MP_BASE); } if (reciprocal) { (void) rec_mp (p, z_g, z_g, digits); } (void) shorten_mp (p, z, digits, z_g, digits_g); /* Exit */ stack_pointer = pop_sp; if (change_sign) { MP_DIGIT (z, 1) = -MP_DIGIT (z, 1); } return (z); } /*! \brief set "z" to sqrt ("x"^2 + "y"^2) \param p position in tree \param z mp number \param x mp number \param y mp number \param digits precision in mp-digits \return result "z" **/ MP_T *hypot_mp (NODE_T * p, MP_T * z, MP_T * x, MP_T * y, int digits) { ADDR_T pop_sp = stack_pointer; MP_T *t, *u, *v; STACK_MP (t, p, digits); STACK_MP (u, p, digits); STACK_MP (v, p, digits); MOVE_MP (u, x, digits); MOVE_MP (v, y, digits); MP_DIGIT (u, 1) = ABS (MP_DIGIT (u, 1)); MP_DIGIT (v, 1) = ABS (MP_DIGIT (v, 1)); if (IS_ZERO_MP (u)) { MOVE_MP (z, v, digits); } else if (IS_ZERO_MP (v)) { MOVE_MP (z, u, digits); } else { (void) set_mp_short (t, (MP_T) 1, 0, digits); (void) sub_mp (p, z, u, v, digits); if (MP_DIGIT (z, 1) > 0) { (void) div_mp (p, z, v, u, digits); (void) mul_mp (p, z, z, z, digits); (void) add_mp (p, z, t, z, digits); (void) sqrt_mp (p, z, z, digits); (void) mul_mp (p, z, u, z, digits); } else { (void) div_mp (p, z, u, v, digits); (void) mul_mp (p, z, z, z, digits); (void) add_mp (p, z, t, z, digits); (void) sqrt_mp (p, z, z, digits); (void) mul_mp (p, z, v, z, digits); } } stack_pointer = pop_sp; return (z); } /*! \brief set "z" to exp ("x") \param p position in tree \param z mp number \param x mp number \param digits precision in mp-digits \return result "z" **/ MP_T *exp_mp (NODE_T * p, MP_T * z, MP_T * x, int digits) { /* Argument is reduced by using exp (z / (2 ** n)) ** (2 ** n) = exp(z) */ int m, n, pop_sp = stack_pointer, digits_g = FUN_DIGITS (digits); MP_T *x_g, *sum, *a68g_pow, *fac, *tmp; BOOL_T iterate; if (MP_DIGIT (x, 1) == 0) { (void) set_mp_short (z, (MP_T) 1, 0, digits); return (z); } STACK_MP (x_g, p, digits_g); STACK_MP (sum, p, digits_g); STACK_MP (a68g_pow, p, digits_g); STACK_MP (fac, p, digits_g); STACK_MP (tmp, p, digits_g); (void) lengthen_mp (p, x_g, digits_g, x, digits); m = 0; /* Scale x down */ while (eps_mp (x_g, digits_g)) { m++; (void) half_mp (p, x_g, x_g, digits_g); } /* Calculate Taylor sum exp (z) = 1 + z / 1 ! + z ** 2 / 2 ! + .. */ (void) set_mp_short (sum, (MP_T) 1, 0, digits_g); (void) add_mp (p, sum, sum, x_g, digits_g); (void) mul_mp (p, a68g_pow, x_g, x_g, digits_g); #if (MP_RADIX == DEFAULT_MP_RADIX) (void) half_mp (p, tmp, a68g_pow, digits_g); (void) add_mp (p, sum, sum, tmp, digits_g); (void) mul_mp (p, a68g_pow, a68g_pow, x_g, digits_g); (void) div_mp_digit (p, tmp, a68g_pow, (MP_T) 6, digits_g); (void) add_mp (p, sum, sum, tmp, digits_g); (void) mul_mp (p, a68g_pow, a68g_pow, x_g, digits_g); (void) div_mp_digit (p, tmp, a68g_pow, (MP_T) 24, digits_g); (void) add_mp (p, sum, sum, tmp, digits_g); (void) mul_mp (p, a68g_pow, a68g_pow, x_g, digits_g); (void) div_mp_digit (p, tmp, a68g_pow, (MP_T) 120, digits_g); (void) add_mp (p, sum, sum, tmp, digits_g); (void) mul_mp (p, a68g_pow, a68g_pow, x_g, digits_g); (void) div_mp_digit (p, tmp, a68g_pow, (MP_T) 720, digits_g); (void) add_mp (p, sum, sum, tmp, digits_g); (void) mul_mp (p, a68g_pow, a68g_pow, x_g, digits_g); (void) div_mp_digit (p, tmp, a68g_pow, (MP_T) 5040, digits_g); (void) add_mp (p, sum, sum, tmp, digits_g); (void) mul_mp (p, a68g_pow, a68g_pow, x_g, digits_g); (void) div_mp_digit (p, tmp, a68g_pow, (MP_T) 40320, digits_g); (void) add_mp (p, sum, sum, tmp, digits_g); (void) mul_mp (p, a68g_pow, a68g_pow, x_g, digits_g); (void) div_mp_digit (p, tmp, a68g_pow, (MP_T) 362880, digits_g); (void) add_mp (p, sum, sum, tmp, digits_g); (void) mul_mp (p, a68g_pow, a68g_pow, x_g, digits_g); (void) set_mp_short (fac, (MP_T) (MP_T) 3628800, 0, digits_g); n = 10; #else (void) set_mp_short (fac, (MP_T) 2, 0, digits_g); n = 2; #endif iterate = (BOOL_T) (MP_DIGIT (a68g_pow, 1) != 0); while (iterate) { (void) div_mp (p, tmp, a68g_pow, fac, digits_g); if (MP_EXPONENT (tmp) <= (MP_EXPONENT (sum) - digits_g)) { iterate = A68_FALSE; } else { (void) add_mp (p, sum, sum, tmp, digits_g); (void) mul_mp (p, a68g_pow, a68g_pow, x_g, digits_g); n++; (void) mul_mp_digit (p, fac, fac, (MP_T) n, digits_g); } } /* Square exp (x) up */ while (m--) { (void) mul_mp (p, sum, sum, sum, digits_g); } (void) shorten_mp (p, z, digits, sum, digits_g); /* Exit */ stack_pointer = pop_sp; return (z); } /*! \brief set "z" to exp ("x") - 1, assuming "x" to be close to 0 \param p position in tree \param z mp number \param x mp number \param digits precision in mp-digits \return result "z" **/ MP_T *expm1_mp (NODE_T * p, MP_T * z, MP_T * x, int digits) { int n, pop_sp = stack_pointer, digits_g = FUN_DIGITS (digits); MP_T *x_g, *sum, *a68g_pow, *fac, *tmp; BOOL_T iterate; if (MP_DIGIT (x, 1) == 0) { (void) set_mp_short (z, (MP_T) 1, 0, digits); return (z); } STACK_MP (x_g, p, digits_g); STACK_MP (sum, p, digits_g); STACK_MP (a68g_pow, p, digits_g); STACK_MP (fac, p, digits_g); STACK_MP (tmp, p, digits_g); (void) lengthen_mp (p, x_g, digits_g, x, digits); /* Calculate Taylor sum expm1 (z) = z / 1 ! + z ** 2 / 2 ! + .. */ SET_MP_ZERO (sum, digits_g); (void) add_mp (p, sum, sum, x_g, digits_g); (void) mul_mp (p, a68g_pow, x_g, x_g, digits_g); #if (MP_RADIX == DEFAULT_MP_RADIX) (void) half_mp (p, tmp, a68g_pow, digits_g); (void) add_mp (p, sum, sum, tmp, digits_g); (void) mul_mp (p, a68g_pow, a68g_pow, x_g, digits_g); (void) div_mp_digit (p, tmp, a68g_pow, (MP_T) 6, digits_g); (void) add_mp (p, sum, sum, tmp, digits_g); (void) mul_mp (p, a68g_pow, a68g_pow, x_g, digits_g); (void) div_mp_digit (p, tmp, a68g_pow, (MP_T) 24, digits_g); (void) add_mp (p, sum, sum, tmp, digits_g); (void) mul_mp (p, a68g_pow, a68g_pow, x_g, digits_g); (void) div_mp_digit (p, tmp, a68g_pow, (MP_T) 120, digits_g); (void) add_mp (p, sum, sum, tmp, digits_g); (void) mul_mp (p, a68g_pow, a68g_pow, x_g, digits_g); (void) div_mp_digit (p, tmp, a68g_pow, (MP_T) 720, digits_g); (void) add_mp (p, sum, sum, tmp, digits_g); (void) mul_mp (p, a68g_pow, a68g_pow, x_g, digits_g); (void) div_mp_digit (p, tmp, a68g_pow, (MP_T) 5040, digits_g); (void) add_mp (p, sum, sum, tmp, digits_g); (void) mul_mp (p, a68g_pow, a68g_pow, x_g, digits_g); (void) div_mp_digit (p, tmp, a68g_pow, (MP_T) 40320, digits_g); (void) add_mp (p, sum, sum, tmp, digits_g); (void) mul_mp (p, a68g_pow, a68g_pow, x_g, digits_g); (void) div_mp_digit (p, tmp, a68g_pow, (MP_T) 362880, digits_g); (void) add_mp (p, sum, sum, tmp, digits_g); (void) mul_mp (p, a68g_pow, a68g_pow, x_g, digits_g); (void) set_mp_short (fac, (MP_T) (MP_T) 3628800, 0, digits_g); n = 10; #else (void) set_mp_short (fac, (MP_T) 2, 0, digits_g); n = 2; #endif iterate = (BOOL_T) (MP_DIGIT (a68g_pow, 1) != 0); while (iterate) { (void) div_mp (p, tmp, a68g_pow, fac, digits_g); if (MP_EXPONENT (tmp) <= (MP_EXPONENT (sum) - digits_g)) { iterate = A68_FALSE; } else { (void) add_mp (p, sum, sum, tmp, digits_g); (void) mul_mp (p, a68g_pow, a68g_pow, x_g, digits_g); n++; (void) mul_mp_digit (p, fac, fac, (MP_T) n, digits_g); } } (void) shorten_mp (p, z, digits, sum, digits_g); /* Exit */ stack_pointer = pop_sp; return (z); } /*! \brief ln scale with digits precision \param p position in tree \param z mp number \param digits precision in mp-digits \return result "z" **/ MP_T *mp_ln_scale (NODE_T * p, MP_T * z, int digits) { int pop_sp = stack_pointer, digits_g = FUN_DIGITS (digits); MP_T *z_g; STACK_MP (z_g, p, digits_g); /* First see if we can restore a previous calculation */ if (digits_g <= mp_ln_scale_size) { MOVE_MP (z_g, ref_mp_ln_scale, digits_g); } else { /* No luck with the kept value, we generate a longer one */ (void) set_mp_short (z_g, (MP_T) 1, 1, digits_g); (void) ln_mp (p, z_g, z_g, digits_g); ref_mp_ln_scale = (MP_T *) get_heap_space ((unsigned) SIZE_MP (digits_g)); MOVE_MP (ref_mp_ln_scale, z_g, digits_g); mp_ln_scale_size = digits_g; } (void) shorten_mp (p, z, digits, z_g, digits_g); stack_pointer = pop_sp; return (z); } /*! \brief ln 10 with digits precision \param p position in tree \param z mp number \param digits precision in mp-digits \return result "z" **/ MP_T *mp_ln_10 (NODE_T * p, MP_T * z, int digits) { int pop_sp = stack_pointer, digits_g = FUN_DIGITS (digits); MP_T *z_g; STACK_MP (z_g, p, digits_g); /* First see if we can restore a previous calculation */ if (digits_g <= mp_ln_10_size) { MOVE_MP (z_g, ref_mp_ln_10, digits_g); } else { /* No luck with the kept value, we generate a longer one */ (void) set_mp_short (z_g, (MP_T) 10, 0, digits_g); (void) ln_mp (p, z_g, z_g, digits_g); ref_mp_ln_10 = (MP_T *) get_heap_space ((unsigned) SIZE_MP (digits_g)); MOVE_MP (ref_mp_ln_10, z_g, digits_g); mp_ln_10_size = digits_g; } (void) shorten_mp (p, z, digits, z_g, digits_g); stack_pointer = pop_sp; return (z); } /*! \brief set "z" to ln ("x") \param p position in tree \param z mp number \param x mp number \param digits precision in mp-digits \return result "z" **/ MP_T *ln_mp (NODE_T * p, MP_T * z, MP_T * x, int digits) { /* Depending on the argument we choose either Taylor or Newton */ int pop_sp = stack_pointer, digits_g = FUN_DIGITS (digits); BOOL_T negative, scale; MP_T *x_g, *z_g, expo = 0; if (MP_DIGIT (x, 1) <= 0) { errno = EDOM; return (NO_MP); } STACK_MP (x_g, p, digits_g); (void) lengthen_mp (p, x_g, digits_g, x, digits); STACK_MP (z_g, p, digits_g); /* We use ln (1 / x) = - ln (x) */ negative = (BOOL_T) (MP_EXPONENT (x_g) < 0); if (negative) { (void) rec_mp (p, x_g, x_g, digits); } /* We want correct results for extreme arguments. We scale when "x_g" exceeds "MP_RADIX ** +- 2", using ln (x * MP_RADIX ** n) = ln (x) + n * ln (MP_RADIX).*/ scale = (BOOL_T) (ABS (MP_EXPONENT (x_g)) >= 2); if (scale) { expo = MP_EXPONENT (x_g); MP_EXPONENT (x_g) = (MP_T) 0; } if (MP_EXPONENT (x_g) == 0 && MP_DIGIT (x_g, 1) == 1 && MP_DIGIT (x_g, 2) == 0) { /* Taylor sum for x close to unity. ln (x) = (x - 1) - (x - 1) ** 2 / 2 + (x - 1) ** 3 / 3 - ... This is faster for small x and avoids cancellation */ MP_T *one, *tmp, *a68g_pow; int n = 2; BOOL_T iterate; STACK_MP (one, p, digits_g); STACK_MP (tmp, p, digits_g); STACK_MP (a68g_pow, p, digits_g); (void) set_mp_short (one, (MP_T) 1, 0, digits_g); (void) sub_mp (p, x_g, x_g, one, digits_g); (void) mul_mp (p, a68g_pow, x_g, x_g, digits_g); MOVE_MP (z_g, x_g, digits_g); iterate = (BOOL_T) (MP_DIGIT (a68g_pow, 1) != 0); while (iterate) { (void) div_mp_digit (p, tmp, a68g_pow, (MP_T) n, digits_g); if (MP_EXPONENT (tmp) <= (MP_EXPONENT (z_g) - digits_g)) { iterate = A68_FALSE; } else { MP_DIGIT (tmp, 1) = (n % 2 == 0 ? -MP_DIGIT (tmp, 1) : MP_DIGIT (tmp, 1)); (void) add_mp (p, z_g, z_g, tmp, digits_g); (void) mul_mp (p, a68g_pow, a68g_pow, x_g, digits_g); n++; } } } else { /* Newton's method: x = x - 1 + a / exp (x) */ MP_T *tmp, *z_0, *one; int decimals; STACK_MP (tmp, p, digits_g); STACK_MP (one, p, digits_g); STACK_MP (z_0, p, digits_g); (void) set_mp_short (one, (MP_T) 1, 0, digits_g); SET_MP_ZERO (z_0, digits_g); /* Construct an estimate */ (void) real_to_mp (p, z_g, log (mp_to_real (p, x_g, digits_g)), digits_g); decimals = DOUBLE_ACCURACY; do { int digits_h; decimals <<= 1; digits_h = MINIMUM (1 + decimals / LOG_MP_BASE, digits_g); (void) exp_mp (p, tmp, z_g, digits_h); (void) div_mp (p, tmp, x_g, tmp, digits_h); (void) sub_mp (p, z_g, z_g, one, digits_h); (void) add_mp (p, z_g, z_g, tmp, digits_h); } while (decimals < digits_g * LOG_MP_BASE); } /* Inverse scaling */ if (scale) { /* ln (x * MP_RADIX ** n) = ln (x) + n * ln (MP_RADIX) */ MP_T *ln_base; STACK_MP (ln_base, p, digits_g); (void) mp_ln_scale (p, ln_base, digits_g); (void) mul_mp_digit (p, ln_base, ln_base, (MP_T) expo, digits_g); (void) add_mp (p, z_g, z_g, ln_base, digits_g); } if (negative) { MP_DIGIT (z_g, 1) = -MP_DIGIT (z_g, 1); } (void) shorten_mp (p, z, digits, z_g, digits_g); /* Exit */ stack_pointer = pop_sp; return (z); } /*! \brief set "z" to log ("x") \param p position in tree \param z mp number \param x mp number \param digits precision in mp-digits \return result "z" **/ MP_T *log_mp (NODE_T * p, MP_T * z, MP_T * x, int digits) { int pop_sp = stack_pointer; MP_T *ln_10; STACK_MP (ln_10, p, digits); if (ln_mp (p, z, x, digits) == NO_MP) { errno = EDOM; return (NO_MP); } (void) mp_ln_10 (p, ln_10, digits); (void) div_mp (p, z, z, ln_10, digits); stack_pointer = pop_sp; return (z); } /*! \brief set "sh" and "ch" to sinh ("z") and cosh ("z") respectively \param p position in tree \param sh mp number \param ch mp number \param z mp number \param digits precision in mp-digits \return result "z" **/ MP_T *hyp_mp (NODE_T * p, MP_T * sh, MP_T * ch, MP_T * z, int digits) { ADDR_T pop_sp = stack_pointer; MP_T *x_g, *y_g, *z_g; STACK_MP (x_g, p, digits); STACK_MP (y_g, p, digits); STACK_MP (z_g, p, digits); MOVE_MP (z_g, z, digits); (void) exp_mp (p, x_g, z_g, digits); (void) rec_mp (p, y_g, x_g, digits); (void) add_mp (p, ch, x_g, y_g, digits); /* Avoid cancellation for sinh */ if ((MP_DIGIT (x_g, 1) == 1 && MP_DIGIT (x_g, 2) == 0) || (MP_DIGIT (y_g, 1) == 1 && MP_DIGIT (y_g, 2) == 0)) { (void) expm1_mp (p, x_g, z_g, digits); MP_DIGIT (z_g, 1) = -MP_DIGIT (z_g, 1); (void) expm1_mp (p, y_g, z_g, digits); } (void) sub_mp (p, sh, x_g, y_g, digits); (void) half_mp (p, sh, sh, digits); (void) half_mp (p, ch, ch, digits); stack_pointer = pop_sp; return (z); } /*! \brief set "z" to sinh ("x") \param p position in tree \param z mp number \param x mp number \param digits precision in mp-digits \return result "z" **/ MP_T *sinh_mp (NODE_T * p, MP_T * z, MP_T * x, int digits) { ADDR_T pop_sp = stack_pointer; int digits_g = FUN_DIGITS (digits); MP_T *x_g, *y_g, *z_g; STACK_MP (x_g, p, digits_g); (void) lengthen_mp (p, x_g, digits_g, x, digits); STACK_MP (y_g, p, digits_g); STACK_MP (z_g, p, digits_g); (void) hyp_mp (p, z_g, y_g, x_g, digits_g); (void) shorten_mp (p, z, digits, z_g, digits_g); stack_pointer = pop_sp; return (z); } /*! \brief set "z" to asinh ("x") \param p position in tree \param z mp number \param x mp number \param digits precision in mp-digits \return result "z" **/ MP_T *asinh_mp (NODE_T * p, MP_T * z, MP_T * x, int digits) { if (IS_ZERO_MP (x)) { SET_MP_ZERO (z, digits); return (z); } else { ADDR_T pop_sp = stack_pointer; int digits_g; MP_T *x_g, *y_g, *z_g; if (MP_EXPONENT (x) >= -1) { digits_g = FUN_DIGITS (digits); } else { /* Extra precision when x^2+1 gets close to 1 */ digits_g = 2 * FUN_DIGITS (digits); } STACK_MP (x_g, p, digits_g); (void) lengthen_mp (p, x_g, digits_g, x, digits); STACK_MP (y_g, p, digits_g); STACK_MP (z_g, p, digits_g); (void) mul_mp (p, z_g, x_g, x_g, digits_g); (void) set_mp_short (y_g, (MP_T) 1, 0, digits_g); (void) add_mp (p, y_g, z_g, y_g, digits_g); (void) sqrt_mp (p, y_g, y_g, digits_g); (void) add_mp (p, y_g, y_g, x_g, digits_g); (void) ln_mp (p, z_g, y_g, digits_g); if (IS_ZERO_MP (z_g)) { MOVE_MP (z, x, digits); } else { (void) shorten_mp (p, z, digits, z_g, digits_g); } stack_pointer = pop_sp; return (z); } } /*! \brief set "z" to cosh ("x") \param p position in tree \param z mp number \param x mp number \param digits precision in mp-digits \return result "z" **/ MP_T *cosh_mp (NODE_T * p, MP_T * z, MP_T * x, int digits) { ADDR_T pop_sp = stack_pointer; int digits_g = FUN_DIGITS (digits); MP_T *x_g, *y_g, *z_g; STACK_MP (x_g, p, digits_g); (void) lengthen_mp (p, x_g, digits_g, x, digits); STACK_MP (y_g, p, digits_g); STACK_MP (z_g, p, digits_g); (void) hyp_mp (p, y_g, z_g, x_g, digits_g); (void) shorten_mp (p, z, digits, z_g, digits_g); stack_pointer = pop_sp; return (z); } /*! \brief set "z" to acosh ("x") \param p position in tree \param z mp number \param x mp number \param digits precision in mp-digits \return result "z" **/ MP_T *acosh_mp (NODE_T * p, MP_T * z, MP_T * x, int digits) { ADDR_T pop_sp = stack_pointer; int digits_g; MP_T *x_g, *y_g, *z_g; if (MP_DIGIT (x, 1) == 1 && MP_DIGIT (x, 2) == 0) { /* Extra precision when x^2-1 gets close to 0 */ digits_g = 2 * FUN_DIGITS (digits); } else { digits_g = FUN_DIGITS (digits); } STACK_MP (x_g, p, digits_g); (void) lengthen_mp (p, x_g, digits_g, x, digits); STACK_MP (y_g, p, digits_g); STACK_MP (z_g, p, digits_g); (void) mul_mp (p, z_g, x_g, x_g, digits_g); (void) set_mp_short (y_g, (MP_T) 1, 0, digits_g); (void) sub_mp (p, y_g, z_g, y_g, digits_g); (void) sqrt_mp (p, y_g, y_g, digits_g); (void) add_mp (p, y_g, y_g, x_g, digits_g); (void) ln_mp (p, z_g, y_g, digits_g); (void) shorten_mp (p, z, digits, z_g, digits_g); stack_pointer = pop_sp; return (z); } /*! \brief set "z" to tanh ("x") \param p position in tree \param z mp number \param x mp number \param digits precision in mp-digits \return result "z" **/ MP_T *tanh_mp (NODE_T * p, MP_T * z, MP_T * x, int digits) { ADDR_T pop_sp = stack_pointer; int digits_g = FUN_DIGITS (digits); MP_T *x_g, *y_g, *z_g; STACK_MP (x_g, p, digits_g); (void) lengthen_mp (p, x_g, digits_g, x, digits); STACK_MP (y_g, p, digits_g); STACK_MP (z_g, p, digits_g); (void) hyp_mp (p, y_g, z_g, x_g, digits_g); (void) div_mp (p, z_g, y_g, z_g, digits_g); (void) shorten_mp (p, z, digits, z_g, digits_g); stack_pointer = pop_sp; return (z); } /*! \brief set "z" to atanh ("x") \param p position in tree \param z mp number \param x mp number \param digits precision in mp-digits \return result "z" **/ MP_T *atanh_mp (NODE_T * p, MP_T * z, MP_T * x, int digits) { ADDR_T pop_sp = stack_pointer; int digits_g = FUN_DIGITS (digits); MP_T *x_g, *y_g, *z_g; STACK_MP (x_g, p, digits_g); (void) lengthen_mp (p, x_g, digits_g, x, digits); STACK_MP (y_g, p, digits_g); STACK_MP (z_g, p, digits_g); (void) set_mp_short (y_g, (MP_T) 1, 0, digits_g); (void) add_mp (p, z_g, y_g, x_g, digits_g); (void) sub_mp (p, y_g, y_g, x_g, digits_g); (void) div_mp (p, y_g, z_g, y_g, digits_g); (void) ln_mp (p, z_g, y_g, digits_g); (void) half_mp (p, z_g, z_g, digits_g); (void) shorten_mp (p, z, digits, z_g, digits_g); stack_pointer = pop_sp; return (z); } /*! \brief return "pi" with "digits" precision, using Borwein & Borwein AGM \param p position in tree \param api mp number \param mult small multiplier \param digits precision in mp-digits \return result "api" **/ MP_T *mp_pi (NODE_T * p, MP_T * api, int mult, int digits) { int pop_sp = stack_pointer, digits_g = FUN_DIGITS (digits); BOOL_T iterate; MP_T *pi_g, *one, *two, *x_g, *y_g, *u_g, *v_g; STACK_MP (pi_g, p, digits_g); /* First see if we can restore a previous calculation */ if (digits_g <= mp_pi_size) { MOVE_MP (pi_g, ref_mp_pi, digits_g); } else { /* No luck with the kept value, hence we generate a longer "pi". Calculate "pi" using the Borwein & Borwein AGM algorithm. This AGM doubles the numbers of digits at every pass */ STACK_MP (one, p, digits_g); STACK_MP (two, p, digits_g); STACK_MP (x_g, p, digits_g); STACK_MP (y_g, p, digits_g); STACK_MP (u_g, p, digits_g); STACK_MP (v_g, p, digits_g); (void) set_mp_short (one, (MP_T) 1, 0, digits_g); (void) set_mp_short (two, (MP_T) 2, 0, digits_g); (void) set_mp_short (x_g, (MP_T) 2, 0, digits_g); (void) sqrt_mp (p, x_g, x_g, digits_g); (void) add_mp (p, pi_g, x_g, two, digits_g); (void) sqrt_mp (p, y_g, x_g, digits_g); iterate = A68_TRUE; while (iterate) { /* New x */ (void) sqrt_mp (p, u_g, x_g, digits_g); (void) div_mp (p, v_g, one, u_g, digits_g); (void) add_mp (p, u_g, u_g, v_g, digits_g); (void) half_mp (p, x_g, u_g, digits_g); /* New pi */ (void) add_mp (p, u_g, x_g, one, digits_g); (void) add_mp (p, v_g, y_g, one, digits_g); (void) div_mp (p, u_g, u_g, v_g, digits_g); (void) mul_mp (p, v_g, pi_g, u_g, digits_g); /* Done yet? */ if (same_mp (p, v_g, pi_g, digits_g)) { iterate = A68_FALSE; } else { MOVE_MP (pi_g, v_g, digits_g); /* New y */ (void) sqrt_mp (p, u_g, x_g, digits_g); (void) div_mp (p, v_g, one, u_g, digits_g); (void) mul_mp (p, u_g, y_g, u_g, digits_g); (void) add_mp (p, u_g, u_g, v_g, digits_g); (void) add_mp (p, v_g, y_g, one, digits_g); (void) div_mp (p, y_g, u_g, v_g, digits_g); } } /* Keep the result for future restore */ ref_mp_pi = (MP_T *) get_heap_space ((unsigned) SIZE_MP (digits_g)); MOVE_MP (ref_mp_pi, pi_g, digits_g); mp_pi_size = digits_g; } switch (mult) { case MP_PI: { break; } case MP_TWO_PI: { (void) mul_mp_digit (p, pi_g, pi_g, (MP_T) 2, digits_g); break; } case MP_HALF_PI: { (void) half_mp (p, pi_g, pi_g, digits_g); break; } } (void) shorten_mp (p, api, digits, pi_g, digits_g); stack_pointer = pop_sp; return (api); } /*! \brief set "z" to sin ("x") \param p position in tree \param z mp number \param x mp number \param digits precision in mp-digits \return result "z" **/ MP_T *sin_mp (NODE_T * p, MP_T * z, MP_T * x, int digits) { /* Use triple-angle relation to reduce argument */ int pop_sp = stack_pointer, m, n, digits_g = FUN_DIGITS (digits); BOOL_T flip, negative, iterate, even; MP_T *x_g, *pi, *tpi, *hpi, *sqr, *tmp, *a68g_pow, *fac, *z_g; /* We will use "pi" */ STACK_MP (pi, p, digits_g); STACK_MP (tpi, p, digits_g); STACK_MP (hpi, p, digits_g); (void) mp_pi (p, pi, MP_PI, digits_g); (void) mp_pi (p, tpi, MP_TWO_PI, digits_g); (void) mp_pi (p, hpi, MP_HALF_PI, digits_g); /* Argument reduction (1): sin (x) = sin (x mod 2 pi) */ STACK_MP (x_g, p, digits_g); (void) lengthen_mp (p, x_g, digits_g, x, digits); (void) mod_mp (p, x_g, x_g, tpi, digits_g); /* Argument reduction (2): sin (-x) = sin (x) sin (x) = - sin (x - pi); pi < x <= 2 pi sin (x) = sin (pi - x); pi / 2 < x <= pi */ negative = (BOOL_T) (MP_DIGIT (x_g, 1) < 0); if (negative) { MP_DIGIT (x_g, 1) = -MP_DIGIT (x_g, 1); } STACK_MP (tmp, p, digits_g); (void) sub_mp (p, tmp, x_g, pi, digits_g); flip = (BOOL_T) (MP_DIGIT (tmp, 1) > 0); if (flip) { /* x > pi */ (void) sub_mp (p, x_g, x_g, pi, digits_g); } (void) sub_mp (p, tmp, x_g, hpi, digits_g); if (MP_DIGIT (tmp, 1) > 0) { /* x > pi / 2 */ (void) sub_mp (p, x_g, pi, x_g, digits_g); } /* Argument reduction (3): (follows from De Moivre's theorem) sin (3x) = sin (x) * (3 - 4 sin ^ 2 (x)) */ m = 0; while (eps_mp (x_g, digits_g)) { m++; (void) div_mp_digit (p, x_g, x_g, (MP_T) 3, digits_g); } /* Taylor sum */ STACK_MP (sqr, p, digits_g); STACK_MP (a68g_pow, p, digits_g); STACK_MP (fac, p, digits_g); STACK_MP (z_g, p, digits_g); (void) mul_mp (p, sqr, x_g, x_g, digits_g); /* sqr = x ** 2 */ (void) mul_mp (p, a68g_pow, sqr, x_g, digits_g); /* pow = x ** 3 */ MOVE_MP (z_g, x_g, digits_g); #if (MP_RADIX == DEFAULT_MP_RADIX) (void) div_mp_digit (p, tmp, a68g_pow, (MP_T) 6, digits_g); (void) sub_mp (p, z_g, z_g, tmp, digits_g); (void) mul_mp (p, a68g_pow, a68g_pow, sqr, digits_g); (void) div_mp_digit (p, tmp, a68g_pow, (MP_T) 120, digits_g); (void) add_mp (p, z_g, z_g, tmp, digits_g); (void) mul_mp (p, a68g_pow, a68g_pow, sqr, digits_g); (void) div_mp_digit (p, tmp, a68g_pow, (MP_T) 5040, digits_g); (void) sub_mp (p, z_g, z_g, tmp, digits_g); (void) mul_mp (p, a68g_pow, a68g_pow, sqr, digits_g); (void) set_mp_short (fac, (MP_T) 362880, 0, digits_g); n = 9; even = A68_TRUE; #else (void) set_mp_short (fac, (MP_T) 6, 0, digits_g); n = 3; even = A68_FALSE; #endif iterate = (BOOL_T) (MP_DIGIT (a68g_pow, 1) != 0); while (iterate) { (void) div_mp (p, tmp, a68g_pow, fac, digits_g); if (MP_EXPONENT (tmp) <= (MP_EXPONENT (z_g) - digits_g)) { iterate = A68_FALSE; } else { if (even) { (void) add_mp (p, z_g, z_g, tmp, digits_g); even = A68_FALSE; } else { (void) sub_mp (p, z_g, z_g, tmp, digits_g); even = A68_TRUE; } (void) mul_mp (p, a68g_pow, a68g_pow, sqr, digits_g); (void) mul_mp_digit (p, fac, fac, (MP_T) (++n), digits_g); (void) mul_mp_digit (p, fac, fac, (MP_T) (++n), digits_g); } } /* Inverse scaling using sin (3x) = sin (x) * (3 - 4 sin ** 2 (x)) Use existing mp's for intermediates */ (void) set_mp_short (fac, (MP_T) 3, 0, digits_g); while (m--) { (void) mul_mp (p, a68g_pow, z_g, z_g, digits_g); (void) mul_mp_digit (p, a68g_pow, a68g_pow, (MP_T) 4, digits_g); (void) sub_mp (p, a68g_pow, fac, a68g_pow, digits_g); (void) mul_mp (p, z_g, a68g_pow, z_g, digits_g); } (void) shorten_mp (p, z, digits, z_g, digits_g); if (negative ^ flip) { MP_DIGIT (z, 1) = -MP_DIGIT (z, 1); } /* Exit */ stack_pointer = pop_sp; return (z); } /*! \brief set "z" to cos ("x") \param p position in tree \param z mp number \param x mp number \param digits precision in mp-digits \return result "z" **/ MP_T *cos_mp (NODE_T * p, MP_T * z, MP_T * x, int digits) { /* Use cos (x) = sin (pi / 2 - x). Compute x mod 2 pi before subtracting to avoid cancellation. */ int pop_sp = stack_pointer, digits_g = FUN_DIGITS (digits); MP_T *hpi, *tpi, *x_g, *y; STACK_MP (hpi, p, digits_g); STACK_MP (tpi, p, digits_g); STACK_MP (x_g, p, digits_g); STACK_MP (y, p, digits); (void) lengthen_mp (p, x_g, digits_g, x, digits); (void) mp_pi (p, hpi, MP_HALF_PI, digits_g); (void) mp_pi (p, tpi, MP_TWO_PI, digits_g); (void) mod_mp (p, x_g, x_g, tpi, digits_g); (void) sub_mp (p, x_g, hpi, x_g, digits_g); (void) shorten_mp (p, y, digits, x_g, digits_g); (void) sin_mp (p, z, y, digits); stack_pointer = pop_sp; return (z); } /*! \brief set "z" to tan ("x") \param p position in tree \param z mp number \param x mp number \param digits precision in mp-digits \return result "z" **/ MP_T *tan_mp (NODE_T * p, MP_T * z, MP_T * x, int digits) { /* Use tan (x) = sin (x) / sqrt (1 - sin ^ 2 (x)) */ int pop_sp = stack_pointer, digits_g = FUN_DIGITS (digits); MP_T *sns, *cns, *one, *pi, *hpi, *x_g, *y_g; BOOL_T negate; STACK_MP (one, p, digits); STACK_MP (pi, p, digits_g); STACK_MP (hpi, p, digits_g); STACK_MP (x_g, p, digits_g); STACK_MP (y_g, p, digits_g); STACK_MP (sns, p, digits); STACK_MP (cns, p, digits); /* Argument mod pi */ (void) mp_pi (p, pi, MP_PI, digits_g); (void) mp_pi (p, hpi, MP_HALF_PI, digits_g); (void) lengthen_mp (p, x_g, digits_g, x, digits); (void) mod_mp (p, x_g, x_g, pi, digits_g); if (MP_DIGIT (x_g, 1) >= 0) { (void) sub_mp (p, y_g, x_g, hpi, digits_g); negate = (BOOL_T) (MP_DIGIT (y_g, 1) > 0); } else { (void) add_mp (p, y_g, x_g, hpi, digits_g); negate = (BOOL_T) (MP_DIGIT (y_g, 1) < 0); } (void) shorten_mp (p, x, digits, x_g, digits_g); /* tan(x) = sin(x) / sqrt (1 - sin ** 2 (x)) */ (void) sin_mp (p, sns, x, digits); (void) set_mp_short (one, (MP_T) 1, 0, digits); (void) mul_mp (p, cns, sns, sns, digits); (void) sub_mp (p, cns, one, cns, digits); (void) sqrt_mp (p, cns, cns, digits); if (div_mp (p, z, sns, cns, digits) == NO_MP) { errno = EDOM; stack_pointer = pop_sp; return (NO_MP); } stack_pointer = pop_sp; if (negate) { MP_DIGIT (z, 1) = -MP_DIGIT (z, 1); } return (z); } /*! \brief set "z" to arcsin ("x") \param p position in tree \param z mp number \param x mp number \param digits precision in mp-digits \return result "z" **/ MP_T *asin_mp (NODE_T * p, MP_T * z, MP_T * x, int digits) { int pop_sp = stack_pointer, digits_g = FUN_DIGITS (digits); MP_T *one, *x_g, *y, *z_g; STACK_MP (y, p, digits); STACK_MP (x_g, p, digits_g); STACK_MP (z_g, p, digits_g); STACK_MP (one, p, digits_g); (void) lengthen_mp (p, x_g, digits_g, x, digits); (void) set_mp_short (one, (MP_T) 1, 0, digits_g); (void) mul_mp (p, z_g, x_g, x_g, digits_g); (void) sub_mp (p, z_g, one, z_g, digits_g); if (sqrt_mp (p, z_g, z_g, digits) == NO_MP) { errno = EDOM; stack_pointer = pop_sp; return (NO_MP); } if (MP_DIGIT (z_g, 1) == 0) { (void) mp_pi (p, z, MP_HALF_PI, digits); MP_DIGIT (z, 1) = (MP_DIGIT (x_g, 1) >= 0 ? MP_DIGIT (z, 1) : -MP_DIGIT (z, 1)); stack_pointer = pop_sp; return (z); } if (div_mp (p, x_g, x_g, z_g, digits_g) == NO_MP) { errno = EDOM; stack_pointer = pop_sp; return (NO_MP); } (void) shorten_mp (p, y, digits, x_g, digits_g); (void) atan_mp (p, z, y, digits); stack_pointer = pop_sp; return (z); } /*! \brief set "z" to arccos ("x") \param p position in tree \param z mp number \param x mp number \param digits precision in mp-digits \return result "z" **/ MP_T *acos_mp (NODE_T * p, MP_T * z, MP_T * x, int digits) { int pop_sp = stack_pointer, digits_g = FUN_DIGITS (digits); MP_T *one, *x_g, *y, *z_g; BOOL_T negative = (BOOL_T) (MP_DIGIT (x, 1) < 0); if (MP_DIGIT (x, 1) == 0) { (void) mp_pi (p, z, MP_HALF_PI, digits); stack_pointer = pop_sp; return (z); } STACK_MP (y, p, digits); STACK_MP (x_g, p, digits_g); STACK_MP (z_g, p, digits_g); STACK_MP (one, p, digits_g); (void) lengthen_mp (p, x_g, digits_g, x, digits); (void) set_mp_short (one, (MP_T) 1, 0, digits_g); (void) mul_mp (p, z_g, x_g, x_g, digits_g); (void) sub_mp (p, z_g, one, z_g, digits_g); if (sqrt_mp (p, z_g, z_g, digits) == NO_MP) { errno = EDOM; stack_pointer = pop_sp; return (NO_MP); } if (div_mp (p, x_g, z_g, x_g, digits_g) == NO_MP) { errno = EDOM; stack_pointer = pop_sp; return (NO_MP); } (void) shorten_mp (p, y, digits, x_g, digits_g); (void) atan_mp (p, z, y, digits); if (negative) { (void) mp_pi (p, y, MP_PI, digits); (void) add_mp (p, z, z, y, digits); } stack_pointer = pop_sp; return (z); } /*! \brief set "z" to arctan ("x") \param p position in tree \param z mp number \param x mp number \param digits precision in mp-digits \return result "z" **/ MP_T *atan_mp (NODE_T * p, MP_T * z, MP_T * x, int digits) { /* Depending on the argument we choose either Taylor or Newton */ int pop_sp = stack_pointer, digits_g = FUN_DIGITS (digits); MP_T *x_g, *z_g; BOOL_T flip, negative; STACK_MP (x_g, p, digits_g); STACK_MP (z_g, p, digits_g); if (MP_DIGIT (x, 1) == 0) { stack_pointer = pop_sp; SET_MP_ZERO (z, digits); return (z); } (void) lengthen_mp (p, x_g, digits_g, x, digits); negative = (BOOL_T) (MP_DIGIT (x_g, 1) < 0); if (negative) { MP_DIGIT (x_g, 1) = -MP_DIGIT (x_g, 1); } /* For larger arguments we use atan(x) = pi/2 - atan(1/x) */ flip = (BOOL_T) (((MP_EXPONENT (x_g) > 0) || (MP_EXPONENT (x_g) == 0 && MP_DIGIT (x_g, 1) > 1)) && (MP_DIGIT (x_g, 1) != 0)); if (flip) { (void) rec_mp (p, x_g, x_g, digits_g); } if (MP_EXPONENT (x_g) < -1 || (MP_EXPONENT (x_g) == -1 && MP_DIGIT (x_g, 1) < MP_RADIX / 100)) { /* Taylor sum for x close to zero. arctan (x) = x - x ** 3 / 3 + x ** 5 / 5 - x ** 7 / 7 + .. This is faster for small x and avoids cancellation */ MP_T *tmp, *a68g_pow, *sqr; int n = 3; BOOL_T iterate, even; STACK_MP (tmp, p, digits_g); STACK_MP (a68g_pow, p, digits_g); STACK_MP (sqr, p, digits_g); (void) mul_mp (p, sqr, x_g, x_g, digits_g); (void) mul_mp (p, a68g_pow, sqr, x_g, digits_g); MOVE_MP (z_g, x_g, digits_g); even = A68_FALSE; iterate = (BOOL_T) (MP_DIGIT (a68g_pow, 1) != 0); while (iterate) { (void) div_mp_digit (p, tmp, a68g_pow, (MP_T) n, digits_g); if (MP_EXPONENT (tmp) <= (MP_EXPONENT (z_g) - digits_g)) { iterate = A68_FALSE; } else { if (even) { (void) add_mp (p, z_g, z_g, tmp, digits_g); even = A68_FALSE; } else { (void) sub_mp (p, z_g, z_g, tmp, digits_g); even = A68_TRUE; } (void) mul_mp (p, a68g_pow, a68g_pow, sqr, digits_g); n += 2; } } } else { /* Newton's method: x = x - cos (x) * (sin (x) - a cos (x)) */ MP_T *tmp, *z_0, *sns, *cns, *one; int decimals, digits_h; STACK_MP (tmp, p, digits_g); STACK_MP (z_0, p, digits_g); STACK_MP (sns, p, digits_g); STACK_MP (cns, p, digits_g); STACK_MP (one, p, digits_g); SET_MP_ZERO (z_0, digits_g); (void) set_mp_short (one, (MP_T) 1, 0, digits_g); /* Construct an estimate */ (void) real_to_mp (p, z_g, atan (mp_to_real (p, x_g, digits_g)), digits_g); decimals = DOUBLE_ACCURACY; do { decimals <<= 1; digits_h = MINIMUM (1 + decimals / LOG_MP_BASE, digits_g); (void) sin_mp (p, sns, z_g, digits_h); (void) mul_mp (p, tmp, sns, sns, digits_h); (void) sub_mp (p, tmp, one, tmp, digits_h); (void) sqrt_mp (p, cns, tmp, digits_h); (void) mul_mp (p, tmp, x_g, cns, digits_h); (void) sub_mp (p, tmp, sns, tmp, digits_h); (void) mul_mp (p, tmp, tmp, cns, digits_h); (void) sub_mp (p, z_g, z_g, tmp, digits_h); } while (decimals < digits_g * LOG_MP_BASE); } if (flip) { MP_T *hpi; STACK_MP (hpi, p, digits_g); (void) sub_mp (p, z_g, mp_pi (p, hpi, MP_HALF_PI, digits_g), z_g, digits_g); } (void) shorten_mp (p, z, digits, z_g, digits_g); MP_DIGIT (z, 1) = (negative ? -MP_DIGIT (z, 1) : MP_DIGIT (z, 1)); /* Exit */ stack_pointer = pop_sp; return (z); } /*! \brief set "z" to atan2 ("x", "y") \param p position in tree \param z mp number \param x mp number \param y mp number \param digits precision in mp-digits \return result "z" **/ MP_T *atan2_mp (NODE_T * p, MP_T * z, MP_T * x, MP_T * y, int digits) { ADDR_T pop_sp = stack_pointer; MP_T *t; STACK_MP (t, p, digits); if (MP_DIGIT (x, 1) == 0 && MP_DIGIT (y, 1) == 0) { errno = EDOM; stack_pointer = pop_sp; return (NO_MP); } else { BOOL_T flip = (BOOL_T) (MP_DIGIT (y, 1) < 0); MP_DIGIT (y, 1) = ABS (MP_DIGIT (y, 1)); if (IS_ZERO_MP (x)) { (void) mp_pi (p, z, MP_HALF_PI, digits); } else { BOOL_T flop = (BOOL_T) (MP_DIGIT (x, 1) <= 0); MP_DIGIT (x, 1) = ABS (MP_DIGIT (x, 1)); (void) div_mp (p, z, y, x, digits); (void) atan_mp (p, z, z, digits); if (flop) { (void) mp_pi (p, t, MP_PI, digits); (void) sub_mp (p, z, t, z, digits); } } if (flip) { MP_DIGIT (z, 1) = -MP_DIGIT (z, 1); } } stack_pointer = pop_sp; return (z); } /*! \brief set "a" I "b" to "a" I "b" * "c" I "d" \param p position in tree \param a real mp number \param b imaginary mp number \param c real mp number \param d imaginary mp number \param digits precision in mp-digits \return real part of result **/ MP_T *cmul_mp (NODE_T * p, MP_T * a, MP_T * b, MP_T * c, MP_T * d, int digits) { ADDR_T pop_sp = stack_pointer; int digits_g = FUN_DIGITS (digits); MP_T *la, *lb, *lc, *ld, *ac, *bd, *ad, *bc; STACK_MP (la, p, digits_g); STACK_MP (lb, p, digits_g); STACK_MP (lc, p, digits_g); STACK_MP (ld, p, digits_g); (void) lengthen_mp (p, la, digits_g, a, digits); (void) lengthen_mp (p, lb, digits_g, b, digits); (void) lengthen_mp (p, lc, digits_g, c, digits); (void) lengthen_mp (p, ld, digits_g, d, digits); STACK_MP (ac, p, digits_g); STACK_MP (bd, p, digits_g); STACK_MP (ad, p, digits_g); STACK_MP (bc, p, digits_g); (void) mul_mp (p, ac, la, lc, digits_g); (void) mul_mp (p, bd, lb, ld, digits_g); (void) mul_mp (p, ad, la, ld, digits_g); (void) mul_mp (p, bc, lb, lc, digits_g); (void) sub_mp (p, la, ac, bd, digits_g); (void) add_mp (p, lb, ad, bc, digits_g); (void) shorten_mp (p, a, digits, la, digits_g); (void) shorten_mp (p, b, digits, lb, digits_g); stack_pointer = pop_sp; return (a); } /*! \brief set "a" I "b" to "a" I "b" / "c" I "d" \param p position in tree \param a real mp number \param b imaginary mp number \param c real mp number \param d imaginary mp number \param digits precision in mp-digits \return real part of result **/ MP_T *cdiv_mp (NODE_T * p, MP_T * a, MP_T * b, MP_T * c, MP_T * d, int digits) { ADDR_T pop_sp = stack_pointer; MP_T *q, *r; if (MP_DIGIT (c, 1) == (MP_T) 0 && MP_DIGIT (d, 1) == (MP_T) 0) { errno = ERANGE; return (NO_MP); } STACK_MP (q, p, digits); STACK_MP (r, p, digits); MOVE_MP (q, c, digits); MOVE_MP (r, d, digits); MP_DIGIT (q, 1) = ABS (MP_DIGIT (q, 1)); MP_DIGIT (r, 1) = ABS (MP_DIGIT (r, 1)); (void) sub_mp (p, q, q, r, digits); if (MP_DIGIT (q, 1) >= 0) { if (div_mp (p, q, d, c, digits) == NO_MP) { errno = ERANGE; return (NO_MP); } (void) mul_mp (p, r, d, q, digits); (void) add_mp (p, r, r, c, digits); (void) mul_mp (p, c, b, q, digits); (void) add_mp (p, c, c, a, digits); (void) div_mp (p, c, c, r, digits); (void) mul_mp (p, d, a, q, digits); (void) sub_mp (p, d, b, d, digits); (void) div_mp (p, d, d, r, digits); } else { if (div_mp (p, q, c, d, digits) == NO_MP) { errno = ERANGE; return (NO_MP); } (void) mul_mp (p, r, c, q, digits); (void) add_mp (p, r, r, d, digits); (void) mul_mp (p, c, a, q, digits); (void) add_mp (p, c, c, b, digits); (void) div_mp (p, c, c, r, digits); (void) mul_mp (p, d, b, q, digits); (void) sub_mp (p, d, d, a, digits); (void) div_mp (p, d, d, r, digits); } MOVE_MP (a, c, digits); MOVE_MP (b, d, digits); stack_pointer = pop_sp; return (a); } /*! \brief set "r" I "i" to sqrt ("r" I "i") \param p position in tree \param r mp real part \param i mp imaginary part \param digits precision in mp-digits \return real part of result **/ MP_T *csqrt_mp (NODE_T * p, MP_T * r, MP_T * i, int digits) { ADDR_T pop_sp = stack_pointer; MP_T *re, *im; int digits_g = FUN_DIGITS (digits); STACK_MP (re, p, digits_g); STACK_MP (im, p, digits_g); (void) lengthen_mp (p, re, digits_g, r, digits); (void) lengthen_mp (p, im, digits_g, i, digits); if (IS_ZERO_MP (re) && IS_ZERO_MP (im)) { SET_MP_ZERO (re, digits_g); SET_MP_ZERO (im, digits_g); } else { MP_T *c1, *t, *x, *y, *u, *v, *w; STACK_MP (c1, p, digits_g); STACK_MP (t, p, digits_g); STACK_MP (x, p, digits_g); STACK_MP (y, p, digits_g); STACK_MP (u, p, digits_g); STACK_MP (v, p, digits_g); STACK_MP (w, p, digits_g); (void) set_mp_short (c1, (MP_T) 1, 0, digits_g); MOVE_MP (x, re, digits_g); MOVE_MP (y, im, digits_g); MP_DIGIT (x, 1) = ABS (MP_DIGIT (x, 1)); MP_DIGIT (y, 1) = ABS (MP_DIGIT (y, 1)); (void) sub_mp (p, w, x, y, digits_g); if (MP_DIGIT (w, 1) >= 0) { (void) div_mp (p, t, y, x, digits_g); (void) mul_mp (p, v, t, t, digits_g); (void) add_mp (p, u, c1, v, digits_g); (void) sqrt_mp (p, v, u, digits_g); (void) add_mp (p, u, c1, v, digits_g); (void) half_mp (p, v, u, digits_g); (void) sqrt_mp (p, u, v, digits_g); (void) sqrt_mp (p, v, x, digits_g); (void) mul_mp (p, w, u, v, digits_g); } else { (void) div_mp (p, t, x, y, digits_g); (void) mul_mp (p, v, t, t, digits_g); (void) add_mp (p, u, c1, v, digits_g); (void) sqrt_mp (p, v, u, digits_g); (void) add_mp (p, u, t, v, digits_g); (void) half_mp (p, v, u, digits_g); (void) sqrt_mp (p, u, v, digits_g); (void) sqrt_mp (p, v, y, digits_g); (void) mul_mp (p, w, u, v, digits_g); } if (MP_DIGIT (re, 1) >= 0) { MOVE_MP (re, w, digits_g); (void) add_mp (p, u, w, w, digits_g); (void) div_mp (p, im, im, u, digits_g); } else { if (MP_DIGIT (im, 1) < 0) { MP_DIGIT (w, 1) = -MP_DIGIT (w, 1); } (void) add_mp (p, v, w, w, digits_g); (void) div_mp (p, re, im, v, digits_g); MOVE_MP (im, w, digits_g); } } (void) shorten_mp (p, r, digits, re, digits_g); (void) shorten_mp (p, i, digits, im, digits_g); stack_pointer = pop_sp; return (r); } /*! \brief set "r" I "i" to exp("r" I "i") \param p position in tree \param r mp real part \param i mp imaginary part \param digits precision in mp-digits \return real part of result **/ MP_T *cexp_mp (NODE_T * p, MP_T * r, MP_T * i, int digits) { ADDR_T pop_sp = stack_pointer; MP_T *re, *im, *u; int digits_g = FUN_DIGITS (digits); STACK_MP (re, p, digits_g); STACK_MP (im, p, digits_g); (void) lengthen_mp (p, re, digits_g, r, digits); (void) lengthen_mp (p, im, digits_g, i, digits); STACK_MP (u, p, digits_g); (void) exp_mp (p, u, re, digits_g); (void) cos_mp (p, re, im, digits_g); (void) sin_mp (p, im, im, digits_g); (void) mul_mp (p, re, re, u, digits_g); (void) mul_mp (p, im, im, u, digits_g); (void) shorten_mp (p, r, digits, re, digits_g); (void) shorten_mp (p, i, digits, im, digits_g); stack_pointer = pop_sp; return (r); } /*! \brief set "r" I "i" to ln ("r" I "i") \param p position in tree \param r mp real part \param i mp imaginary part \param digits precision in mp-digits \return real part of result **/ MP_T *cln_mp (NODE_T * p, MP_T * r, MP_T * i, int digits) { ADDR_T pop_sp = stack_pointer; MP_T *re, *im, *u, *v, *s, *t; int digits_g = FUN_DIGITS (digits); STACK_MP (re, p, digits_g); STACK_MP (im, p, digits_g); (void) lengthen_mp (p, re, digits_g, r, digits); (void) lengthen_mp (p, im, digits_g, i, digits); STACK_MP (s, p, digits_g); STACK_MP (t, p, digits_g); STACK_MP (u, p, digits_g); STACK_MP (v, p, digits_g); MOVE_MP (u, re, digits_g); MOVE_MP (v, im, digits_g); (void) hypot_mp (p, s, u, v, digits_g); MOVE_MP (u, re, digits_g); MOVE_MP (v, im, digits_g); (void) atan2_mp (p, t, u, v, digits_g); (void) ln_mp (p, re, s, digits_g); MOVE_MP (im, t, digits_g); (void) shorten_mp (p, r, digits, re, digits_g); (void) shorten_mp (p, i, digits, im, digits_g); stack_pointer = pop_sp; return (r); } /*! \brief set "r" I "i" to sin ("r" I "i") \param p position in tree \param r mp real part \param i mp imaginary part \param digits precision in mp-digits \return real part of result **/ MP_T *csin_mp (NODE_T * p, MP_T * r, MP_T * i, int digits) { ADDR_T pop_sp = stack_pointer; MP_T *re, *im, *s, *c, *sh, *ch; int digits_g = FUN_DIGITS (digits); STACK_MP (re, p, digits_g); STACK_MP (im, p, digits_g); (void) lengthen_mp (p, re, digits_g, r, digits); (void) lengthen_mp (p, im, digits_g, i, digits); STACK_MP (s, p, digits_g); STACK_MP (c, p, digits_g); STACK_MP (sh, p, digits_g); STACK_MP (ch, p, digits_g); if (IS_ZERO_MP (im)) { (void) sin_mp (p, re, re, digits_g); SET_MP_ZERO (im, digits_g); } else { (void) sin_mp (p, s, re, digits_g); (void) cos_mp (p, c, re, digits_g); (void) hyp_mp (p, sh, ch, im, digits_g); (void) mul_mp (p, re, s, ch, digits_g); (void) mul_mp (p, im, c, sh, digits_g); } (void) shorten_mp (p, r, digits, re, digits_g); (void) shorten_mp (p, i, digits, im, digits_g); stack_pointer = pop_sp; return (r); } /*! \brief set "r" I "i" to cos ("r" I "i") \param p position in tree \param r mp real part \param i mp imaginary part \param digits precision in mp-digits \return real part of result **/ MP_T *ccos_mp (NODE_T * p, MP_T * r, MP_T * i, int digits) { ADDR_T pop_sp = stack_pointer; MP_T *re, *im, *s, *c, *sh, *ch; int digits_g = FUN_DIGITS (digits); STACK_MP (re, p, digits_g); STACK_MP (im, p, digits_g); (void) lengthen_mp (p, re, digits_g, r, digits); (void) lengthen_mp (p, im, digits_g, i, digits); STACK_MP (s, p, digits_g); STACK_MP (c, p, digits_g); STACK_MP (sh, p, digits_g); STACK_MP (ch, p, digits_g); if (IS_ZERO_MP (im)) { (void) cos_mp (p, re, re, digits_g); SET_MP_ZERO (im, digits_g); } else { (void) sin_mp (p, s, re, digits_g); (void) cos_mp (p, c, re, digits_g); (void) hyp_mp (p, sh, ch, im, digits_g); MP_DIGIT (sh, 1) = -MP_DIGIT (sh, 1); (void) mul_mp (p, re, c, ch, digits_g); (void) mul_mp (p, im, s, sh, digits_g); } (void) shorten_mp (p, r, digits, re, digits_g); (void) shorten_mp (p, i, digits, im, digits_g); stack_pointer = pop_sp; return (r); } /*! \brief set "r" I "i" to tan ("r" I "i") \param p position in tree \param r mp real part \param i mp imaginary part \param digits precision in mp-digits \return real part of result **/ MP_T *ctan_mp (NODE_T * p, MP_T * r, MP_T * i, int digits) { ADDR_T pop_sp = stack_pointer; MP_T *s, *t, *u, *v; RESET_ERRNO; STACK_MP (s, p, digits); STACK_MP (t, p, digits); STACK_MP (u, p, digits); STACK_MP (v, p, digits); MOVE_MP (u, r, digits); MOVE_MP (v, i, digits); (void) csin_mp (p, u, v, digits); MOVE_MP (s, u, digits); MOVE_MP (t, v, digits); MOVE_MP (u, r, digits); MOVE_MP (v, i, digits); (void) ccos_mp (p, u, v, digits); (void) cdiv_mp (p, s, t, u, v, digits); MOVE_MP (r, s, digits); MOVE_MP (i, t, digits); stack_pointer = pop_sp; return (r); } /*! \brief set "r" I "i" to asin ("r" I "i") \param p position in tree \param r mp real part \param i mp imaginary part \param digits precision in mp-digits \return real part of result **/ MP_T *casin_mp (NODE_T * p, MP_T * r, MP_T * i, int digits) { ADDR_T pop_sp = stack_pointer; MP_T *re, *im; int digits_g = FUN_DIGITS (digits); STACK_MP (re, p, digits_g); STACK_MP (im, p, digits_g); (void) lengthen_mp (p, re, digits_g, r, digits); (void) lengthen_mp (p, im, digits_g, i, digits); if (IS_ZERO_MP (im)) { (void) asin_mp (p, re, re, digits_g); } else { MP_T *c1, *u, *v, *a, *b; STACK_MP (c1, p, digits_g); (void) set_mp_short (c1, (MP_T) 1, 0, digits_g); STACK_MP (u, p, digits_g); STACK_MP (v, p, digits_g); STACK_MP (a, p, digits_g); STACK_MP (b, p, digits_g); /* u=sqrt((r+1)^2+i^2), v=sqrt((r-1)^2+i^2) */ (void) add_mp (p, a, re, c1, digits_g); (void) sub_mp (p, b, re, c1, digits_g); (void) hypot_mp (p, u, a, im, digits_g); (void) hypot_mp (p, v, b, im, digits_g); /* a=(u+v)/2, b=(u-v)/2 */ (void) add_mp (p, a, u, v, digits_g); (void) half_mp (p, a, a, digits_g); (void) sub_mp (p, b, u, v, digits_g); (void) half_mp (p, b, b, digits_g); /* r=asin(b), i=ln(a+sqrt(a^2-1)) */ (void) mul_mp (p, u, a, a, digits_g); (void) sub_mp (p, u, u, c1, digits_g); (void) sqrt_mp (p, u, u, digits_g); (void) add_mp (p, u, a, u, digits_g); (void) ln_mp (p, im, u, digits_g); (void) asin_mp (p, re, b, digits_g); } (void) shorten_mp (p, r, digits, re, digits_g); (void) shorten_mp (p, i, digits, im, digits_g); stack_pointer = pop_sp; return (re); } /*! \brief set "r" I "i" to acos ("r" I "i") \param p position in tree \param r mp real part \param i mp imaginary part \param digits precision in mp-digits \return real part of result **/ MP_T *cacos_mp (NODE_T * p, MP_T * r, MP_T * i, int digits) { ADDR_T pop_sp = stack_pointer; MP_T *re, *im; int digits_g = FUN_DIGITS (digits); STACK_MP (re, p, digits_g); STACK_MP (im, p, digits_g); (void) lengthen_mp (p, re, digits_g, r, digits); (void) lengthen_mp (p, im, digits_g, i, digits); if (IS_ZERO_MP (im)) { (void) acos_mp (p, re, re, digits_g); } else { MP_T *c1, *u, *v, *a, *b; STACK_MP (c1, p, digits_g); (void) set_mp_short (c1, (MP_T) 1, 0, digits_g); STACK_MP (u, p, digits_g); STACK_MP (v, p, digits_g); STACK_MP (a, p, digits_g); STACK_MP (b, p, digits_g); /* u=sqrt((r+1)^2+i^2), v=sqrt((r-1)^2+i^2) */ (void) add_mp (p, a, re, c1, digits_g); (void) sub_mp (p, b, re, c1, digits_g); (void) hypot_mp (p, u, a, im, digits_g); (void) hypot_mp (p, v, b, im, digits_g); /* a=(u+v)/2, b=(u-v)/2 */ (void) add_mp (p, a, u, v, digits_g); (void) half_mp (p, a, a, digits_g); (void) sub_mp (p, b, u, v, digits_g); (void) half_mp (p, b, b, digits_g); /* r=acos(b), i=-ln(a+sqrt(a^2-1)) */ (void) mul_mp (p, u, a, a, digits_g); (void) sub_mp (p, u, u, c1, digits_g); (void) sqrt_mp (p, u, u, digits_g); (void) add_mp (p, u, a, u, digits_g); (void) ln_mp (p, im, u, digits_g); MP_DIGIT (im, 1) = -MP_DIGIT (im, 1); (void) acos_mp (p, re, b, digits_g); } (void) shorten_mp (p, r, digits, re, digits_g); (void) shorten_mp (p, i, digits, im, digits_g); stack_pointer = pop_sp; return (re); } /*! \brief set "r" I "i" to atan ("r" I "i") \param p position in tree \param r mp real part \param i mp imaginary part \param digits precision in mp-digits \return real part of result **/ MP_T *catan_mp (NODE_T * p, MP_T * r, MP_T * i, int digits) { ADDR_T pop_sp = stack_pointer; MP_T *re, *im, *u, *v; int digits_g = FUN_DIGITS (digits); STACK_MP (re, p, digits_g); STACK_MP (im, p, digits_g); (void) lengthen_mp (p, re, digits_g, r, digits); (void) lengthen_mp (p, im, digits_g, i, digits); STACK_MP (u, p, digits_g); STACK_MP (v, p, digits_g); if (IS_ZERO_MP (im)) { (void) atan_mp (p, u, re, digits_g); SET_MP_ZERO (v, digits_g); } else { MP_T *c1, *a, *b; STACK_MP (c1, p, digits_g); (void) set_mp_short (c1, (MP_T) 1, 0, digits_g); STACK_MP (a, p, digits_g); STACK_MP (b, p, digits_g); /* a=sqrt(r^2+(i+1)^2), b=sqrt(r^2+(i-1)^2) */ (void) add_mp (p, a, im, c1, digits_g); (void) sub_mp (p, b, im, c1, digits_g); (void) hypot_mp (p, u, re, a, digits_g); (void) hypot_mp (p, v, re, b, digits_g); /* im=ln(a/b)/4 */ (void) div_mp (p, u, u, v, digits_g); (void) ln_mp (p, u, u, digits_g); (void) half_mp (p, v, u, digits_g); /* re=atan(2r/(1-r^2-i^2)) */ (void) mul_mp (p, a, re, re, digits_g); (void) mul_mp (p, b, im, im, digits_g); (void) sub_mp (p, u, c1, a, digits_g); (void) sub_mp (p, b, u, b, digits_g); (void) add_mp (p, a, re, re, digits_g); (void) div_mp (p, a, a, b, digits_g); (void) atan_mp (p, u, a, digits_g); (void) half_mp (p, u, u, digits_g); } (void) shorten_mp (p, r, digits, u, digits_g); (void) shorten_mp (p, i, digits, v, digits_g); stack_pointer = pop_sp; return (re); } /*! \brief comparison of "x" and "y" \param p position in tree \param x mp number \param y mp number \param digits precision in mp-digits \return whether x = y **/ void eq_mp (NODE_T * p, A68_BOOL * z, MP_T * x, MP_T * y, int digits) { ADDR_T pop_sp = stack_pointer; MP_T *v; STACK_MP (v, p, digits); (void) sub_mp (p, v, x, y, digits); STATUS (z) = INIT_MASK; VALUE (z) = (MP_DIGIT (v, 1) == 0 ? A68_TRUE : A68_FALSE); stack_pointer = pop_sp; } /*! \brief comparison of "x" and "y" \param p position in tree \param x mp number \param y mp number \param digits precision in mp-digits \return whether x != y **/ void ne_mp (NODE_T * p, A68_BOOL * z, MP_T * x, MP_T * y, int digits) { ADDR_T pop_sp = stack_pointer; MP_T *v; STACK_MP (v, p, digits); (void) sub_mp (p, v, x, y, digits); STATUS (z) = INIT_MASK; VALUE (z) = (MP_DIGIT (v, 1) != 0 ? A68_TRUE : A68_FALSE); stack_pointer = pop_sp; } /*! \brief comparison of "x" and "y" \param p position in tree \param x mp number \param y mp number \param digits precision in mp-digits \return whether x < y **/ void lt_mp (NODE_T * p, A68_BOOL * z, MP_T * x, MP_T * y, int digits) { ADDR_T pop_sp = stack_pointer; MP_T *v; STACK_MP (v, p, digits); (void) sub_mp (p, v, x, y, digits); STATUS (z) = INIT_MASK; VALUE (z) = (MP_DIGIT (v, 1) < 0 ? A68_TRUE : A68_FALSE); stack_pointer = pop_sp; } /*! \brief comparison of "x" and "y" \param p position in tree \param x mp number \param y mp number \param digits precision in mp-digits \return whether x <= y **/ void le_mp (NODE_T * p, A68_BOOL * z, MP_T * x, MP_T * y, int digits) { ADDR_T pop_sp = stack_pointer; MP_T *v; STACK_MP (v, p, digits); (void) sub_mp (p, v, x, y, digits); STATUS (z) = INIT_MASK; VALUE (z) = (MP_DIGIT (v, 1) <= 0 ? A68_TRUE : A68_FALSE); stack_pointer = pop_sp; } /*! \brief comparison of "x" and "y" \param p position in tree \param x mp number \param y mp number \param digits precision in mp-digits \return whether x > y **/ void gt_mp (NODE_T * p, A68_BOOL * z, MP_T * x, MP_T * y, int digits) { ADDR_T pop_sp = stack_pointer; MP_T *v; STACK_MP (v, p, digits); (void) sub_mp (p, v, x, y, digits); STATUS (z) = INIT_MASK; VALUE (z) = (MP_DIGIT (v, 1) > 0 ? A68_TRUE : A68_FALSE); stack_pointer = pop_sp; } /*! \brief comparison of "x" and "y" \param p position in tree \param x mp number \param y mp number \param digits precision in mp-digits \return whether x >= y **/ void ge_mp (NODE_T * p, A68_BOOL * z, MP_T * x, MP_T * y, int digits) { ADDR_T pop_sp = stack_pointer; MP_T *v; STACK_MP (v, p, digits); (void) sub_mp (p, v, x, y, digits); STATUS (z) = INIT_MASK; VALUE (z) = (MP_DIGIT (v, 1) >= 0 ? A68_TRUE : A68_FALSE); stack_pointer = pop_sp; } /*! \brief rounding \param p position in tree \param z mp number \param x mp number \param digits precision in mp-digits \return round (x) **/ MP_T *round_mp (NODE_T * p, MP_T * z, MP_T * x, int digits) { MP_T *y; STACK_MP (y, p, digits); (void) set_mp_short (y, (MP_T) (MP_RADIX / 2), -1, digits); if (MP_DIGIT (x, 1) >= 0) { (void) add_mp (p, z, x, y, digits); (void) trunc_mp (p, z, z, digits); } else { (void) sub_mp (p, z, x, y, digits); (void) trunc_mp (p, z, z, digits); } MP_STATUS (z) = (MP_T) INIT_MASK; return (z); } /*! \brief rounding \param p position in tree \param z mp number \param x mp number \param digits precision in mp-digits \return entier (x) **/ MP_T *entier_mp (NODE_T * p, MP_T * z, MP_T * x, int digits) { if (MP_DIGIT (x, 1) >= 0) { (void) trunc_mp (p, z, x, digits); } else { MP_T *y; STACK_MP (y, p, digits); MOVE_MP (y, z, digits); (void) trunc_mp (p, z, x, digits); (void) sub_mp (p, y, y, z, digits); if (MP_DIGIT (y, 1) != 0) { (void) set_mp_short (y, (MP_T) 1, 0, digits); (void) sub_mp (p, z, z, y, digits); } } MP_STATUS (z) = (MP_T) INIT_MASK; return (z); } /*! \brief absolute value \param p position in tree \param z mp number \param x mp number \param digits precision in mp-digits \return |x| **/ MP_T *abs_mp (NODE_T * p, MP_T * z, MP_T * x, int digits) { (void) p; if (x != z) { MOVE_MP (z, x, digits); } MP_DIGIT (z, 1) = fabs (MP_DIGIT (z, 1)); MP_STATUS (z) = (MP_T) INIT_MASK; return (z); } /*! \brief change sign \param p position in tree \param z mp number \param x mp number \param digits precision in mp-digits \return -x **/ MP_T *minus_mp (NODE_T * p, MP_T * z, MP_T * x, int digits) { (void) p; if (x != z) { MOVE_MP (z, x, digits); } MP_DIGIT (z, 1) = -MP_DIGIT (z, 1); MP_STATUS (z) = (MP_T) INIT_MASK; return (z); } algol68g-2.4.1/source/a68g-config.h0000644000175000001440000002422711770455757013570 00000000000000/* source/a68g-config.h. Generated from a68g-config.h.in by configure. */ /* source/a68g-config.h.in. Generated from configure.ac by autoheader. */ /* Define to 1 if `TIOCGWINSZ' requires . */ #define GWINSZ_IN_SYS_IOCTL 1 /* Define to 1 if you have the header file. */ #define HAVE_ASSERT_H 1 /* Define to 1 if you have the header file. */ #define HAVE_CTYPE_H 1 /* Define this if curses was detected */ #define HAVE_CURSES 1 /* Define to 1 if you have the header file. */ #define HAVE_CURSES_H 1 /* Define to 1 if you have the header file, and it defines `DIR'. */ #define HAVE_DIRENT_H 1 /* Define this if a good DL installation was detected */ #define HAVE_DL 1 /* Define to 1 if you have the header file. */ #define HAVE_DLFCN_H 1 /* Define to 1 if you have the header file. */ #define HAVE_ERRNO_H 1 /* Define to 1 if you have the `exit' function. */ #define HAVE_EXIT 1 /* Define this if EXPORT_DYNAMIC is recognised */ #define HAVE_EXPORT_DYNAMIC 1 /* Define to 1 if you have the header file. */ #define HAVE_FCNTL_H 1 /* Define to 1 if you have the header file. */ #define HAVE_FLOAT_H 1 /* Define to 1 if you have the `fprintf' function. */ #define HAVE_FPRINTF 1 /* Define to 1 if you have the `free' function. */ #define HAVE_FREE 1 /* Define this if FreeBSD was detected */ /* #undef HAVE_FREEBSD */ /* Define this if GCC was detected */ #define HAVE_GCC 1 /* Define this if a good GNU GSL installation was detected */ #define HAVE_GNU_GSL 1 /* Define this if a good GNU plotutils installation was detected */ #define HAVE_GNU_PLOTUTILS 1 /* Define to 1 if you have the header file. */ #define HAVE_GSL_GSL_BLAS_H 1 /* Define to 1 if you have the header file. */ #define HAVE_GSL_GSL_COMPLEX_H 1 /* Define to 1 if you have the header file. */ #define HAVE_GSL_GSL_COMPLEX_MATH_H 1 /* Define to 1 if you have the header file. */ #define HAVE_GSL_GSL_ERRNO_H 1 /* Define to 1 if you have the header file. */ #define HAVE_GSL_GSL_FFT_COMPLEX_H 1 /* Define to 1 if you have the header file. */ #define HAVE_GSL_GSL_INTEGRATION_H 1 /* Define to 1 if you have the header file. */ #define HAVE_GSL_GSL_LINALG_H 1 /* Define to 1 if you have the header file. */ #define HAVE_GSL_GSL_MATH_H 1 /* Define to 1 if you have the header file. */ #define HAVE_GSL_GSL_MATRIX_H 1 /* Define to 1 if you have the header file. */ #define HAVE_GSL_GSL_PERMUTATION_H 1 /* Define to 1 if you have the header file. */ #define HAVE_GSL_GSL_SF_H 1 /* Define to 1 if you have the header file. */ #define HAVE_GSL_GSL_VECTOR_H 1 /* Define this if IEEE_754 compliant */ #define HAVE_IEEE_754 1 /* Define to 1 if you have the header file. */ #define HAVE_INTTYPES_H 1 /* Define to 1 if you have the `dl' library (-ldl). */ #define HAVE_LIBDL 1 /* Define to 1 if you have the `gsl' library (-lgsl). */ #define HAVE_LIBGSL 1 /* Define to 1 if you have the `gslcblas' library (-lgslcblas). */ #define HAVE_LIBGSLCBLAS 1 /* Define to 1 if you have the `m' library (-lm). */ #define HAVE_LIBM 1 /* Define to 1 if you have the `ncurses' library (-lncurses). */ #define HAVE_LIBNCURSES 1 /* Define to 1 if you have the `plot' library (-lplot). */ #define HAVE_LIBPLOT 1 /* Define to 1 if you have the `pq' library (-lpq). */ #define HAVE_LIBPQ 1 /* Define to 1 if you have the header file. */ #define HAVE_LIBPQ_FE_H 1 /* Define to 1 if you have the `pthread' library (-lpthread). */ #define HAVE_LIBPTHREAD 1 /* Define to 1 if you have the `readline' library (-lreadline). */ #define HAVE_LIBREADLINE 1 /* Define to 1 if you have the header file. */ #define HAVE_LIMITS_H 1 /* Define this if LINUX was detected */ #define HAVE_LINUX 1 /* Define to 1 if you have the `longjmp' function. */ #define HAVE_LONGJMP 1 /* Define this if DARWIN was detected */ /* #undef HAVE_MAC_OS_X */ /* Define to 1 if you have the `malloc' function. */ #define HAVE_MALLOC 1 /* Define to 1 if you have the header file. */ #define HAVE_MATH_H 1 /* Define to 1 if you have the `memcpy' function. */ #define HAVE_MEMCPY 1 /* Define to 1 if you have the `memmove' function. */ #define HAVE_MEMMOVE 1 /* Define to 1 if you have the header file. */ #define HAVE_MEMORY_H 1 /* Define to 1 if you have the `memset' function. */ #define HAVE_MEMSET 1 /* Define to 1 if you have the header file. */ /* #undef HAVE_NCURSES_CURSES_H */ /* Define to 1 if you have the header file, and it defines `DIR'. */ /* #undef HAVE_NDIR_H */ /* Define this if NetBSD was detected */ /* #undef HAVE_NETBSD */ /* Define to 1 if you have the header file. */ #define HAVE_NETDB_H 1 /* Define to 1 if you have the header file. */ #define HAVE_NETINET_IN_H 1 /* Define this if OpenBSD was detected */ /* #undef HAVE_OPENBSD */ /* Define this if /opt/local/pgsql/include was detected */ /* #undef HAVE_OPT_LOCAL_PGSQL_INCLUDE */ /* Define this if a good pthread installation was detected */ #define HAVE_PARALLEL_CLAUSE 1 /* Define this as PIC option */ #define HAVE_PIC "-fPIC" /* Define to 1 if you have the header file. */ #define HAVE_PLOT_H 1 /* Define this if a good PostgreSQL installation was detected */ #define HAVE_POSTGRESQL 1 /* Define to 1 if you have the `printf' function. */ #define HAVE_PRINTF 1 /* Define to 1 if you have the header file. */ #define HAVE_PTHREAD_H 1 /* Define this if readline was detected */ #define HAVE_READLINE 1 /* Define to 1 if you have the header file. */ #define HAVE_READLINE_HISTORY_H 1 /* Define to 1 if you have the header file. */ #define HAVE_READLINE_READLINE_H 1 /* Define to 1 if you have the header file. */ #define HAVE_REGEX_H 1 /* Define to 1 if you have the `setjmp' function. */ #define HAVE_SETJMP 1 /* Define to 1 if you have the header file. */ #define HAVE_SETJMP_H 1 /* Define to 1 if you have the `signal' function. */ #define HAVE_SIGNAL 1 /* Define to 1 if you have the header file. */ #define HAVE_SIGNAL_H 1 /* Define to 1 if you have the `snprintf' function. */ #define HAVE_SNPRINTF 1 /* Define to 1 if you have the header file. */ #define HAVE_STDARG_H 1 /* Define to 1 if you have the header file. */ #define HAVE_STDDEF_H 1 /* Define to 1 if you have the header file. */ #define HAVE_STDINT_H 1 /* Define to 1 if you have the header file. */ #define HAVE_STDIO_H 1 /* Define to 1 if you have the header file. */ #define HAVE_STDLIB_H 1 /* Define to 1 if you have the `strcmp' function. */ #define HAVE_STRCMP 1 /* Define to 1 if you have the header file. */ #define HAVE_STRINGS_H 1 /* Define to 1 if you have the header file. */ #define HAVE_STRING_H 1 /* Define to 1 if you have the `strncmp' function. */ #define HAVE_STRNCMP 1 /* Define to 1 if you have the `strncpy' function. */ #define HAVE_STRNCPY 1 /* Define to 1 if you have the header file, and it defines `DIR'. */ /* #undef HAVE_SYS_DIR_H */ /* Define to 1 if you have the header file. */ #define HAVE_SYS_IOCTL_H 1 /* Define to 1 if you have the header file, and it defines `DIR'. */ /* #undef HAVE_SYS_NDIR_H */ /* Define to 1 if you have the header file. */ #define HAVE_SYS_RESOURCE_H 1 /* Define to 1 if you have the header file. */ #define HAVE_SYS_SOCKET_H 1 /* Define to 1 if you have the header file. */ #define HAVE_SYS_STAT_H 1 /* Define to 1 if you have the header file. */ #define HAVE_SYS_TIME_H 1 /* Define to 1 if you have the header file. */ #define HAVE_SYS_TYPES_H 1 /* Define to 1 if you have that is POSIX.1 compatible. */ #define HAVE_SYS_WAIT_H 1 /* Define to 1 if you have the header file. */ #define HAVE_TERMIOS_H 1 /* Define to 1 if you have the header file. */ #define HAVE_TIME_H 1 /* Define this if user wants to tune for a specific CPU */ /* #undef HAVE_TUNING */ /* Define to 1 if you have the header file. */ #define HAVE_UNISTD_H 1 /* Define this if untested OS was detected */ /* #undef HAVE_UNTESTED */ /* Define this if /usr/local/pgsql/include was detected */ #define HAVE_USR_LOCAL_PGSQL_INCLUDE 1 /* Define this if /usr/pkg/pgsql/include was detected */ /* #undef HAVE_USR_PKG_PGSQL_INCLUDE */ /* Define to 1 if assertions should be disabled. */ /* #undef NDEBUG */ /* Define to 1 if your C compiler doesn't accept -c and -o together. */ /* #undef NO_MINUS_C_MINUS_O */ /* Name of package */ #define PACKAGE "algol68g" /* Define to the address where bug reports for this package should be sent. */ #define PACKAGE_BUGREPORT "Marcel van der Veer " /* Define to the full name of this package. */ #define PACKAGE_NAME "algol68g" /* Define to the full name and version of this package. */ #define PACKAGE_STRING "algol68g 2.4.1" /* Define to the one symbol short name of this package. */ #define PACKAGE_TARNAME "algol68g" /* Define to the version of this package. */ #define PACKAGE_VERSION "2.4.1" /* Define to 1 if you have the ANSI C header files. */ #define STDC_HEADERS 1 /* Version number of package */ #define VERSION "2.4.1" /* Define to 1 if type `char' is unsigned and you are not using gcc. */ #ifndef __CHAR_UNSIGNED__ /* # undef __CHAR_UNSIGNED__ */ #endif /* Define this if we have no __mode_t */ /* #undef __mode_t */ /* Define this if we have no __off_t */ /* #undef __off_t */ /* Define this if we have no __pid_t */ /* #undef __pid_t */ /* Define to `int' if does not define. */ /* #undef mode_t */ /* Define to `unsigned int' if does not define. */ /* #undef size_t */ /* Define to `int' if does not define. */ /* #undef ssize_t */ /* Define to the type of an unsigned integer type of width exactly 16 bits if such a type exists and the standard includes do not define it. */ /* #undef uint16_t */ algol68g-2.4.1/source/gsl.c0000644000175000001440000022456711770153007012330 00000000000000/*! \file gsl.c \brief vector, matrix and FFT support through GSL */ /* This file is part of Algol68G - an Algol 68 interpreter. Copyright (C) 2001-2012 J. Marcel van der Veer . This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 3 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see . */ #include "a68g.h" #if defined HAVE_GNU_GSL static NODE_T *error_node = NO_NODE; #define VECTOR_OFFSET(a, t)\ ((LWB (t) * SPAN (t) - SHIFT (t) + SLICE_OFFSET (a)) * ELEM_SIZE (a) + FIELD_OFFSET (a)) #define MATRIX_OFFSET(a, t1, t2)\ ((LWB (t1) * SPAN (t1) - SHIFT (t1) + LWB (t2) * SPAN (t2) - SHIFT (t2) + SLICE_OFFSET (a)) * ELEM_SIZE (a) + FIELD_OFFSET (a)) /*! \brief set permutation vector element - function fails in gsl \param p permutation vector \param i element iindex \param j element value **/ void gsl_permutation_set (const gsl_permutation * p, const size_t i, const size_t j) { DATA (p)[i] = j; } /*! \brief map GSL error handler onto a68g error handler \param reason error text \param file gsl file where error occured \param line line in above file \param int gsl error number **/ void torrix_error_handler (const char *reason, const char *file, int line, int gsl_errno) { if (line != 0) { ASSERT (snprintf (edit_line, SNPRINTF_SIZE, "%s in line %d of file %s", reason, line, file) >= 0); } else { ASSERT (snprintf (edit_line, SNPRINTF_SIZE, "%s", reason) >= 0); } diagnostic_node (A68_RUNTIME_ERROR, error_node, ERROR_TORRIX, edit_line, gsl_strerror (gsl_errno)); exit_genie (error_node, A68_RUNTIME_ERROR); } /*! \brief detect math errors, mainly in BLAS functions \param rc return code from function **/ static void torrix_test_error (int rc) { if (rc != 0) { torrix_error_handler ("math error", "", 0, rc); } } /*! \brief pop [] INT on the stack as gsl_permutation \param p position in tree \param get whether to get elements from row in the stack \return gsl_permutation_complex **/ static gsl_permutation *pop_permutation (NODE_T * p, BOOL_T get) { A68_REF desc; A68_ARRAY *arr; A68_TUPLE *tup; int len, inc, iindex, k; BYTE_T *base; gsl_permutation *v; /* Pop arguments */ POP_REF (p, &desc); CHECK_REF (p, desc, MODE (ROW_INT)); GET_DESCRIPTOR (arr, tup, &desc); len = ROW_SIZE (tup); v = gsl_permutation_alloc ((size_t) len); if (get && len > 0) { base = DEREF (BYTE_T, &ARRAY (arr)); iindex = VECTOR_OFFSET (arr, tup); inc = SPAN (tup) * ELEM_SIZE (arr); for (k = 0; k < len; k++, iindex += inc) { A68_INT *x = (A68_INT *) (base + iindex); CHECK_INIT (p, INITIALISED (x), MODE (INT)); gsl_permutation_set (v, (size_t) k, (size_t) VALUE (x)); } } return (v); } /*! \brief push gsl_permutation on the stack as [] INT \param p position in tree **/ static void push_permutation (NODE_T * p, gsl_permutation * v) { A68_REF desc, row; A68_ARRAY arr; A68_TUPLE tup; int len, inc, iindex, k; BYTE_T *base; len = (int) (SIZE (v)); desc = heap_generator (p, MODE (ROW_INT), ALIGNED_SIZE_OF (A68_ARRAY) + ALIGNED_SIZE_OF (A68_TUPLE)); row = heap_generator (p, MODE (ROW_INT), len * ALIGNED_SIZE_OF (A68_INT)); DIM (&arr) = 1; MOID (&arr) = MODE (INT); ELEM_SIZE (&arr) = ALIGNED_SIZE_OF (A68_INT); SLICE_OFFSET (&arr) = FIELD_OFFSET (&arr) = 0; ARRAY (&arr) = row; LWB (&tup) = 1; UPB (&tup) = len; SPAN (&tup) = 1; SHIFT (&tup) = LWB (&tup); K (&tup) = 0; PUT_DESCRIPTOR (arr, tup, &desc); base = DEREF (BYTE_T, &ARRAY (&arr)); iindex = VECTOR_OFFSET (&arr, &tup); inc = SPAN (&tup) * ELEM_SIZE (&arr); for (k = 0; k < len; k++, iindex += inc) { A68_INT *x = (A68_INT *) (base + iindex); STATUS (x) = INIT_MASK; VALUE (x) = (int) gsl_permutation_get (v, (size_t) k); } PUSH_REF (p, desc); } /*! \brief pop [] REAL on the stack as gsl_vector \param p position in tree \param get whether to get elements from row in the stack \return gsl_vector_complex **/ static gsl_vector *pop_vector (NODE_T * p, BOOL_T get) { A68_REF desc; A68_ARRAY *arr; A68_TUPLE *tup; int len, inc, iindex, k; BYTE_T *base; gsl_vector *v; /* Pop arguments */ POP_REF (p, &desc); CHECK_REF (p, desc, MODE (ROW_REAL)); GET_DESCRIPTOR (arr, tup, &desc); len = ROW_SIZE (tup); v = gsl_vector_alloc ((size_t) len); if (get && len > 0) { base = DEREF (BYTE_T, &ARRAY (arr)); iindex = VECTOR_OFFSET (arr, tup); inc = SPAN (tup) * ELEM_SIZE (arr); for (k = 0; k < len; k++, iindex += inc) { A68_REAL *x = (A68_REAL *) (base + iindex); CHECK_INIT (p, INITIALISED (x), MODE (REAL)); gsl_vector_set (v, (size_t) k, VALUE (x)); } } return (v); } /*! \brief push gsl_vector on the stack as [] REAL \param p position in tree **/ static void push_vector (NODE_T * p, gsl_vector * v) { A68_REF desc, row; A68_ARRAY arr; A68_TUPLE tup; int len, inc, iindex, k; BYTE_T *base; len = (int) (SIZE (v)); desc = heap_generator (p, MODE (ROW_REAL), ALIGNED_SIZE_OF (A68_ARRAY) + ALIGNED_SIZE_OF (A68_TUPLE)); row = heap_generator (p, MODE (ROW_REAL), len * ALIGNED_SIZE_OF (A68_REAL)); DIM (&arr) = 1; MOID (&arr) = MODE (REAL); ELEM_SIZE (&arr) = ALIGNED_SIZE_OF (A68_REAL); SLICE_OFFSET (&arr) = FIELD_OFFSET (&arr) = 0; ARRAY (&arr) = row; LWB (&tup) = 1; UPB (&tup) = len; SPAN (&tup) = 1; SHIFT (&tup) = LWB (&tup); K (&tup) = 0; PUT_DESCRIPTOR (arr, tup, &desc); base = DEREF (BYTE_T, &ARRAY (&arr)); iindex = VECTOR_OFFSET (&arr, &tup); inc = SPAN (&tup) * ELEM_SIZE (&arr); for (k = 0; k < len; k++, iindex += inc) { A68_REAL *x = (A68_REAL *) (base + iindex); STATUS (x) = INIT_MASK; VALUE (x) = gsl_vector_get (v, (size_t) k); CHECK_REAL_REPRESENTATION (p, VALUE (x)); } PUSH_REF (p, desc); } /*! \brief pop [,] REAL on the stack as gsl_matrix \param p position in tree \param get whether to get elements from row in the stack \return gsl_matrix **/ static gsl_matrix *pop_matrix (NODE_T * p, BOOL_T get) { A68_REF desc; A68_ARRAY *arr; A68_TUPLE *tup1, *tup2; int len1, len2, inc1, inc2, iindex1, iindex2, k1, k2; BYTE_T *base; gsl_matrix *a; /* Pop arguments */ POP_REF (p, &desc); CHECK_REF (p, desc, MODE (ROWROW_REAL)); GET_DESCRIPTOR (arr, tup1, &desc); tup2 = &(tup1[1]); len1 = ROW_SIZE (tup1); len2 = ROW_SIZE (tup2); a = gsl_matrix_alloc ((size_t) len1, (size_t) len2); if (get && (len1 * len2 > 0)) { base = DEREF (BYTE_T, &ARRAY (arr)); iindex1 = MATRIX_OFFSET (arr, tup1, tup2); inc1 = SPAN (tup1) * ELEM_SIZE (arr); inc2 = SPAN (tup2) * ELEM_SIZE (arr); for (k1 = 0; k1 < len1; k1++, iindex1 += inc1) { for (k2 = 0, iindex2 = iindex1; k2 < len2; k2++, iindex2 += inc2) { A68_REAL *x = (A68_REAL *) (base + iindex2); CHECK_INIT (p, INITIALISED (x), MODE (REAL)); gsl_matrix_set (a, (size_t) k1, (size_t) k2, VALUE (x)); } } } return (a); } /*! \brief push gsl_matrix on the stack as [,] REAL \param p position in tree **/ static void push_matrix (NODE_T * p, gsl_matrix * a) { A68_REF desc, row; A68_ARRAY arr; A68_TUPLE tup1, tup2; int len1, len2, inc1, inc2, iindex1, iindex2, k1, k2; BYTE_T *base; len1 = (int) (SIZE1 (a)); len2 = (int) (SIZE2 (a)); desc = heap_generator (p, MODE (ROWROW_REAL), ALIGNED_SIZE_OF (A68_ARRAY) + 2 * ALIGNED_SIZE_OF (A68_TUPLE)); row = heap_generator (p, MODE (ROWROW_REAL), len1 * len2 * ALIGNED_SIZE_OF (A68_REAL)); DIM (&arr) = 2; MOID (&arr) = MODE (REAL); ELEM_SIZE (&arr) = ALIGNED_SIZE_OF (A68_REAL); SLICE_OFFSET (&arr) = FIELD_OFFSET (&arr) = 0; ARRAY (&arr) = row; LWB (&tup1) = 1; UPB (&tup1) = len1; SPAN (&tup1) = 1; SHIFT (&tup1) = LWB (&tup1); K (&tup1) = 0; LWB (&tup2) = 1; UPB (&tup2) = len2; SPAN (&tup2) = ROW_SIZE (&tup1); SHIFT (&tup2) = LWB (&tup2) * SPAN (&tup2); K (&tup2) = 0; PUT_DESCRIPTOR2 (arr, tup1, tup2, &desc); base = DEREF (BYTE_T, &ARRAY (&arr)); iindex1 = MATRIX_OFFSET (&arr, &tup1, &tup2); inc1 = SPAN (&tup1) * ELEM_SIZE (&arr); inc2 = SPAN (&tup2) * ELEM_SIZE (&arr); for (k1 = 0; k1 < len1; k1++, iindex1 += inc1) { for (k2 = 0, iindex2 = iindex1; k2 < len2; k2++, iindex2 += inc2) { A68_REAL *x = (A68_REAL *) (base + iindex2); STATUS (x) = INIT_MASK; VALUE (x) = gsl_matrix_get (a, (size_t) k1, (size_t) k2); CHECK_REAL_REPRESENTATION (p, VALUE (x)); } } PUSH_REF (p, desc); } /*! \brief pop [] COMPLEX on the stack as gsl_vector_complex \param p position in tree \param get whether to get elements from row in the stack \return gsl_vector_complex **/ static gsl_vector_complex *pop_vector_complex (NODE_T * p, BOOL_T get) { A68_REF desc; A68_ARRAY *arr; A68_TUPLE *tup; int len, inc, iindex, k; BYTE_T *base; gsl_vector_complex *v; /* Pop arguments */ POP_REF (p, &desc); CHECK_REF (p, desc, MODE (ROW_COMPLEX)); GET_DESCRIPTOR (arr, tup, &desc); len = ROW_SIZE (tup); v = gsl_vector_complex_alloc ((size_t) len); if (get && len > 0) { base = DEREF (BYTE_T, &ARRAY (arr)); iindex = VECTOR_OFFSET (arr, tup); inc = SPAN (tup) * ELEM_SIZE (arr); for (k = 0; k < len; k++, iindex += inc) { A68_REAL *re = (A68_REAL *) (base + iindex); A68_REAL *im = (A68_REAL *) (base + iindex + ALIGNED_SIZE_OF (A68_REAL)); gsl_complex z; CHECK_INIT (p, INITIALISED (re), MODE (COMPLEX)); CHECK_INIT (p, INITIALISED (im), MODE (COMPLEX)); GSL_SET_COMPLEX (&z, VALUE (re), VALUE (im)); gsl_vector_complex_set (v, (size_t) k, z); } } return (v); } /*! \brief push gsl_vector_complex on the stack as [] COMPLEX \param p position in tree **/ static void push_vector_complex (NODE_T * p, gsl_vector_complex * v) { A68_REF desc, row; A68_ARRAY arr; A68_TUPLE tup; int len, inc, iindex, k; BYTE_T *base; len = (int) (SIZE (v)); desc = heap_generator (p, MODE (ROW_COMPLEX), ALIGNED_SIZE_OF (A68_ARRAY) + ALIGNED_SIZE_OF (A68_TUPLE)); row = heap_generator (p, MODE (ROW_COMPLEX), len * 2 * ALIGNED_SIZE_OF (A68_REAL)); DIM (&arr) = 1; MOID (&arr) = MODE (COMPLEX); ELEM_SIZE (&arr) = 2 * ALIGNED_SIZE_OF (A68_REAL); SLICE_OFFSET (&arr) = FIELD_OFFSET (&arr) = 0; ARRAY (&arr) = row; LWB (&tup) = 1; UPB (&tup) = len; SPAN (&tup) = 1; SHIFT (&tup) = LWB (&tup); K (&tup) = 0; PUT_DESCRIPTOR (arr, tup, &desc); base = DEREF (BYTE_T, &ARRAY (&arr)); iindex = VECTOR_OFFSET (&arr, &tup); inc = SPAN (&tup) * ELEM_SIZE (&arr); for (k = 0; k < len; k++, iindex += inc) { A68_REAL *re = (A68_REAL *) (base + iindex); A68_REAL *im = (A68_REAL *) (base + iindex + ALIGNED_SIZE_OF (A68_REAL)); gsl_complex z = gsl_vector_complex_get (v, (size_t) k); STATUS (re) = INIT_MASK; VALUE (re) = GSL_REAL (z); STATUS (im) = INIT_MASK; VALUE (im) = GSL_IMAG (z); CHECK_COMPLEX_REPRESENTATION (p, VALUE (re), VALUE (im)); } PUSH_REF (p, desc); } /*! \brief pop [,] COMPLEX on the stack as gsl_matrix_complex \param p position in tree \param get whether to get elements from row in the stack \return gsl_matrix_complex **/ static gsl_matrix_complex *pop_matrix_complex (NODE_T * p, BOOL_T get) { A68_REF desc; A68_ARRAY *arr; A68_TUPLE *tup1, *tup2; int len1, len2; gsl_matrix_complex *a; /* Pop arguments */ POP_REF (p, &desc); CHECK_REF (p, desc, MODE (ROWROW_COMPLEX)); GET_DESCRIPTOR (arr, tup1, &desc); tup2 = &(tup1[1]); len1 = ROW_SIZE (tup1); len2 = ROW_SIZE (tup2); a = gsl_matrix_complex_alloc ((size_t) len1, (size_t) len2); if (get && (len1 * len2 > 0)) { BYTE_T *base = DEREF (BYTE_T, &ARRAY (arr)); int iindex1 = MATRIX_OFFSET (arr, tup1, tup2); int inc1 = SPAN (tup1) * ELEM_SIZE (arr), inc2 = SPAN (tup2) * ELEM_SIZE (arr), k1; for (k1 = 0; k1 < len1; k1++, iindex1 += inc1) { int iindex2, k2; for (k2 = 0, iindex2 = iindex1; k2 < len2; k2++, iindex2 += inc2) { A68_REAL *re = (A68_REAL *) (base + iindex2); A68_REAL *im = (A68_REAL *) (base + iindex2 + ALIGNED_SIZE_OF (A68_REAL)); gsl_complex z; CHECK_INIT (p, INITIALISED (re), MODE (COMPLEX)); CHECK_INIT (p, INITIALISED (im), MODE (COMPLEX)); GSL_SET_COMPLEX (&z, VALUE (re), VALUE (im)); gsl_matrix_complex_set (a, (size_t) k1, (size_t) k2, z); } } } return (a); } /*! \brief push gsl_matrix_complex on the stack as [,] COMPLEX \param p position in tree **/ static void push_matrix_complex (NODE_T * p, gsl_matrix_complex * a) { A68_REF desc, row; A68_ARRAY arr; A68_TUPLE tup1, tup2; int len1, len2, inc1, inc2, iindex1, iindex2, k1, k2; BYTE_T *base; len1 = (int) (SIZE1 (a)); len2 = (int) (SIZE2 (a)); desc = heap_generator (p, MODE (ROWROW_COMPLEX), ALIGNED_SIZE_OF (A68_ARRAY) + 2 * ALIGNED_SIZE_OF (A68_TUPLE)); row = heap_generator (p, MODE (ROWROW_COMPLEX), len1 * len2 * 2 * ALIGNED_SIZE_OF (A68_REAL)); DIM (&arr) = 2; MOID (&arr) = MODE (COMPLEX); ELEM_SIZE (&arr) = 2 * ALIGNED_SIZE_OF (A68_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 + ALIGNED_SIZE_OF (A68_REAL)); gsl_complex z = gsl_matrix_complex_get (a, (size_t) k1, (size_t) k2); STATUS (re) = INIT_MASK; VALUE (re) = GSL_REAL (z); STATUS (im) = INIT_MASK; VALUE (im) = GSL_IMAG (z); CHECK_COMPLEX_REPRESENTATION (p, VALUE (re), VALUE (im)); } } PUSH_REF (p, desc); } /*! \brief pop REF [...] M and derefence to [...] M \param p position in tree \param m mode of REF [...] M \param par_size size of parameters in the stack \return the undereferenced REF **/ static A68_REF dereference_ref_row (NODE_T * p, MOID_T * m, ADDR_T par_size) { A68_REF *u, v; u = (A68_REF *) STACK_OFFSET (-par_size); v = *u; CHECK_REF (p, v, m); *u = *DEREF (A68_ROW, &v); return (v); } /*! \brief generically perform operation and assign result (+:=, -:=, ...) \param p position in tree \param m mode of REF [...] M \param n mode of right operand M \param op operation to be performed **/ static void op_ab (NODE_T * p, MOID_T * m, MOID_T * n, GPROC * op) { ADDR_T par_size = MOID_SIZE (m) + MOID_SIZE (n); A68_REF u, *v; error_node = p; u = dereference_ref_row (p, m, par_size); v = (A68_REF *) STACK_OFFSET (-par_size); (*op) (p); *DEREF (A68_ROW, &u) = *v; *v = u; } /*! \brief PROC vector echo = ([] REAL) [] REAL \param p position in tree **/ void genie_vector_echo (NODE_T * p) { gsl_error_handler_t *save_handler = gsl_set_error_handler (torrix_error_handler); gsl_vector *u; error_node = p; u = pop_vector (p, A68_TRUE); push_vector (p, u); gsl_vector_free (u); (void) gsl_set_error_handler (save_handler); } /*! \brief PROC matrix echo = ([,] REAL) [,] REAL \param p position in tree **/ void genie_matrix_echo (NODE_T * p) { gsl_error_handler_t *save_handler = gsl_set_error_handler (torrix_error_handler); gsl_matrix *a; error_node = p; a = pop_matrix (p, A68_TRUE); push_matrix (p, a); gsl_matrix_free (a); (void) gsl_set_error_handler (save_handler); } /*! \brief PROC complex vector echo = ([] COMPLEX) [] COMPLEX \param p position in tree **/ void genie_vector_complex_echo (NODE_T * p) { gsl_error_handler_t *save_handler = gsl_set_error_handler (torrix_error_handler); gsl_vector_complex *u; error_node = p; u = pop_vector_complex (p, A68_TRUE); push_vector_complex (p, u); gsl_vector_complex_free (u); (void) gsl_set_error_handler (save_handler); } /*! \brief PROC complex matrix echo = ([,] COMPLEX) [,] COMPLEX \param p position in tree **/ void genie_matrix_complex_echo (NODE_T * p) { gsl_error_handler_t *save_handler = gsl_set_error_handler (torrix_error_handler); gsl_matrix_complex *a; error_node = p; a = pop_matrix_complex (p, A68_TRUE); push_matrix_complex (p, a); gsl_matrix_complex_free (a); (void) gsl_set_error_handler (save_handler); } /*! \brief OP - = ([] REAL) [] REAL \param p position in tree **/ void genie_vector_minus (NODE_T * p) { gsl_error_handler_t *save_handler = gsl_set_error_handler (torrix_error_handler); gsl_vector *u; int rc; error_node = p; u = pop_vector (p, A68_TRUE); rc = gsl_vector_scale (u, -1); torrix_test_error (rc); push_vector (p, u); gsl_vector_free (u); (void) gsl_set_error_handler (save_handler); } /*! \brief OP - = ([,] REAL) [,] REAL \param p position in tree **/ void genie_matrix_minus (NODE_T * p) { gsl_error_handler_t *save_handler = gsl_set_error_handler (torrix_error_handler); gsl_matrix *a; int rc; error_node = p; a = pop_matrix (p, A68_TRUE); rc = gsl_matrix_scale (a, -1); torrix_test_error (rc); push_matrix (p, a); gsl_matrix_free (a); (void) gsl_set_error_handler (save_handler); } /*! \brief OP T = ([,] REAL) [,] REAL \param p position in tree **/ void genie_matrix_transpose (NODE_T * p) { gsl_error_handler_t *save_handler = gsl_set_error_handler (torrix_error_handler); gsl_matrix *a; int rc; error_node = p; a = pop_matrix (p, A68_TRUE); rc = gsl_matrix_transpose (a); torrix_test_error (rc); push_matrix (p, a); gsl_matrix_free (a); (void) gsl_set_error_handler (save_handler); } /*! \brief OP T = ([,] COMPLEX) [,] COMPLEX \param p position in tree **/ void genie_matrix_complex_transpose (NODE_T * p) { gsl_error_handler_t *save_handler = gsl_set_error_handler (torrix_error_handler); gsl_matrix_complex *a; int rc; error_node = p; a = pop_matrix_complex (p, A68_TRUE); rc = gsl_matrix_complex_transpose (a); torrix_test_error (rc); push_matrix_complex (p, a); gsl_matrix_complex_free (a); (void) gsl_set_error_handler (save_handler); } /*! \brief OP INV = ([,] REAL) [,] REAL \param p position in tree **/ void genie_matrix_inv (NODE_T * p) { gsl_error_handler_t *save_handler = gsl_set_error_handler (torrix_error_handler); gsl_permutation *q; gsl_matrix *u, *inv; int rc, signum; error_node = p; u = pop_matrix (p, A68_TRUE); q = gsl_permutation_alloc (SIZE1 (u)); rc = gsl_linalg_LU_decomp (u, q, &signum); torrix_test_error (rc); inv = gsl_matrix_alloc (SIZE1 (u), SIZE2 (u)); rc = gsl_linalg_LU_invert (u, q, inv); torrix_test_error (rc); push_matrix (p, inv); gsl_matrix_free (inv); gsl_matrix_free (u); gsl_permutation_free (q); (void) gsl_set_error_handler (save_handler); } /*! \brief OP INV = ([,] COMPLEX) [,] COMPLEX \param p position in tree **/ void genie_matrix_complex_inv (NODE_T * p) { gsl_error_handler_t *save_handler = gsl_set_error_handler (torrix_error_handler); gsl_permutation *q; gsl_matrix_complex *u, *inv; int rc, signum; error_node = p; u = pop_matrix_complex (p, A68_TRUE); q = gsl_permutation_alloc (SIZE1 (u)); rc = gsl_linalg_complex_LU_decomp (u, q, &signum); torrix_test_error (rc); inv = gsl_matrix_complex_alloc (SIZE1 (u), SIZE2 (u)); rc = gsl_linalg_complex_LU_invert (u, q, inv); torrix_test_error (rc); push_matrix_complex (p, inv); gsl_matrix_complex_free (inv); gsl_matrix_complex_free (u); gsl_permutation_free (q); (void) gsl_set_error_handler (save_handler); } /*! \brief OP DET = ([,] REAL) REAL \param p position in tree **/ void genie_matrix_det (NODE_T * p) { gsl_error_handler_t *save_handler = gsl_set_error_handler (torrix_error_handler); gsl_permutation *q; gsl_matrix *u; int rc, signum; error_node = p; u = pop_matrix (p, A68_TRUE); q = gsl_permutation_alloc (SIZE1 (u)); rc = gsl_linalg_LU_decomp (u, q, &signum); torrix_test_error (rc); PUSH_PRIMITIVE (p, gsl_linalg_LU_det (u, signum), A68_REAL); gsl_matrix_free (u); gsl_permutation_free (q); (void) gsl_set_error_handler (save_handler); } /*! \brief OP DET = ([,] COMPLEX) COMPLEX \param p position in tree **/ void genie_matrix_complex_det (NODE_T * p) { gsl_error_handler_t *save_handler = gsl_set_error_handler (torrix_error_handler); gsl_permutation *q; gsl_matrix_complex *u; int rc, signum; gsl_complex det; error_node = p; u = pop_matrix_complex (p, A68_TRUE); q = gsl_permutation_alloc (SIZE1 (u)); rc = gsl_linalg_complex_LU_decomp (u, q, &signum); torrix_test_error (rc); det = gsl_linalg_complex_LU_det (u, signum); PUSH_PRIMITIVE (p, GSL_REAL (det), A68_REAL); PUSH_PRIMITIVE (p, GSL_IMAG (det), A68_REAL); gsl_matrix_complex_free (u); gsl_permutation_free (q); (void) gsl_set_error_handler (save_handler); } /*! \brief OP TRACE = ([,] REAL) REAL \param p position in tree **/ void genie_matrix_trace (NODE_T * p) { gsl_error_handler_t *save_handler = gsl_set_error_handler (torrix_error_handler); gsl_matrix *a; double sum; int len1, len2, k; error_node = p; a = pop_matrix (p, A68_TRUE); len1 = (int) (SIZE1 (a)); len2 = (int) (SIZE2 (a)); if (len1 != len2) { torrix_error_handler ("cannot calculate trace", __FILE__, __LINE__, GSL_ENOTSQR); } sum = 0.0; for (k = 0; k < len1; k++) { sum += gsl_matrix_get (a, (size_t) k, (size_t) k); } PUSH_PRIMITIVE (p, sum, A68_REAL); gsl_matrix_free (a); (void) gsl_set_error_handler (save_handler); } /*! \brief OP TRACE = ([,] COMPLEX) COMPLEX \param p position in tree **/ void genie_matrix_complex_trace (NODE_T * p) { gsl_error_handler_t *save_handler = gsl_set_error_handler (torrix_error_handler); gsl_matrix_complex *a; gsl_complex sum; int len1, len2, k; error_node = p; a = pop_matrix_complex (p, A68_TRUE); len1 = (int) (SIZE1 (a)); len2 = (int) (SIZE2 (a)); if (len1 != len2) { torrix_error_handler ("cannot calculate trace", __FILE__, __LINE__, GSL_ENOTSQR); } GSL_SET_COMPLEX (&sum, 0.0, 0.0); for (k = 0; k < len1; k++) { sum = gsl_complex_add (sum, gsl_matrix_complex_get (a, (size_t) k, (size_t) k)); } PUSH_PRIMITIVE (p, GSL_REAL (sum), A68_REAL); PUSH_PRIMITIVE (p, GSL_IMAG (sum), A68_REAL); gsl_matrix_complex_free (a); (void) gsl_set_error_handler (save_handler); } /*! \brief OP - = ([] COMPLEX) [] COMPLEX \param p position in tree **/ void genie_vector_complex_minus (NODE_T * p) { gsl_error_handler_t *save_handler = gsl_set_error_handler (torrix_error_handler); gsl_vector_complex *u; error_node = p; u = pop_vector_complex (p, A68_TRUE); gsl_blas_zdscal (-1, u); push_vector_complex (p, u); gsl_vector_complex_free (u); (void) gsl_set_error_handler (save_handler); } /*! \brief OP - = ([,] COMPLEX) [,] COMPLEX \param p position in tree **/ void genie_matrix_complex_minus (NODE_T * p) { gsl_error_handler_t *save_handler = gsl_set_error_handler (torrix_error_handler); gsl_matrix_complex *a; gsl_complex one; int rc; error_node = p; GSL_SET_COMPLEX (&one, -1.0, 0.0); a = pop_matrix_complex (p, A68_TRUE); rc = gsl_matrix_complex_scale (a, one); torrix_test_error (rc); push_matrix_complex (p, a); gsl_matrix_complex_free (a); (void) gsl_set_error_handler (save_handler); } /*! \brief OP + = ([] REAL, [] REAL) [] REAL \param p position in tree **/ void genie_vector_add (NODE_T * p) { gsl_error_handler_t *save_handler = gsl_set_error_handler (torrix_error_handler); gsl_vector *u, *v; int rc; error_node = p; v = pop_vector (p, A68_TRUE); u = pop_vector (p, A68_TRUE); rc = gsl_vector_add (u, v); torrix_test_error (rc); push_vector (p, u); gsl_vector_free (u); gsl_vector_free (v); (void) gsl_set_error_handler (save_handler); } /*! \brief OP - = ([] REAL, [] REAL) [] REAL \param p position in tree **/ void genie_vector_sub (NODE_T * p) { gsl_error_handler_t *save_handler = gsl_set_error_handler (torrix_error_handler); gsl_vector *u, *v; int rc; error_node = p; v = pop_vector (p, A68_TRUE); u = pop_vector (p, A68_TRUE); rc = gsl_vector_sub (u, v); torrix_test_error (rc); push_vector (p, u); gsl_vector_free (u); gsl_vector_free (v); (void) gsl_set_error_handler (save_handler); } /*! \brief OP = = ([] REAL, [] REAL) BOOL \param p position in tree **/ void genie_vector_eq (NODE_T * p) { gsl_error_handler_t *save_handler = gsl_set_error_handler (torrix_error_handler); gsl_vector *u, *v; int rc; error_node = p; v = pop_vector (p, A68_TRUE); u = pop_vector (p, A68_TRUE); rc = gsl_vector_sub (u, v); torrix_test_error (rc); PUSH_PRIMITIVE (p, (BOOL_T) (gsl_vector_isnull (u) ? A68_TRUE : A68_FALSE), A68_BOOL); gsl_vector_free (u); gsl_vector_free (v); (void) gsl_set_error_handler (save_handler); } /*! \brief OP /= = ([] REAL, [] REAL) BOOL \param p position in tree **/ void genie_vector_ne (NODE_T * p) { genie_vector_eq (p); genie_not_bool (p); } /*! \brief OP +:= = (REF [] REAL, [] REAL) REF [] REAL \param p position in tree **/ void genie_vector_plusab (NODE_T * p) { op_ab (p, MODE (REF_ROW_REAL), MODE (ROW_REAL), genie_vector_add); } /*! \brief OP -:= = (REF [] REAL, [] REAL) REF [] REAL \param p position in tree **/ void genie_vector_minusab (NODE_T * p) { op_ab (p, MODE (REF_ROW_REAL), MODE (ROW_REAL), genie_vector_sub); } /*! \brief OP + = ([, ] REAL, [, ] REAL) [, ] REAL \param p position in tree **/ void genie_matrix_add (NODE_T * p) { gsl_error_handler_t *save_handler = gsl_set_error_handler (torrix_error_handler); gsl_matrix *u, *v; int rc; error_node = p; v = pop_matrix (p, A68_TRUE); u = pop_matrix (p, A68_TRUE); rc = gsl_matrix_add (u, v); torrix_test_error (rc); push_matrix (p, u); gsl_matrix_free (u); gsl_matrix_free (v); (void) gsl_set_error_handler (save_handler); } /*! \brief OP - = ([, ] REAL, [, ] REAL) [, ] REAL \param p position in tree **/ void genie_matrix_sub (NODE_T * p) { gsl_error_handler_t *save_handler = gsl_set_error_handler (torrix_error_handler); gsl_matrix *u, *v; int rc; error_node = p; v = pop_matrix (p, A68_TRUE); u = pop_matrix (p, A68_TRUE); rc = gsl_matrix_sub (u, v); torrix_test_error (rc); push_matrix (p, u); gsl_matrix_free (u); gsl_matrix_free (v); (void) gsl_set_error_handler (save_handler); } /*! \brief OP = = ([, ] REAL, [, ] REAL) [, ] BOOL \param p position in tree **/ void genie_matrix_eq (NODE_T * p) { gsl_error_handler_t *save_handler = gsl_set_error_handler (torrix_error_handler); gsl_matrix *u, *v; int rc; error_node = p; v = pop_matrix (p, A68_TRUE); u = pop_matrix (p, A68_TRUE); rc = gsl_matrix_sub (u, v); torrix_test_error (rc); PUSH_PRIMITIVE (p, (BOOL_T) (gsl_matrix_isnull (u) ? A68_TRUE : A68_FALSE), A68_BOOL); gsl_matrix_free (u); gsl_matrix_free (v); (void) gsl_set_error_handler (save_handler); } /*! \brief OP /= = ([, ] REAL, [, ] REAL) [, ] BOOL \param p position in tree **/ void genie_matrix_ne (NODE_T * p) { genie_matrix_eq (p); genie_not_bool (p); } /*! \brief OP +:= = (REF [, ] REAL, [, ] REAL) [, ] REAL \param p position in tree **/ void genie_matrix_plusab (NODE_T * p) { op_ab (p, MODE (REF_ROWROW_REAL), MODE (ROWROW_REAL), genie_matrix_add); } /*! \brief OP -:= = (REF [, ] REAL, [, ] REAL) [, ] REAL \param p position in tree **/ void genie_matrix_minusab (NODE_T * p) { op_ab (p, MODE (REF_ROWROW_REAL), MODE (ROWROW_REAL), genie_matrix_sub); } /*! \brief OP + = ([] COMPLEX, [] COMPLEX) [] COMPLEX \param p position in tree **/ void genie_vector_complex_add (NODE_T * p) { gsl_error_handler_t *save_handler = gsl_set_error_handler (torrix_error_handler); gsl_vector_complex *u, *v; gsl_complex one; int rc; error_node = p; GSL_SET_COMPLEX (&one, 1.0, 0.0); v = pop_vector_complex (p, A68_TRUE); u = pop_vector_complex (p, A68_TRUE); rc = gsl_blas_zaxpy (one, u, v); torrix_test_error (rc); push_vector_complex (p, v); gsl_vector_complex_free (u); gsl_vector_complex_free (v); (void) gsl_set_error_handler (save_handler); } /*! \brief OP - = ([] COMPLEX, [] COMPLEX) [] COMPLEX \param p position in tree **/ void genie_vector_complex_sub (NODE_T * p) { gsl_error_handler_t *save_handler = gsl_set_error_handler (torrix_error_handler); gsl_vector_complex *u, *v; gsl_complex one; int rc; error_node = p; GSL_SET_COMPLEX (&one, -1.0, 0.0); v = pop_vector_complex (p, A68_TRUE); u = pop_vector_complex (p, A68_TRUE); rc = gsl_blas_zaxpy (one, v, u); torrix_test_error (rc); push_vector_complex (p, u); gsl_vector_complex_free (u); gsl_vector_complex_free (v); (void) gsl_set_error_handler (save_handler); } /*! \brief OP = = ([] COMPLEX, [] COMPLEX) BOOL \param p position in tree **/ void genie_vector_complex_eq (NODE_T * p) { gsl_error_handler_t *save_handler = gsl_set_error_handler (torrix_error_handler); gsl_vector_complex *u, *v; gsl_complex one; int rc; error_node = p; GSL_SET_COMPLEX (&one, -1.0, 0.0); v = pop_vector_complex (p, A68_TRUE); u = pop_vector_complex (p, A68_TRUE); rc = gsl_blas_zaxpy (one, v, u); torrix_test_error (rc); PUSH_PRIMITIVE (p, (BOOL_T) (gsl_vector_complex_isnull (u) ? A68_TRUE : A68_FALSE), A68_BOOL); gsl_vector_complex_free (u); gsl_vector_complex_free (v); (void) gsl_set_error_handler (save_handler); } /*! \brief OP /= = ([] COMPLEX, [] COMPLEX) BOOL \param p position in tree **/ void genie_vector_complex_ne (NODE_T * p) { genie_vector_complex_eq (p); genie_not_bool (p); } /*! \brief OP +:= = (REF [] COMPLEX, [] COMPLEX) [] COMPLEX \param p position in tree **/ void genie_vector_complex_plusab (NODE_T * p) { op_ab (p, MODE (REF_ROW_COMPLEX), MODE (ROW_COMPLEX), genie_vector_complex_add); } /*! \brief OP -:= = (REF [] COMPLEX, [] COMPLEX) [] COMPLEX \param p position in tree **/ void genie_vector_complex_minusab (NODE_T * p) { op_ab (p, MODE (REF_ROW_COMPLEX), MODE (ROW_COMPLEX), genie_vector_complex_sub); } /*! \brief OP + = ([, ] COMPLEX, [, ] COMPLEX) [, ] COMPLEX \param p position in tree **/ void genie_matrix_complex_add (NODE_T * p) { gsl_error_handler_t *save_handler = gsl_set_error_handler (torrix_error_handler); gsl_matrix_complex *u, *v; int rc; error_node = p; v = pop_matrix_complex (p, A68_TRUE); u = pop_matrix_complex (p, A68_TRUE); rc = gsl_matrix_complex_add (u, v); torrix_test_error (rc); push_matrix_complex (p, u); gsl_matrix_complex_free (u); gsl_matrix_complex_free (v); (void) gsl_set_error_handler (save_handler); } /*! \brief OP - = ([, ] COMPLEX, [, ] COMPLEX) [, ] COMPLEX \param p position in tree **/ void genie_matrix_complex_sub (NODE_T * p) { gsl_error_handler_t *save_handler = gsl_set_error_handler (torrix_error_handler); gsl_matrix_complex *u, *v; int rc; error_node = p; v = pop_matrix_complex (p, A68_TRUE); u = pop_matrix_complex (p, A68_TRUE); rc = gsl_matrix_complex_sub (u, v); torrix_test_error (rc); push_matrix_complex (p, u); gsl_matrix_complex_free (u); gsl_matrix_complex_free (v); (void) gsl_set_error_handler (save_handler); } /*! \brief OP = = ([, ] COMPLEX, [, ] COMPLEX) BOOL \param p position in tree **/ void genie_matrix_complex_eq (NODE_T * p) { gsl_error_handler_t *save_handler = gsl_set_error_handler (torrix_error_handler); gsl_matrix_complex *u, *v; int rc; error_node = p; v = pop_matrix_complex (p, A68_TRUE); u = pop_matrix_complex (p, A68_TRUE); rc = gsl_matrix_complex_sub (u, v); torrix_test_error (rc); PUSH_PRIMITIVE (p, (BOOL_T) (gsl_matrix_complex_isnull (u) ? A68_TRUE : A68_FALSE), A68_BOOL); gsl_matrix_complex_free (u); gsl_matrix_complex_free (v); (void) gsl_set_error_handler (save_handler); } /*! \brief OP /= = ([, ] COMPLEX, [, ] COMPLEX) BOOL \param p position in tree **/ void genie_matrix_complex_ne (NODE_T * p) { genie_matrix_complex_eq (p); genie_not_bool (p); } /*! \brief OP +:= = (REF [, ] COMPLEX, [, ] COMPLEX) [, ] COMPLEX \param p position in tree **/ void genie_matrix_complex_plusab (NODE_T * p) { op_ab (p, MODE (REF_ROWROW_COMPLEX), MODE (ROWROW_COMPLEX), genie_matrix_complex_add); } /*! \brief OP -:= = (REF [, ] COMPLEX, [, ] COMPLEX) [, ] COMPLEX \param p position in tree **/ void genie_matrix_complex_minusab (NODE_T * p) { op_ab (p, MODE (REF_ROWROW_COMPLEX), MODE (ROWROW_COMPLEX), genie_matrix_complex_sub); } /*! \brief OP * = ([] REAL, REAL) [] REAL \param p position in tree **/ void genie_vector_scale_real (NODE_T * p) { gsl_error_handler_t *save_handler = gsl_set_error_handler (torrix_error_handler); gsl_vector *u; A68_REAL v; int rc; error_node = p; POP_OBJECT (p, &v, A68_REAL); u = pop_vector (p, A68_TRUE); rc = gsl_vector_scale (u, VALUE (&v)); torrix_test_error (rc); push_vector (p, u); gsl_vector_free (u); (void) gsl_set_error_handler (save_handler); } /*! \brief OP * = (REAL, [] REAL) [] REAL \param p position in tree **/ void genie_real_scale_vector (NODE_T * p) { gsl_error_handler_t *save_handler = gsl_set_error_handler (torrix_error_handler); gsl_vector *u; A68_REAL v; int rc; error_node = p; u = pop_vector (p, A68_TRUE); POP_OBJECT (p, &v, A68_REAL); rc = gsl_vector_scale (u, VALUE (&v)); torrix_test_error (rc); push_vector (p, u); gsl_vector_free (u); (void) gsl_set_error_handler (save_handler); } /*! \brief OP * = ([, ] REAL, REAL) [, ] REAL \param p position in tree **/ void genie_matrix_scale_real (NODE_T * p) { gsl_error_handler_t *save_handler = gsl_set_error_handler (torrix_error_handler); gsl_matrix *u; A68_REAL v; int rc; error_node = p; POP_OBJECT (p, &v, A68_REAL); u = pop_matrix (p, A68_TRUE); rc = gsl_matrix_scale (u, VALUE (&v)); torrix_test_error (rc); push_matrix (p, u); gsl_matrix_free (u); (void) gsl_set_error_handler (save_handler); } /*! \brief OP * = (REAL, [, ] REAL) [, ] REAL \param p position in tree **/ void genie_real_scale_matrix (NODE_T * p) { gsl_error_handler_t *save_handler = gsl_set_error_handler (torrix_error_handler); gsl_matrix *u; A68_REAL v; int rc; error_node = p; u = pop_matrix (p, A68_TRUE); POP_OBJECT (p, &v, A68_REAL); rc = gsl_matrix_scale (u, VALUE (&v)); torrix_test_error (rc); push_matrix (p, u); gsl_matrix_free (u); (void) gsl_set_error_handler (save_handler); } /*! \brief OP * = ([] COMPLEX, COMPLEX) [] COMPLEX \param p position in tree **/ void genie_vector_complex_scale_complex (NODE_T * p) { gsl_error_handler_t *save_handler = gsl_set_error_handler (torrix_error_handler); gsl_vector_complex *u; A68_REAL re, im; gsl_complex v; error_node = p; POP_OBJECT (p, &im, A68_REAL); POP_OBJECT (p, &re, A68_REAL); GSL_SET_COMPLEX (&v, VALUE (&re), VALUE (&im)); u = pop_vector_complex (p, A68_TRUE); gsl_blas_zscal (v, u); push_vector_complex (p, u); gsl_vector_complex_free (u); (void) gsl_set_error_handler (save_handler); } /*! \brief OP * = (COMPLEX, [] COMPLEX) [] COMPLEX \param p position in tree **/ void genie_complex_scale_vector_complex (NODE_T * p) { gsl_error_handler_t *save_handler = gsl_set_error_handler (torrix_error_handler); gsl_vector_complex *u; A68_REAL re, im; gsl_complex v; error_node = p; u = pop_vector_complex (p, A68_TRUE); POP_OBJECT (p, &im, A68_REAL); POP_OBJECT (p, &re, A68_REAL); GSL_SET_COMPLEX (&v, VALUE (&re), VALUE (&im)); gsl_blas_zscal (v, u); push_vector_complex (p, u); gsl_vector_complex_free (u); (void) gsl_set_error_handler (save_handler); } /*! \brief OP * = ([, ] COMPLEX, COMPLEX) [, ] COMPLEX \param p position in tree **/ void genie_matrix_complex_scale_complex (NODE_T * p) { gsl_error_handler_t *save_handler = gsl_set_error_handler (torrix_error_handler); gsl_matrix_complex *u; A68_REAL re, im; gsl_complex v; int rc; error_node = p; POP_OBJECT (p, &im, A68_REAL); POP_OBJECT (p, &re, A68_REAL); GSL_SET_COMPLEX (&v, VALUE (&re), VALUE (&im)); u = pop_matrix_complex (p, A68_TRUE); rc = gsl_matrix_complex_scale (u, v); torrix_test_error (rc); push_matrix_complex (p, u); gsl_matrix_complex_free (u); (void) gsl_set_error_handler (save_handler); } /*! \brief OP * = (COMPLEX, [, ] COMPLEX) [, ] COMPLEX \param p position in tree **/ void genie_complex_scale_matrix_complex (NODE_T * p) { gsl_error_handler_t *save_handler = gsl_set_error_handler (torrix_error_handler); gsl_matrix_complex *u; A68_REAL re, im; gsl_complex v; int rc; error_node = p; u = pop_matrix_complex (p, A68_TRUE); POP_OBJECT (p, &im, A68_REAL); POP_OBJECT (p, &re, A68_REAL); GSL_SET_COMPLEX (&v, VALUE (&re), VALUE (&im)); rc = gsl_matrix_complex_scale (u, v); torrix_test_error (rc); push_matrix_complex (p, u); gsl_matrix_complex_free (u); (void) gsl_set_error_handler (save_handler); } /*! \brief OP *:= (REF [] REAL, REAL) REF [] REAL \param p position in tree **/ void genie_vector_scale_real_ab (NODE_T * p) { op_ab (p, MODE (REF_ROW_REAL), MODE (REAL), genie_vector_scale_real); } /*! \brief OP *:= (REF [, ] REAL, REAL) REF [, ] REAL \param p position in tree **/ void genie_matrix_scale_real_ab (NODE_T * p) { op_ab (p, MODE (REF_ROWROW_REAL), MODE (REAL), genie_matrix_scale_real); } /*! \brief OP *:= (REF [] COMPLEX, COMPLEX) REF [] COMPLEX \param p position in tree **/ void genie_vector_complex_scale_complex_ab (NODE_T * p) { op_ab (p, MODE (REF_ROW_COMPLEX), MODE (COMPLEX), genie_vector_complex_scale_complex); } /*! \brief OP *:= (REF [, ] COMPLEX, COMPLEX) REF [, ] COMPLEX \param p position in tree **/ void genie_matrix_complex_scale_complex_ab (NODE_T * p) { op_ab (p, MODE (REF_ROWROW_COMPLEX), MODE (COMPLEX), genie_matrix_complex_scale_complex); } /*! \brief OP / = ([] REAL, REAL) [] REAL \param p position in tree **/ void genie_vector_div_real (NODE_T * p) { gsl_error_handler_t *save_handler = gsl_set_error_handler (torrix_error_handler); gsl_vector *u; A68_REAL v; int rc; error_node = p; POP_OBJECT (p, &v, A68_REAL); if (VALUE (&v) == 0.0) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_DIVISION_BY_ZERO, MODE (ROW_REAL)); exit_genie (p, A68_RUNTIME_ERROR); } u = pop_vector (p, A68_TRUE); rc = gsl_vector_scale (u, 1.0 / VALUE (&v)); torrix_test_error (rc); push_vector (p, u); gsl_vector_free (u); (void) gsl_set_error_handler (save_handler); } /*! \brief OP / = ([, ] REAL, REAL) [, ] REAL \param p position in tree **/ void genie_matrix_div_real (NODE_T * p) { gsl_error_handler_t *save_handler = gsl_set_error_handler (torrix_error_handler); gsl_matrix *u; A68_REAL v; int rc; error_node = p; POP_OBJECT (p, &v, A68_REAL); if (VALUE (&v) == 0.0) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_DIVISION_BY_ZERO, MODE (ROWROW_REAL)); exit_genie (p, A68_RUNTIME_ERROR); } u = pop_matrix (p, A68_TRUE); rc = gsl_matrix_scale (u, 1.0 / VALUE (&v)); torrix_test_error (rc); push_matrix (p, u); gsl_matrix_free (u); (void) gsl_set_error_handler (save_handler); } /*! \brief OP / = ([] COMPLEX, COMPLEX) [] COMPLEX \param p position in tree **/ void genie_vector_complex_div_complex (NODE_T * p) { gsl_error_handler_t *save_handler = gsl_set_error_handler (torrix_error_handler); gsl_vector_complex *u; A68_REAL re, im; gsl_complex v; error_node = p; POP_OBJECT (p, &im, A68_REAL); POP_OBJECT (p, &re, A68_REAL); if (VALUE (&re) == 0.0 && VALUE (&im) == 0.0) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_DIVISION_BY_ZERO, MODE (ROW_COMPLEX)); exit_genie (p, A68_RUNTIME_ERROR); } GSL_SET_COMPLEX (&v, VALUE (&re), VALUE (&im)); u = pop_vector_complex (p, A68_TRUE); v = gsl_complex_inverse (v); gsl_blas_zscal (v, u); push_vector_complex (p, u); gsl_vector_complex_free (u); (void) gsl_set_error_handler (save_handler); } /*! \brief OP / = ([, ] COMPLEX, COMPLEX) [, ] COMPLEX \param p position in tree **/ void genie_matrix_complex_div_complex (NODE_T * p) { gsl_error_handler_t *save_handler = gsl_set_error_handler (torrix_error_handler); gsl_matrix_complex *u; A68_REAL re, im; gsl_complex v; int rc; error_node = p; POP_OBJECT (p, &im, A68_REAL); POP_OBJECT (p, &re, A68_REAL); if (VALUE (&re) == 0.0 && VALUE (&im) == 0.0) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_DIVISION_BY_ZERO, MODE (ROWROW_COMPLEX)); exit_genie (p, A68_RUNTIME_ERROR); } GSL_SET_COMPLEX (&v, VALUE (&re), VALUE (&im)); v = gsl_complex_inverse (v); u = pop_matrix_complex (p, A68_TRUE); rc = gsl_matrix_complex_scale (u, v); torrix_test_error (rc); push_matrix_complex (p, u); gsl_matrix_complex_free (u); (void) gsl_set_error_handler (save_handler); } /*! \brief OP /:= (REF [] REAL, REAL) REF [] REAL \param p position in tree **/ void genie_vector_div_real_ab (NODE_T * p) { op_ab (p, MODE (REF_ROW_REAL), MODE (REAL), genie_vector_div_real); } /*! \brief OP /:= (REF [, ] REAL, REAL) REF [, ] REAL \param p position in tree **/ void genie_matrix_div_real_ab (NODE_T * p) { op_ab (p, MODE (REF_ROWROW_REAL), MODE (REAL), genie_matrix_div_real); } /*! \brief OP /:= (REF [] COMPLEX, COMPLEX) REF [] COMPLEX \param p position in tree **/ void genie_vector_complex_div_complex_ab (NODE_T * p) { op_ab (p, MODE (REF_ROW_COMPLEX), MODE (COMPLEX), genie_vector_complex_div_complex); } /*! \brief OP /:= (REF [, ] COMPLEX, COMPLEX) REF [, ] COMPLEX \param p position in tree **/ void genie_matrix_complex_div_complex_ab (NODE_T * p) { op_ab (p, MODE (REF_ROWROW_COMPLEX), MODE (COMPLEX), genie_matrix_complex_div_complex); } /*! \brief OP * = ([] REAL, [] REAL) REAL \param p position in tree **/ void genie_vector_dot (NODE_T * p) { gsl_error_handler_t *save_handler = gsl_set_error_handler (torrix_error_handler); gsl_vector *u, *v; double w; int rc; error_node = p; v = pop_vector (p, A68_TRUE); u = pop_vector (p, A68_TRUE); rc = gsl_blas_ddot (u, v, &w); torrix_test_error (rc); PUSH_PRIMITIVE (p, w, A68_REAL); gsl_vector_free (u); gsl_vector_free (v); (void) gsl_set_error_handler (save_handler); } /*! \brief OP * = ([] COMPLEX, [] COMPLEX) COMPLEX \param p position in tree **/ void genie_vector_complex_dot (NODE_T * p) { gsl_error_handler_t *save_handler = gsl_set_error_handler (torrix_error_handler); gsl_vector_complex *u, *v; gsl_complex w; int rc; error_node = p; v = pop_vector_complex (p, A68_TRUE); u = pop_vector_complex (p, A68_TRUE); rc = gsl_blas_zdotc (u, v, &w); torrix_test_error (rc); PUSH_PRIMITIVE (p, GSL_REAL (w), A68_REAL); PUSH_PRIMITIVE (p, GSL_IMAG (w), A68_REAL); gsl_vector_complex_free (u); gsl_vector_complex_free (v); (void) gsl_set_error_handler (save_handler); } /*! \brief OP NORM = ([] REAL) REAL \param p position in tree **/ void genie_vector_norm (NODE_T * p) { gsl_error_handler_t *save_handler = gsl_set_error_handler (torrix_error_handler); gsl_vector *u; error_node = p; u = pop_vector (p, A68_TRUE); PUSH_PRIMITIVE (p, gsl_blas_dnrm2 (u), A68_REAL); gsl_vector_free (u); (void) gsl_set_error_handler (save_handler); } /*! \brief OP NORM = ([] COMPLEX) COMPLEX \param p position in tree **/ void genie_vector_complex_norm (NODE_T * p) { gsl_error_handler_t *save_handler = gsl_set_error_handler (torrix_error_handler); gsl_vector_complex *u; error_node = p; u = pop_vector_complex (p, A68_TRUE); PUSH_PRIMITIVE (p, gsl_blas_dznrm2 (u), A68_REAL); gsl_vector_complex_free (u); (void) gsl_set_error_handler (save_handler); } /*! \brief OP DYAD = ([] REAL, [] REAL) [, ] REAL \param p position in tree **/ void genie_vector_dyad (NODE_T * p) { gsl_error_handler_t *save_handler = gsl_set_error_handler (torrix_error_handler); gsl_vector *u, *v; gsl_matrix *w; int len1, len2, j, k; error_node = p; v = pop_vector (p, A68_TRUE); u = pop_vector (p, A68_TRUE); len1 = (int) (SIZE (u)); len2 = (int) (SIZE (v)); w = gsl_matrix_alloc ((size_t) len1, (size_t) len2); for (j = 0; j < len1; j++) { double uj = gsl_vector_get (u, (size_t) j); for (k = 0; k < len2; k++) { double vk = gsl_vector_get (v, (size_t) k); gsl_matrix_set (w, (size_t) j, (size_t) k, uj * vk); } } push_matrix (p, w); gsl_vector_free (u); gsl_vector_free (v); gsl_matrix_free (w); (void) gsl_set_error_handler (save_handler); } /*! \brief OP DYAD = ([] COMPLEX, [] COMPLEX) [, ] COMPLEX \param p position in tree **/ void genie_vector_complex_dyad (NODE_T * p) { gsl_error_handler_t *save_handler = gsl_set_error_handler (torrix_error_handler); gsl_vector_complex *u, *v; gsl_matrix_complex *w; int len1, len2, j, k; error_node = p; v = pop_vector_complex (p, A68_TRUE); u = pop_vector_complex (p, A68_TRUE); len1 = (int) (SIZE (u)); len2 = (int) (SIZE (v)); w = gsl_matrix_complex_alloc ((size_t) len1, (size_t) len2); for (j = 0; j < len1; j++) { gsl_complex uj = gsl_vector_complex_get (u, (size_t) j); for (k = 0; k < len2; k++) { gsl_complex vk = gsl_vector_complex_get (u, (size_t) k); gsl_matrix_complex_set (w, (size_t) j, (size_t) k, gsl_complex_mul (uj, vk)); } } push_matrix_complex (p, w); gsl_vector_complex_free (u); gsl_vector_complex_free (v); gsl_matrix_complex_free (w); (void) gsl_set_error_handler (save_handler); } /*! \brief OP * = ([, ] REAL, [] REAL) [] REAL \param p position in tree **/ void genie_matrix_times_vector (NODE_T * p) { gsl_error_handler_t *save_handler = gsl_set_error_handler (torrix_error_handler); int len; int rc; gsl_vector *u, *v; gsl_matrix *w; error_node = p; u = pop_vector (p, A68_TRUE); w = pop_matrix (p, A68_TRUE); len = (int) (SIZE (u)); v = gsl_vector_alloc ((size_t) len); gsl_vector_set_zero (v); rc = gsl_blas_dgemv (CblasNoTrans, 1.0, w, u, 0.0, v); torrix_test_error (rc); push_vector (p, v); gsl_vector_free (u); gsl_vector_free (v); gsl_matrix_free (w); (void) gsl_set_error_handler (save_handler); } /*! \brief OP * = ([] REAL, [, ] REAL) [] REAL \param p position in tree **/ void genie_vector_times_matrix (NODE_T * p) { gsl_error_handler_t *save_handler = gsl_set_error_handler (torrix_error_handler); int len; int rc; gsl_vector *u, *v; gsl_matrix *w; error_node = p; w = pop_matrix (p, A68_TRUE); rc = gsl_matrix_transpose (w); torrix_test_error (rc); u = pop_vector (p, A68_TRUE); len = (int) (SIZE (u)); v = gsl_vector_alloc ((size_t) len); gsl_vector_set_zero (v); rc = gsl_blas_dgemv (CblasNoTrans, 1.0, w, u, 0.0, v); torrix_test_error (rc); push_vector (p, v); gsl_vector_free (u); gsl_vector_free (v); gsl_matrix_free (w); (void) gsl_set_error_handler (save_handler); } /*! \brief OP * = ([, ] REAL, [, ] REAL) [, ] REAL \param p position in tree **/ void genie_matrix_times_matrix (NODE_T * p) { gsl_error_handler_t *save_handler = gsl_set_error_handler (torrix_error_handler); int len1, len2; int rc; gsl_matrix *u, *v, *w; error_node = p; v = pop_matrix (p, A68_TRUE); u = pop_matrix (p, A68_TRUE); len2 = (int) (SIZE2 (v)); len1 = (int) (SIZE1 (u)); w = gsl_matrix_alloc ((size_t) len1, (size_t) len2); gsl_matrix_set_zero (w); rc = gsl_blas_dgemm (CblasNoTrans, CblasNoTrans, 1.0, u, v, 0.0, w); torrix_test_error (rc); push_matrix (p, w); gsl_matrix_free (u); gsl_matrix_free (v); gsl_matrix_free (w); (void) gsl_set_error_handler (save_handler); } /*! \brief OP * = ([, ] COMPLEX, [] COMPLEX) [] COMPLEX \param p position in tree **/ void genie_matrix_complex_times_vector (NODE_T * p) { gsl_error_handler_t *save_handler = gsl_set_error_handler (torrix_error_handler); int len, rc; gsl_vector_complex *u, *v; gsl_matrix_complex *w; gsl_complex zero, one; error_node = p; GSL_SET_COMPLEX (&zero, 0.0, 0.0); GSL_SET_COMPLEX (&one, 1.0, 0.0); u = pop_vector_complex (p, A68_TRUE); w = pop_matrix_complex (p, A68_TRUE); len = (int) (SIZE (u)); v = gsl_vector_complex_alloc ((size_t) len); gsl_vector_complex_set_zero (v); rc = gsl_blas_zgemv (CblasNoTrans, one, w, u, zero, v); torrix_test_error (rc); push_vector_complex (p, v); gsl_vector_complex_free (u); gsl_vector_complex_free (v); gsl_matrix_complex_free (w); (void) gsl_set_error_handler (save_handler); } /*! \brief OP * = ([] COMPLEX, [, ] COMPLEX) [] COMPLEX \param p position in tree **/ void genie_vector_complex_times_matrix (NODE_T * p) { gsl_error_handler_t *save_handler = gsl_set_error_handler (torrix_error_handler); int len, rc; gsl_vector_complex *u, *v; gsl_matrix_complex *w; gsl_complex zero, one; error_node = p; GSL_SET_COMPLEX (&zero, 0.0, 0.0); GSL_SET_COMPLEX (&one, 1.0, 0.0); w = pop_matrix_complex (p, A68_TRUE); rc = gsl_matrix_complex_transpose (w); torrix_test_error (rc); u = pop_vector_complex (p, A68_TRUE); len = (int) (SIZE (u)); v = gsl_vector_complex_alloc ((size_t) len); gsl_vector_complex_set_zero (v); rc = gsl_blas_zgemv (CblasNoTrans, one, w, u, zero, v); torrix_test_error (rc); push_vector_complex (p, v); gsl_vector_complex_free (u); gsl_vector_complex_free (v); gsl_matrix_complex_free (w); (void) gsl_set_error_handler (save_handler); } /*! \brief OP * = ([, ] COMPLEX, [, ] COMPLEX) [, ] COMPLEX \param p position in tree **/ void genie_matrix_complex_times_matrix (NODE_T * p) { gsl_error_handler_t *save_handler = gsl_set_error_handler (torrix_error_handler); int len1, len2, rc; gsl_matrix_complex *u, *v, *w; gsl_complex zero, one; error_node = p; GSL_SET_COMPLEX (&zero, 0.0, 0.0); GSL_SET_COMPLEX (&one, 1.0, 0.0); v = pop_matrix_complex (p, A68_TRUE); u = pop_matrix_complex (p, A68_TRUE); len1 = (int) (SIZE2 (v)); len2 = (int) (SIZE1 (u)); w = gsl_matrix_complex_alloc ((size_t) len1, (size_t) len2); gsl_matrix_complex_set_zero (w); rc = gsl_blas_zgemm (CblasNoTrans, CblasNoTrans, one, u, v, zero, w); torrix_test_error (rc); push_matrix_complex (p, w); gsl_matrix_complex_free (u); gsl_matrix_complex_free (v); gsl_matrix_complex_free (w); (void) gsl_set_error_handler (save_handler); } /*! \brief PROC lu decomp = ([, ] REAL, REF [] INT, REF INT) [, ] REAL \param p position in tree **/ void genie_matrix_lu (NODE_T * p) { gsl_error_handler_t *save_handler = gsl_set_error_handler (torrix_error_handler); A68_REF ref_signum, ref_q; gsl_permutation *q; gsl_matrix *u; int rc; A68_INT signum; error_node = p; POP_REF (p, &ref_signum); CHECK_REF (p, ref_signum, MODE (REF_INT)); POP_REF (p, &ref_q); CHECK_REF (p, ref_q, MODE (REF_ROW_INT)); PUSH_REF (p, *DEREF (A68_ROW, &ref_q)); q = pop_permutation (p, A68_FALSE); u = pop_matrix (p, A68_TRUE); rc = gsl_linalg_LU_decomp (u, q, &(VALUE (&signum))); torrix_test_error (rc); STATUS (&signum) = INIT_MASK; *DEREF (A68_INT, &ref_signum) = signum; push_permutation (p, q); POP_REF (p, DEREF (A68_ROW, &ref_q)); push_matrix (p, u); gsl_matrix_free (u); gsl_permutation_free (q); (void) gsl_set_error_handler (save_handler); } /*! \brief PROC lu det = ([, ] REAL, INT) REAL \param p position in tree **/ void genie_matrix_lu_det (NODE_T * p) { gsl_error_handler_t *save_handler = gsl_set_error_handler (torrix_error_handler); gsl_matrix *lu; A68_INT signum; error_node = p; POP_OBJECT (p, &signum, A68_INT); lu = pop_matrix (p, A68_TRUE); PUSH_PRIMITIVE (p, gsl_linalg_LU_det (lu, VALUE (&signum)), A68_REAL); gsl_matrix_free (lu); (void) gsl_set_error_handler (save_handler); } /*! \brief PROC lu inv = ([, ] REAL, [] INT) [, ] REAL \param p position in tree **/ void genie_matrix_lu_inv (NODE_T * p) { gsl_error_handler_t *save_handler = gsl_set_error_handler (torrix_error_handler); gsl_permutation *q; gsl_matrix *lu, *inv; int rc; error_node = p; q = pop_permutation (p, A68_TRUE); lu = pop_matrix (p, A68_TRUE); inv = gsl_matrix_alloc (SIZE1 (lu), SIZE2 (lu)); rc = gsl_linalg_LU_invert (lu, q, inv); torrix_test_error (rc); push_matrix (p, inv); gsl_matrix_free (lu); gsl_matrix_free (inv); gsl_permutation_free (q); (void) gsl_set_error_handler (save_handler); } /*! \brief PROC lu solve ([, ] REAL, [, ] REAL, [] INT, [] REAL) [] REAL \param p position in tree **/ void genie_matrix_lu_solve (NODE_T * p) { gsl_error_handler_t *save_handler = gsl_set_error_handler (torrix_error_handler); gsl_permutation *q; gsl_matrix *a, *lu; gsl_vector *b, *x, *r; int rc; error_node = p; b = pop_vector (p, A68_TRUE); q = pop_permutation (p, A68_TRUE); lu = pop_matrix (p, A68_TRUE); a = pop_matrix (p, A68_TRUE); x = gsl_vector_alloc (SIZE (b)); r = gsl_vector_alloc (SIZE (b)); rc = gsl_linalg_LU_solve (lu, q, b, x); torrix_test_error (rc); rc = gsl_linalg_LU_refine (a, lu, q, b, x, r); torrix_test_error (rc); push_vector (p, x); gsl_matrix_free (a); gsl_matrix_free (lu); gsl_vector_free (b); gsl_vector_free (r); gsl_vector_free (x); gsl_permutation_free (q); (void) gsl_set_error_handler (save_handler); } /*! \brief PROC complex lu decomp = ([, ] COMPLEX, REF [] INT, REF INT) [, ] COMPLEX \param p position in tree **/ void genie_matrix_complex_lu (NODE_T * p) { gsl_error_handler_t *save_handler = gsl_set_error_handler (torrix_error_handler); A68_REF ref_signum, ref_q; gsl_permutation *q; gsl_matrix_complex *u; int rc; A68_INT signum; error_node = p; POP_REF (p, &ref_signum); CHECK_REF (p, ref_signum, MODE (REF_INT)); POP_REF (p, &ref_q); CHECK_REF (p, ref_q, MODE (REF_ROW_INT)); PUSH_REF (p, *DEREF (A68_ROW, &ref_q)); q = pop_permutation (p, A68_FALSE); u = pop_matrix_complex (p, A68_TRUE); rc = gsl_linalg_complex_LU_decomp (u, q, &(VALUE (&signum))); torrix_test_error (rc); STATUS (&signum) = INIT_MASK; *DEREF (A68_INT, &ref_signum) = signum; push_permutation (p, q); POP_REF (p, DEREF (A68_ROW, &ref_q)); push_matrix_complex (p, u); gsl_matrix_complex_free (u); gsl_permutation_free (q); (void) gsl_set_error_handler (save_handler); } /*! \brief PROC complex lu det = ([, ] COMPLEX, INT) COMPLEX \param p position in tree **/ void genie_matrix_complex_lu_det (NODE_T * p) { gsl_error_handler_t *save_handler = gsl_set_error_handler (torrix_error_handler); gsl_matrix_complex *lu; A68_INT signum; gsl_complex det; error_node = p; POP_OBJECT (p, &signum, A68_INT); lu = pop_matrix_complex (p, A68_TRUE); det = gsl_linalg_complex_LU_det (lu, VALUE (&signum)); PUSH_PRIMITIVE (p, GSL_REAL (det), A68_REAL); PUSH_PRIMITIVE (p, GSL_IMAG (det), A68_REAL); gsl_matrix_complex_free (lu); (void) gsl_set_error_handler (save_handler); } /*! \brief PROC complex lu inv = ([, ] COMPLEX, [] INT) [, ] COMPLEX \param p position in tree **/ void genie_matrix_complex_lu_inv (NODE_T * p) { gsl_error_handler_t *save_handler = gsl_set_error_handler (torrix_error_handler); gsl_permutation *q; gsl_matrix_complex *lu, *inv; int rc; error_node = p; q = pop_permutation (p, A68_TRUE); lu = pop_matrix_complex (p, A68_TRUE); inv = gsl_matrix_complex_alloc (SIZE1 (lu), SIZE2 (lu)); rc = gsl_linalg_complex_LU_invert (lu, q, inv); torrix_test_error (rc); push_matrix_complex (p, inv); gsl_matrix_complex_free (lu); gsl_matrix_complex_free (inv); gsl_permutation_free (q); (void) gsl_set_error_handler (save_handler); } /*! \brief PROC complex lu solve ([, ] COMPLEX, [, ] COMPLEX, [] INT, [] COMPLEX) [] COMPLEX \param p position in tree **/ void genie_matrix_complex_lu_solve (NODE_T * p) { gsl_error_handler_t *save_handler = gsl_set_error_handler (torrix_error_handler); gsl_permutation *q; gsl_matrix_complex *a, *lu; gsl_vector_complex *b, *x, *r; int rc; error_node = p; b = pop_vector_complex (p, A68_TRUE); q = pop_permutation (p, A68_TRUE); lu = pop_matrix_complex (p, A68_TRUE); a = pop_matrix_complex (p, A68_TRUE); x = gsl_vector_complex_alloc (SIZE (b)); r = gsl_vector_complex_alloc (SIZE (b)); rc = gsl_linalg_complex_LU_solve (lu, q, b, x); torrix_test_error (rc); rc = gsl_linalg_complex_LU_refine (a, lu, q, b, x, r); torrix_test_error (rc); push_vector_complex (p, x); gsl_matrix_complex_free (a); gsl_matrix_complex_free (lu); gsl_vector_complex_free (b); gsl_vector_complex_free (r); gsl_vector_complex_free (x); gsl_permutation_free (q); (void) gsl_set_error_handler (save_handler); } /*! \brief PROC svd decomp = ([, ] REAL, REF [, ] REAL, REF [] REAL) [, ] REAL \param p position in tree **/ void genie_matrix_svd (NODE_T * p) { gsl_error_handler_t *save_handler = gsl_set_error_handler (torrix_error_handler); gsl_matrix *a, *v; gsl_vector *s, *w; A68_REF ref_s, ref_v; int rc; error_node = p; POP_REF (p, &ref_s); CHECK_REF (p, ref_s, MODE (REF_ROW_REAL)); PUSH_REF (p, *DEREF (A68_ROW, &ref_s)); s = pop_vector (p, A68_FALSE); POP_REF (p, &ref_v); CHECK_REF (p, ref_v, MODE (REF_ROWROW_REAL)); PUSH_REF (p, *DEREF (A68_ROW, &ref_v)); v = pop_matrix (p, A68_FALSE); a = pop_matrix (p, A68_TRUE); w = gsl_vector_alloc (SIZE2 (v)); rc = gsl_linalg_SV_decomp (a, v, s, w); torrix_test_error (rc); push_vector (p, s); POP_REF (p, DEREF (A68_ROW, &ref_s)); push_matrix (p, v); POP_REF (p, DEREF (A68_ROW, &ref_v)); push_matrix (p, a); gsl_matrix_free (a); gsl_matrix_free (v); gsl_vector_free (s); gsl_vector_free (w); (void) gsl_set_error_handler (save_handler); } /*! \brief PROC svd solve = ([, ] REAL, [, ] REAL, [] REAL, [] REAL) [] REAL \param p position in tree **/ void genie_matrix_svd_solve (NODE_T * p) { gsl_error_handler_t *save_handler = gsl_set_error_handler (torrix_error_handler); gsl_matrix *u, *v; gsl_vector *s, *b, *x; int rc; error_node = p; b = pop_vector (p, A68_TRUE); s = pop_vector (p, A68_TRUE); v = pop_matrix (p, A68_TRUE); u = pop_matrix (p, A68_TRUE); x = gsl_vector_alloc (SIZE (b)); rc = gsl_linalg_SV_solve (u, v, s, b, x); push_vector (p, x); gsl_vector_free (x); gsl_vector_free (b); gsl_vector_free (s); gsl_matrix_free (v); gsl_matrix_free (u); (void) gsl_set_error_handler (save_handler); } /*! \brief PROC qr decomp = ([, ] REAL, [] REAL) [, ] REAL \param p position in tree **/ void genie_matrix_qr (NODE_T * p) { gsl_error_handler_t *save_handler = gsl_set_error_handler (torrix_error_handler); gsl_matrix *a; gsl_vector *t; A68_REF ref_t; int rc; error_node = p; POP_REF (p, &ref_t); CHECK_REF (p, ref_t, MODE (REF_ROW_REAL)); PUSH_REF (p, *DEREF (A68_ROW, &ref_t)); t = pop_vector (p, A68_FALSE); a = pop_matrix (p, A68_TRUE); rc = gsl_linalg_QR_decomp (a, t); torrix_test_error (rc); push_vector (p, t); POP_REF (p, DEREF (A68_ROW, &ref_t)); push_matrix (p, a); gsl_matrix_free (a); gsl_vector_free (t); (void) gsl_set_error_handler (save_handler); } /*! \brief PROC qr solve = ([, ] REAL, [] REAL, [] REAL) [] REAL \param p position in tree **/ void genie_matrix_qr_solve (NODE_T * p) { gsl_error_handler_t *save_handler = gsl_set_error_handler (torrix_error_handler); gsl_matrix *q; gsl_vector *t, *b, *x; int rc; error_node = p; b = pop_vector (p, A68_TRUE); t = pop_vector (p, A68_TRUE); q = pop_matrix (p, A68_TRUE); x = gsl_vector_alloc (SIZE (b)); rc = gsl_linalg_QR_solve (q, t, b, x); push_vector (p, x); gsl_vector_free (x); gsl_vector_free (b); gsl_vector_free (t); gsl_matrix_free (q); (void) gsl_set_error_handler (save_handler); } /*! \brief PROC qr ls solve = ([, ] REAL, [] REAL, [] REAL) [] REAL \param p position in tree **/ void genie_matrix_qr_ls_solve (NODE_T * p) { gsl_error_handler_t *save_handler = gsl_set_error_handler (torrix_error_handler); gsl_matrix *q; gsl_vector *t, *b, *x, *r; int rc; error_node = p; b = pop_vector (p, A68_TRUE); t = pop_vector (p, A68_TRUE); q = pop_matrix (p, A68_TRUE); r = gsl_vector_alloc (SIZE (b)); x = gsl_vector_alloc (SIZE (b)); rc = gsl_linalg_QR_lssolve (q, t, b, x, r); push_vector (p, x); gsl_vector_free (x); gsl_vector_free (r); gsl_vector_free (b); gsl_vector_free (t); gsl_matrix_free (q); (void) gsl_set_error_handler (save_handler); } /*! \brief PROC cholesky decomp = ([, ] REAL) [, ] REAL \param p position in tree **/ void genie_matrix_ch (NODE_T * p) { gsl_error_handler_t *save_handler = gsl_set_error_handler (torrix_error_handler); gsl_matrix *a; int rc; error_node = p; a = pop_matrix (p, A68_TRUE); rc = gsl_linalg_cholesky_decomp (a); torrix_test_error (rc); push_matrix (p, a); gsl_matrix_free (a); (void) gsl_set_error_handler (save_handler); } /*! \brief PROC cholesky solve = ([, ] REAL, [] REAL) [] REAL \param p position in tree **/ void genie_matrix_ch_solve (NODE_T * p) { gsl_error_handler_t *save_handler = gsl_set_error_handler (torrix_error_handler); gsl_matrix *c; gsl_vector *b, *x; int rc; error_node = p; b = pop_vector (p, A68_TRUE); c = pop_matrix (p, A68_TRUE); x = gsl_vector_alloc (SIZE (b)); rc = gsl_linalg_cholesky_solve (c, b, x); push_vector (p, x); gsl_vector_free (x); gsl_vector_free (b); gsl_matrix_free (c); (void) gsl_set_error_handler (save_handler); } /*! \brief map GSL error handler onto a68g error handler \param reason error text \param file gsl file where error occured \param line line in above file \param int gsl error number **/ void fft_error_handler (const char *reason, const char *file, int line, int gsl_errno) { if (line != 0) { ASSERT (snprintf (edit_line, SNPRINTF_SIZE, "%s in line %d of file %s", reason, line, file) >= 0); } else { ASSERT (snprintf (edit_line, SNPRINTF_SIZE, "%s", reason) >= 0); } diagnostic_node (A68_RUNTIME_ERROR, error_node, ERROR_FFT, edit_line, gsl_strerror (gsl_errno)); exit_genie (error_node, A68_RUNTIME_ERROR); } /*! \brief detect math errors \param rc return code from function **/ static void fft_test_error (int rc) { if (rc != 0) { fft_error_handler ("math error", "", 0, rc); } } /*! \brief pop [] REAL on the stack as complex double [] \param p position in tree \param get whether to get elements from row in the stack \return double [] **/ static double *pop_array_real (NODE_T * p, int *len) { A68_REF desc; A68_ARRAY *arr; A68_TUPLE *tup; int inc, iindex, k; BYTE_T *base; double *v; error_node = p; /* Pop arguments */ POP_REF (p, &desc); CHECK_REF (p, desc, MODE (ROW_REAL)); GET_DESCRIPTOR (arr, tup, &desc); *len = ROW_SIZE (tup); if ((*len) <= 0) { return (NO_REAL); } v = malloc (2 * (size_t) (*len) * sizeof (double)); fft_test_error (v == NO_REAL ? GSL_ENOMEM : GSL_SUCCESS); base = DEREF (BYTE_T, &ARRAY (arr)); iindex = VECTOR_OFFSET (arr, tup); inc = SPAN (tup) * ELEM_SIZE (arr); for (k = 0; k < (*len); k++, iindex += inc) { A68_REAL *x = (A68_REAL *) (base + iindex); CHECK_INIT (p, INITIALISED (x), MODE (REAL)); v[2 * k] = VALUE (x); v[2 * k + 1] = 0.0; } return (v); } /*! \brief push double [] on the stack as [] REAL \param p position in tree **/ static void push_array_real (NODE_T * p, double *v, int len) { A68_REF desc, row; A68_ARRAY arr; A68_TUPLE tup; int inc, iindex, k; BYTE_T *base; error_node = p; desc = heap_generator (p, MODE (ROW_REAL), ALIGNED_SIZE_OF (A68_ARRAY) + ALIGNED_SIZE_OF (A68_TUPLE)); row = heap_generator (p, MODE (ROW_REAL), len * ALIGNED_SIZE_OF (A68_REAL)); DIM (&arr) = 1; MOID (&arr) = MODE (REAL); ELEM_SIZE (&arr) = ALIGNED_SIZE_OF (A68_REAL); SLICE_OFFSET (&arr) = FIELD_OFFSET (&arr) = 0; ARRAY (&arr) = row; LWB (&tup) = 1; UPB (&tup) = len; SHIFT (&tup) = LWB (&tup); SPAN (&tup) = 1; K (&tup) = 0; PUT_DESCRIPTOR (arr, tup, &desc); base = DEREF (BYTE_T, &ARRAY (&arr)); iindex = VECTOR_OFFSET (&arr, &tup); inc = SPAN (&tup) * ELEM_SIZE (&arr); for (k = 0; k < len; k++, iindex += inc) { A68_REAL *x = (A68_REAL *) (base + iindex); STATUS (x) = INIT_MASK; VALUE (x) = v[2 * k]; CHECK_REAL_REPRESENTATION (p, VALUE (x)); } PUSH_REF (p, desc); } /*! \brief pop [] COMPLEX on the stack as double [] \param p position in tree \param get whether to get elements from row in the stack \return double [] **/ static double *pop_array_complex (NODE_T * p, int *len) { A68_REF desc; A68_ARRAY *arr; A68_TUPLE *tup; int inc, iindex, k; BYTE_T *base; double *v; error_node = p; /* Pop arguments */ POP_REF (p, &desc); CHECK_REF (p, desc, MODE (ROW_COMPLEX)); GET_DESCRIPTOR (arr, tup, &desc); *len = ROW_SIZE (tup); if ((*len) <= 0) { return (NO_REAL); } v = malloc (2 * (size_t) (*len) * sizeof (double)); fft_test_error (v == NO_REAL ? GSL_ENOMEM : GSL_SUCCESS); base = DEREF (BYTE_T, &ARRAY (arr)); iindex = VECTOR_OFFSET (arr, tup); inc = SPAN (tup) * ELEM_SIZE (arr); for (k = 0; k < (*len); k++, iindex += inc) { A68_REAL *re = (A68_REAL *) (base + iindex); A68_REAL *im = (A68_REAL *) (base + iindex + ALIGNED_SIZE_OF (A68_REAL)); CHECK_INIT (p, INITIALISED (re), MODE (COMPLEX)); CHECK_INIT (p, INITIALISED (im), MODE (COMPLEX)); v[2 * k] = VALUE (re); v[2 * k + 1] = VALUE (im); } return (v); } /*! \brief push double [] on the stack as [] COMPLEX \param p position in tree **/ static void push_array_complex (NODE_T * p, double *v, int len) { A68_REF desc, row; A68_ARRAY arr; A68_TUPLE tup; int inc, iindex, k; BYTE_T *base; error_node = p; desc = heap_generator (p, MODE (ROW_COMPLEX), ALIGNED_SIZE_OF (A68_ARRAY) + ALIGNED_SIZE_OF (A68_TUPLE)); row = heap_generator (p, MODE (ROW_COMPLEX), len * 2 * ALIGNED_SIZE_OF (A68_REAL)); DIM (&arr) = 1; MOID (&arr) = MODE (COMPLEX); ELEM_SIZE (&arr) = 2 * ALIGNED_SIZE_OF (A68_REAL); SLICE_OFFSET (&arr) = FIELD_OFFSET (&arr) = 0; ARRAY (&arr) = row; LWB (&tup) = 1; UPB (&tup) = len; SHIFT (&tup) = LWB (&tup); SPAN (&tup) = 1; K (&tup) = 0; PUT_DESCRIPTOR (arr, tup, &desc); base = DEREF (BYTE_T, &ARRAY (&arr)); iindex = VECTOR_OFFSET (&arr, &tup); inc = SPAN (&tup) * ELEM_SIZE (&arr); for (k = 0; k < len; k++, iindex += inc) { A68_REAL *re = (A68_REAL *) (base + iindex); A68_REAL *im = (A68_REAL *) (base + iindex + ALIGNED_SIZE_OF (A68_REAL)); STATUS (re) = INIT_MASK; VALUE (re) = v[2 * k]; STATUS (im) = INIT_MASK; VALUE (im) = v[2 * k + 1]; CHECK_COMPLEX_REPRESENTATION (p, VALUE (re), VALUE (im)); } PUSH_REF (p, desc); } /*! \brief push prime factorisation on the stack as [] INT \param p position in tree **/ void genie_prime_factors (NODE_T * p) { gsl_error_handler_t *save_handler = gsl_set_error_handler (fft_error_handler); A68_INT n; A68_REF desc, row; A68_ARRAY arr; A68_TUPLE tup; int len, inc, iindex, k; BYTE_T *base; gsl_fft_complex_wavetable *wt; error_node = p; POP_OBJECT (p, &n, A68_INT); CHECK_INIT (p, INITIALISED (&n), MODE (INT)); wt = gsl_fft_complex_wavetable_alloc ((size_t) (VALUE (&n))); len = (int) (NF (wt)); desc = heap_generator (p, MODE (ROW_INT), ALIGNED_SIZE_OF (A68_ARRAY) + ALIGNED_SIZE_OF (A68_TUPLE)); row = heap_generator (p, MODE (ROW_INT), len * ALIGNED_SIZE_OF (A68_INT)); DIM (&arr) = 1; MOID (&arr) = MODE (INT); ELEM_SIZE (&arr) = ALIGNED_SIZE_OF (A68_INT); SLICE_OFFSET (&arr) = FIELD_OFFSET (&arr) = 0; ARRAY (&arr) = row; LWB (&tup) = 1; UPB (&tup) = len; SHIFT (&tup) = LWB (&tup); SPAN (&tup) = 1; K (&tup) = 0; PUT_DESCRIPTOR (arr, tup, &desc); base = DEREF (BYTE_T, &ARRAY (&arr)); iindex = VECTOR_OFFSET (&arr, &tup); inc = SPAN (&tup) * ELEM_SIZE (&arr); for (k = 0; k < len; k++, iindex += inc) { A68_INT *x = (A68_INT *) (base + iindex); STATUS (x) = INIT_MASK; VALUE (x) = (int) ((FACTOR (wt))[k]); } gsl_fft_complex_wavetable_free (wt); PUSH_REF (p, desc); (void) gsl_set_error_handler (save_handler); } /*! \brief PROC ([] COMPLEX) [] COMPLEX fft complex forward \param p position in tree **/ void genie_fft_complex_forward (NODE_T * p) { gsl_error_handler_t *save_handler = gsl_set_error_handler (fft_error_handler); int len, rc; double *data; gsl_fft_complex_wavetable *wt; gsl_fft_complex_workspace *ws; error_node = p; data = pop_array_complex (p, &len); fft_test_error (len == 0 ? GSL_EDOM : GSL_SUCCESS); wt = gsl_fft_complex_wavetable_alloc ((size_t) len); ws = gsl_fft_complex_workspace_alloc ((size_t) len); rc = gsl_fft_complex_forward (data, 1, (size_t) len, wt, ws); fft_test_error (rc); push_array_complex (p, data, len); gsl_fft_complex_wavetable_free (wt); gsl_fft_complex_workspace_free (ws); if (data != NO_REAL) { free (data); } (void) gsl_set_error_handler (save_handler); } /*! \brief PROC ([] COMPLEX) [] COMPLEX fft complex backward \param p position in tree **/ void genie_fft_complex_backward (NODE_T * p) { gsl_error_handler_t *save_handler = gsl_set_error_handler (fft_error_handler); int len, rc; double *data; gsl_fft_complex_wavetable *wt; gsl_fft_complex_workspace *ws; error_node = p; data = pop_array_complex (p, &len); fft_test_error (len == 0 ? GSL_EDOM : GSL_SUCCESS); wt = gsl_fft_complex_wavetable_alloc ((size_t) len); ws = gsl_fft_complex_workspace_alloc ((size_t) len); rc = gsl_fft_complex_backward (data, 1, (size_t) len, wt, ws); fft_test_error (rc); push_array_complex (p, data, len); gsl_fft_complex_wavetable_free (wt); gsl_fft_complex_workspace_free (ws); if (data != NO_REAL) { free (data); } (void) gsl_set_error_handler (save_handler); } /*! \brief PROC ([] COMPLEX) [] COMPLEX fft complex inverse \param p position in tree **/ void genie_fft_complex_inverse (NODE_T * p) { gsl_error_handler_t *save_handler = gsl_set_error_handler (fft_error_handler); int len, rc; double *data; gsl_fft_complex_wavetable *wt; gsl_fft_complex_workspace *ws; error_node = p; data = pop_array_complex (p, &len); fft_test_error (len == 0 ? GSL_EDOM : GSL_SUCCESS); wt = gsl_fft_complex_wavetable_alloc ((size_t) len); ws = gsl_fft_complex_workspace_alloc ((size_t) len); rc = gsl_fft_complex_inverse (data, 1, (size_t) len, wt, ws); fft_test_error (rc); push_array_complex (p, data, len); gsl_fft_complex_wavetable_free (wt); gsl_fft_complex_workspace_free (ws); if (data != NO_REAL) { free (data); } (void) gsl_set_error_handler (save_handler); } /*! \brief PROC ([] REAL) [] COMPLEX fft forward \param p position in tree **/ void genie_fft_forward (NODE_T * p) { gsl_error_handler_t *save_handler = gsl_set_error_handler (fft_error_handler); int len, rc; double *data; gsl_fft_complex_wavetable *wt; gsl_fft_complex_workspace *ws; error_node = p; data = pop_array_real (p, &len); fft_test_error (len == 0 ? GSL_EDOM : GSL_SUCCESS); wt = gsl_fft_complex_wavetable_alloc ((size_t) len); ws = gsl_fft_complex_workspace_alloc ((size_t) len); rc = gsl_fft_complex_forward (data, 1, (size_t) len, wt, ws); fft_test_error (rc); push_array_complex (p, data, len); gsl_fft_complex_wavetable_free (wt); gsl_fft_complex_workspace_free (ws); if (data != NO_REAL) { free (data); } (void) gsl_set_error_handler (save_handler); } /*! \brief PROC ([] COMPLEX) [] REAL fft backward \param p position in tree **/ void genie_fft_backward (NODE_T * p) { gsl_error_handler_t *save_handler = gsl_set_error_handler (fft_error_handler); int len, rc; double *data; gsl_fft_complex_wavetable *wt; gsl_fft_complex_workspace *ws; error_node = p; data = pop_array_complex (p, &len); fft_test_error (len == 0 ? GSL_EDOM : GSL_SUCCESS); wt = gsl_fft_complex_wavetable_alloc ((size_t) len); ws = gsl_fft_complex_workspace_alloc ((size_t) len); rc = gsl_fft_complex_backward (data, 1, (size_t) len, wt, ws); fft_test_error (rc); push_array_real (p, data, len); gsl_fft_complex_wavetable_free (wt); gsl_fft_complex_workspace_free (ws); if (data != NO_REAL) { free (data); } (void) gsl_set_error_handler (save_handler); } /*! \brief PROC ([] COMPLEX) [] REAL fft inverse \param p position in tree **/ void genie_fft_inverse (NODE_T * p) { gsl_error_handler_t *save_handler = gsl_set_error_handler (fft_error_handler); int len, rc; double *data; gsl_fft_complex_wavetable *wt; gsl_fft_complex_workspace *ws; error_node = p; data = pop_array_complex (p, &len); fft_test_error (len == 0 ? GSL_EDOM : GSL_SUCCESS); wt = gsl_fft_complex_wavetable_alloc ((size_t) len); ws = gsl_fft_complex_workspace_alloc ((size_t) len); rc = gsl_fft_complex_inverse (data, 1, (size_t) len, wt, ws); fft_test_error (rc); push_array_real (p, data, len); gsl_fft_complex_wavetable_free (wt); gsl_fft_complex_workspace_free (ws); if (data != NO_REAL) { free (data); } (void) gsl_set_error_handler (save_handler); } /*! \brief map GSL error handler onto a68g error handler \param reason error text \param file gsl file where error occured \param line line in above file \param int gsl error number **/ void laplace_error_handler (const char *reason, const char *file, int line, int gsl_errno) { if (line != 0) { ASSERT (snprintf (edit_line, SNPRINTF_SIZE, "%s in line %d of file %s", reason, line, file) >= 0); } else { ASSERT (snprintf (edit_line, SNPRINTF_SIZE, "%s", reason) >= 0); } diagnostic_node (A68_RUNTIME_ERROR, error_node, ERROR_LAPLACE, edit_line, gsl_strerror (gsl_errno)); exit_genie (error_node, A68_RUNTIME_ERROR); } /*! \brief detect math errors \param rc return code from function **/ static void laplace_test_error (int rc) { if (rc != 0) { laplace_error_handler ("math error", "", 0, rc); } } /*! \brief PROC (PROC (REAL) REAL, REAL, REF REAL) REAL laplace \param p position in tree **/ #define LAPLACE_DIVISIONS 1024 typedef struct A68_LAPLACE A68_LAPLACE; struct A68_LAPLACE { NODE_T *p; A68_PROCEDURE f; double s; }; double laplace_f (double t, void *z) { A68_LAPLACE *l = (A68_LAPLACE *) z; ADDR_T pop_sp = stack_pointer, pop_fp = frame_pointer; MOID_T *u = MODE (PROC_REAL_REAL); A68_REAL *ft = (A68_REAL *) STACK_TOP; PUSH_PRIMITIVE (P (l), t, A68_REAL); genie_call_procedure (P (l), MOID (&(F (l))), u, u, &(F (l)), pop_sp, pop_fp); stack_pointer = pop_sp; return (VALUE (ft) * a68g_exp (-(S (l)) * t)); } void genie_laplace (NODE_T * p) { A68_REF ref_error; A68_REAL s, *error; A68_PROCEDURE f; A68_LAPLACE l; gsl_function g; gsl_integration_workspace *w; double result, estimated_error; int rc; gsl_error_handler_t *save_handler = gsl_set_error_handler (laplace_error_handler); POP_REF (p, &ref_error); CHECK_REF (p, ref_error, MODE (REF_REAL)); error = (A68_REAL *) ADDRESS (&ref_error); POP_OBJECT (p, &s, A68_REAL); POP_PROCEDURE (p, &f); P (&l) = p; F (&l) = f; S (&l) = VALUE (&s); FUNCTION (&g) = &laplace_f; GSL_PARAMS (&g) = &l; w = gsl_integration_workspace_alloc (LAPLACE_DIVISIONS); if (VALUE (error) >= 0.0) { rc = gsl_integration_qagiu (&g, 0.0, VALUE (error), 0.0, LAPLACE_DIVISIONS, w, &result, &estimated_error); } else { rc = gsl_integration_qagiu (&g, 0.0, 0.0, -VALUE (error), LAPLACE_DIVISIONS, w, &result, &estimated_error); } laplace_test_error (rc); VALUE (error) = estimated_error; PUSH_PRIMITIVE (p, result, A68_REAL); gsl_integration_workspace_free (w); (void) gsl_set_error_handler (save_handler); } #endif /* defined HAVE_GNU_GSL */ algol68g-2.4.1/source/inet.c0000644000175000001440000004402011767464642012502 00000000000000/*! \file inet.c \brief standard prelude implementation */ /* This file is part of Algol68G - an Algol 68 interpreter. Copyright (C) 2001-2012 J. Marcel van der Veer . This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 3 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see . */ #include "a68g.h" #if defined HAVE_WINSOCK_H #include #endif #if defined HAVE_HTTP #if defined HAVE_WIN32 typedef int socklen_t; #endif /* defined HAVE_WIN32 */ #define PROTOCOL "tcp" #define SERVICE "http" #define CONTENT_BUFFER_SIZE (4 * KILOBYTE) #define TIMEOUT_INTERVAL 15 #if defined HAVE_WIN32 /*! \brief send GET request to server and yield answer (TCP/HTTP only) \param p position in tree **/ void genie_http_content (NODE_T * p) { WSADATA wsa_data; A68_REF path_string, domain_string, content_string; A68_INT port_number; int socket_id, conn, k, rc, len, sent; struct servent *service_address; struct hostent *host_address; struct protoent *protocol; struct sockaddr_in socket_address; char buffer[CONTENT_BUFFER_SIZE]; char *str; RESET_ERRNO; /* Pop arguments */ POP_OBJECT (p, &port_number, A68_INT); CHECK_INIT (p, INITIALISED (&port_number), MODE (INT)); POP_REF (p, &path_string); CHECK_INIT (p, INITIALISED (&path_string), MODE (STRING)); POP_REF (p, &domain_string); CHECK_INIT (p, INITIALISED (&domain_string), MODE (STRING)); POP_REF (p, &content_string); CHECK_REF (p, content_string, MODE (REF_STRING)); * DEREF (A68_REF, &content_string) = empty_string (p); /* Reset buffers */ reset_transput_buffer (DOMAIN_BUFFER); reset_transput_buffer (PATH_BUFFER); reset_transput_buffer (REQUEST_BUFFER); reset_transput_buffer (CONTENT_BUFFER); add_a_string_transput_buffer (p, DOMAIN_BUFFER, (BYTE_T *) & domain_string); add_a_string_transput_buffer (p, PATH_BUFFER, (BYTE_T *) & path_string); /* Make request */ add_string_transput_buffer (p, REQUEST_BUFFER, "GET "); add_string_transput_buffer (p, REQUEST_BUFFER, get_transput_buffer (PATH_BUFFER)); add_string_transput_buffer (p, REQUEST_BUFFER, " HTTP/1.0\n\n"); /* Connect to host */ if (WSAStartup(MAKEWORD(1, 1), &wsa_data) != NO_ERROR) { PUSH_PRIMITIVE (p, 1, A68_INT); return; } FILL (&socket_address, 0, (int) sizeof (socket_address)); SIN_FAMILY (&socket_address) = AF_INET; service_address = getservbyname (SERVICE, PROTOCOL); if (service_address == NULL) { PUSH_PRIMITIVE (p, 1, A68_INT); WSACleanup (); return; } if (VALUE (&port_number) == 0) { SIN_PORT (&socket_address) = (uint16_t) (S_PORT (service_address)); } else { /* Next line provokes inevitably: warning: conversion to 'short unsigned int' from 'int' may alter its value This warning can be safely ignored. */ SIN_PORT (&socket_address) = (uint16_t) (htons ((uint16_t) (VALUE (&port_number)))); if (SIN_PORT (&socket_address) == 0) { PUSH_PRIMITIVE (p, (errno == 0 ? 1 : errno), A68_INT); WSACleanup (); return; } } host_address = gethostbyname (get_transput_buffer (DOMAIN_BUFFER)); if (host_address == NULL) { PUSH_PRIMITIVE (p, (errno == 0 ? 1 : errno), A68_INT); WSACleanup (); return; } COPY (&SIN_ADDR (&socket_address), H_ADDR (host_address), H_LENGTH (host_address)); protocol = getprotobyname (PROTOCOL); if (protocol == NULL) { PUSH_PRIMITIVE (p, (errno == 0 ? 1 : errno), A68_INT); WSACleanup (); return; } socket_id = socket (PF_INET, SOCK_STREAM, P_PROTO (protocol)); if (socket_id < 0) { PUSH_PRIMITIVE (p, (errno == 0 ? 1 : errno), A68_INT); WSACleanup (); return; } conn = connect (socket_id, (const struct sockaddr *) &socket_address, (socklen_t) ALIGNED_SIZE_OF (socket_address)); if (conn < 0) { PUSH_PRIMITIVE (p, (errno == 0 ? 1 : errno), A68_INT); WSACleanup (); return; } /* Send request to host */ str = get_transput_buffer (REQUEST_BUFFER); len = (int) strlen (str); sent = 0; while (sent < len) { rc = send (socket_id, &str[sent], len - sent, 0); if (rc == SOCKET_ERROR) { PUSH_PRIMITIVE (p, (errno == 0 ? 1 : errno), A68_INT); WSACleanup (); } sent += rc; } /* Receive data from host */ while ((k = (int) recv (socket_id, (char *) &buffer, (CONTENT_BUFFER_SIZE - 1), 0)) > 0) { buffer[k] = NULL_CHAR; add_string_transput_buffer (p, CONTENT_BUFFER, buffer); } if (k < 0 || errno != 0) { PUSH_PRIMITIVE (p, (errno == 0 ? 1 : errno), A68_INT); WSACleanup (); return; } /* Convert string */ * DEREF (A68_REF, &content_string) = c_to_a_string (p, get_transput_buffer (CONTENT_BUFFER), get_transput_buffer_index (CONTENT_BUFFER)); if (k != 0) { /* Not gracefully closed by recv () */ ASSERT (close (socket_id) == 0); } PUSH_PRIMITIVE (p, errno, A68_INT); WSACleanup (); } /*! \brief send request to server and yield answer (TCP only) \param p position in tree **/ void genie_tcp_request (NODE_T * p) { WSADATA wsa_data; A68_REF path_string, domain_string, content_string; A68_INT port_number; int socket_id, conn, k, rc, len, sent; struct servent *service_address; struct hostent *host_address; struct protoent *protocol; struct sockaddr_in socket_address; char buffer[CONTENT_BUFFER_SIZE]; char *str; RESET_ERRNO; /* Pop arguments */ POP_OBJECT (p, &port_number, A68_INT); CHECK_INIT (p, INITIALISED (&port_number), MODE (INT)); POP_REF (p, &path_string); CHECK_INIT (p, INITIALISED (&path_string), MODE (STRING)); POP_REF (p, &domain_string); CHECK_INIT (p, INITIALISED (&domain_string), MODE (STRING)); POP_REF (p, &content_string); CHECK_REF (p, content_string, MODE (REF_STRING)); * DEREF (A68_REF, &content_string) = empty_string (p); /* Reset buffers */ reset_transput_buffer (DOMAIN_BUFFER); reset_transput_buffer (PATH_BUFFER); reset_transput_buffer (REQUEST_BUFFER); reset_transput_buffer (CONTENT_BUFFER); add_a_string_transput_buffer (p, DOMAIN_BUFFER, (BYTE_T *) & domain_string); add_a_string_transput_buffer (p, PATH_BUFFER, (BYTE_T *) & path_string); /* Make request */ add_string_transput_buffer (p, REQUEST_BUFFER, get_transput_buffer (PATH_BUFFER)); /* Connect to host */ if (WSAStartup(MAKEWORD(1, 1), &wsa_data) != NO_ERROR) { PUSH_PRIMITIVE (p, 1, A68_INT); return; } FILL (&socket_address, 0, (int) sizeof (socket_address)); SIN_FAMILY (&socket_address) = AF_INET; service_address = getservbyname (SERVICE, PROTOCOL); if (service_address == NULL) { PUSH_PRIMITIVE (p, 1, A68_INT); WSACleanup (); return; } if (VALUE (&port_number) == 0) { SIN_PORT (&socket_address) = (uint16_t) (S_PORT (service_address)); } else { /* Next line provokes inevitably: warning: conversion to 'short unsigned int' from 'int' may alter its value This warning can be safely ignored. */ SIN_PORT (&socket_address) = (uint16_t) (htons ((uint16_t) (VALUE (&port_number)))); if (SIN_PORT (&socket_address) == 0) { PUSH_PRIMITIVE (p, (errno == 0 ? 1 : errno), A68_INT); WSACleanup (); return; } } host_address = gethostbyname (get_transput_buffer (DOMAIN_BUFFER)); if (host_address == NULL) { PUSH_PRIMITIVE (p, (errno == 0 ? 1 : errno), A68_INT); WSACleanup (); return; } COPY (&SIN_ADDR (&socket_address), H_ADDR (host_address), H_LENGTH (host_address)); protocol = getprotobyname (PROTOCOL); if (protocol == NULL) { PUSH_PRIMITIVE (p, (errno == 0 ? 1 : errno), A68_INT); WSACleanup (); return; } socket_id = socket (PF_INET, SOCK_STREAM, P_PROTO (protocol)); if (socket_id < 0) { PUSH_PRIMITIVE (p, (errno == 0 ? 1 : errno), A68_INT); WSACleanup (); return; } conn = connect (socket_id, (const struct sockaddr *) &socket_address, (socklen_t) ALIGNED_SIZE_OF (socket_address)); if (conn < 0) { PUSH_PRIMITIVE (p, (errno == 0 ? 1 : errno), A68_INT); WSACleanup (); return; } /* Send request to host */ str = get_transput_buffer (REQUEST_BUFFER); len = (int) strlen (str); sent = 0; while (sent < len) { rc = send (socket_id, &str[sent], len - sent, 0); if (rc == SOCKET_ERROR) { PUSH_PRIMITIVE (p, (errno == 0 ? 1 : errno), A68_INT); WSACleanup (); } sent += rc; } /* Receive data from host */ while ((k = (int) recv (socket_id, (char *) &buffer, (CONTENT_BUFFER_SIZE - 1), 0)) > 0) { buffer[k] = NULL_CHAR; add_string_transput_buffer (p, CONTENT_BUFFER, buffer); } if (k < 0 || errno != 0) { PUSH_PRIMITIVE (p, (errno == 0 ? 1 : errno), A68_INT); WSACleanup (); return; } /* Convert string */ * DEREF (A68_REF, &content_string) = c_to_a_string (p, get_transput_buffer (CONTENT_BUFFER), get_transput_buffer_index (CONTENT_BUFFER)); if (k != 0) { /* Not gracefully closed by recv () */ ASSERT (close (socket_id) == 0); } PUSH_PRIMITIVE (p, errno, A68_INT); WSACleanup (); } #else /* ! defined HAVE_WIN32 */ /*! \brief send GET request to server and yield answer (TCP/HTTP only) \param p position in tree **/ void genie_http_content (NODE_T * p) { A68_REF path_string, domain_string, content_string; A68_INT port_number; int socket_id, conn, k; fd_set set; struct timeval a68g_timeout; struct servent *service_address; struct hostent *host_address; struct protoent *protocol; struct sockaddr_in socket_address; char buffer[CONTENT_BUFFER_SIZE]; RESET_ERRNO; /* Pop arguments */ POP_OBJECT (p, &port_number, A68_INT); CHECK_INIT (p, INITIALISED (&port_number), MODE (INT)); POP_REF (p, &path_string); CHECK_INIT (p, INITIALISED (&path_string), MODE (STRING)); POP_REF (p, &domain_string); CHECK_INIT (p, INITIALISED (&domain_string), MODE (STRING)); POP_REF (p, &content_string); CHECK_REF (p, content_string, MODE (REF_STRING)); * DEREF (A68_REF, &content_string) = empty_string (p); /* Reset buffers */ reset_transput_buffer (DOMAIN_BUFFER); reset_transput_buffer (PATH_BUFFER); reset_transput_buffer (REQUEST_BUFFER); reset_transput_buffer (CONTENT_BUFFER); add_a_string_transput_buffer (p, DOMAIN_BUFFER, (BYTE_T *) & domain_string); add_a_string_transput_buffer (p, PATH_BUFFER, (BYTE_T *) & path_string); /* Make request */ add_string_transput_buffer (p, REQUEST_BUFFER, "GET "); add_string_transput_buffer (p, REQUEST_BUFFER, get_transput_buffer (PATH_BUFFER)); add_string_transput_buffer (p, REQUEST_BUFFER, " HTTP/1.0\n\n"); /* Connect to host */ FILL (&socket_address, 0, (int) sizeof (socket_address)); SIN_FAMILY (&socket_address) = AF_INET; service_address = getservbyname (SERVICE, PROTOCOL); if (service_address == NULL) { PUSH_PRIMITIVE (p, 1, A68_INT); return; } if (VALUE (&port_number) == 0) { SIN_PORT (&socket_address) = (uint16_t) (S_PORT (service_address)); } else { /* Next line provokes inevitably: warning: conversion to 'short unsigned int' from 'int' may alter its value This warning can be safely ignored. */ SIN_PORT (&socket_address) = (uint16_t) (htons ((uint16_t) (VALUE (&port_number)))); if (SIN_PORT (&socket_address) == 0) { PUSH_PRIMITIVE (p, (errno == 0 ? 1 : errno), A68_INT); return; } } host_address = gethostbyname (get_transput_buffer (DOMAIN_BUFFER)); if (host_address == NULL) { PUSH_PRIMITIVE (p, (errno == 0 ? 1 : errno), A68_INT); return; } COPY (&SIN_ADDR (&socket_address), H_ADDR (host_address), H_LENGTH (host_address)); protocol = getprotobyname (PROTOCOL); if (protocol == NULL) { PUSH_PRIMITIVE (p, (errno == 0 ? 1 : errno), A68_INT); return; } socket_id = socket (PF_INET, SOCK_STREAM, P_PROTO (protocol)); if (socket_id < 0) { PUSH_PRIMITIVE (p, (errno == 0 ? 1 : errno), A68_INT); return; } conn = connect (socket_id, (const struct sockaddr *) &socket_address, (socklen_t) ALIGNED_SIZE_OF (socket_address)); if (conn < 0) { PUSH_PRIMITIVE (p, (errno == 0 ? 1 : errno), A68_INT); ASSERT (close (socket_id) == 0); return; } /* Read from host */ WRITE (socket_id, get_transput_buffer (REQUEST_BUFFER)); if (errno != 0) { PUSH_PRIMITIVE (p, errno, A68_INT); ASSERT (close (socket_id) == 0); return; } /* Initialise file descriptor set */ FD_ZERO (&set); FD_SET (socket_id, &set); /* Initialise the a68g_timeout data structure */ TV_SEC (&a68g_timeout) = TIMEOUT_INTERVAL; TV_USEC (&a68g_timeout) = 0; /* Block until server replies or a68g_timeout blows up */ switch (select (FD_SETSIZE, &set, NULL, NULL, &a68g_timeout)) { case 0: { errno = ETIMEDOUT; PUSH_PRIMITIVE (p, errno, A68_INT); ASSERT (close (socket_id) == 0); return; } case -1: { PUSH_PRIMITIVE (p, errno, A68_INT); ASSERT (close (socket_id) == 0); return; } case 1: { break; } default: { ABEND (A68_TRUE, "unexpected result from select", NO_TEXT); } } while ((k = (int) io_read (socket_id, &buffer, (CONTENT_BUFFER_SIZE - 1))) > 0) { buffer[k] = NULL_CHAR; add_string_transput_buffer (p, CONTENT_BUFFER, buffer); } if (k < 0 || errno != 0) { PUSH_PRIMITIVE (p, (errno == 0 ? 1 : errno), A68_INT); ASSERT (close (socket_id) == 0); return; } /* Convert string */ * DEREF (A68_REF, &content_string) = c_to_a_string (p, get_transput_buffer (CONTENT_BUFFER), get_transput_buffer_index (CONTENT_BUFFER)); ASSERT (close (socket_id) == 0); PUSH_PRIMITIVE (p, errno, A68_INT); } /*! \brief send request to server and yield answer (TCP only) \param p position in tree **/ void genie_tcp_request (NODE_T * p) { A68_REF path_string, domain_string, content_string; A68_INT port_number; int socket_id, conn, k; fd_set set; struct timeval a68g_timeout; struct servent *service_address; struct hostent *host_address; struct protoent *protocol; struct sockaddr_in socket_address; char buffer[CONTENT_BUFFER_SIZE]; RESET_ERRNO; /* Pop arguments */ POP_OBJECT (p, &port_number, A68_INT); CHECK_INIT (p, INITIALISED (&port_number), MODE (INT)); POP_REF (p, &path_string); CHECK_INIT (p, INITIALISED (&path_string), MODE (STRING)); POP_REF (p, &domain_string); CHECK_INIT (p, INITIALISED (&domain_string), MODE (STRING)); POP_REF (p, &content_string); CHECK_REF (p, content_string, MODE (REF_STRING)); * DEREF (A68_REF, &content_string) = empty_string (p); /* Reset buffers */ reset_transput_buffer (DOMAIN_BUFFER); reset_transput_buffer (PATH_BUFFER); reset_transput_buffer (REQUEST_BUFFER); reset_transput_buffer (CONTENT_BUFFER); add_a_string_transput_buffer (p, DOMAIN_BUFFER, (BYTE_T *) & domain_string); add_a_string_transput_buffer (p, PATH_BUFFER, (BYTE_T *) & path_string); /* Make request */ add_string_transput_buffer (p, REQUEST_BUFFER, get_transput_buffer (PATH_BUFFER)); /* Connect to host */ FILL (&socket_address, 0, (int) sizeof (socket_address)); SIN_FAMILY (&socket_address) = AF_INET; service_address = getservbyname (SERVICE, PROTOCOL); if (service_address == NULL) { PUSH_PRIMITIVE (p, 1, A68_INT); return; } if (VALUE (&port_number) == 0) { SIN_PORT (&socket_address) = (uint16_t) (S_PORT (service_address)); } else { /* Next line provokes inevitably: warning: conversion to 'short unsigned int' from 'int' may alter its value This warning can be safely ignored. */ SIN_PORT (&socket_address) = (uint16_t) (htons ((uint16_t) (VALUE (&port_number)))); if (SIN_PORT (&socket_address) == 0) { PUSH_PRIMITIVE (p, (errno == 0 ? 1 : errno), A68_INT); return; } } host_address = gethostbyname (get_transput_buffer (DOMAIN_BUFFER)); if (host_address == NULL) { PUSH_PRIMITIVE (p, (errno == 0 ? 1 : errno), A68_INT); return; } COPY (&SIN_ADDR (&socket_address), H_ADDR (host_address), H_LENGTH (host_address)); protocol = getprotobyname (PROTOCOL); if (protocol == NULL) { PUSH_PRIMITIVE (p, (errno == 0 ? 1 : errno), A68_INT); return; } socket_id = socket (PF_INET, SOCK_STREAM, P_PROTO (protocol)); if (socket_id < 0) { PUSH_PRIMITIVE (p, (errno == 0 ? 1 : errno), A68_INT); return; } conn = connect (socket_id, (const struct sockaddr *) &socket_address, (socklen_t) ALIGNED_SIZE_OF (socket_address)); if (conn < 0) { PUSH_PRIMITIVE (p, (errno == 0 ? 1 : errno), A68_INT); ASSERT (close (socket_id) == 0); return; } /* Read from host */ WRITE (socket_id, get_transput_buffer (REQUEST_BUFFER)); if (errno != 0) { PUSH_PRIMITIVE (p, errno, A68_INT); ASSERT (close (socket_id) == 0); return; } /* Initialise file descriptor set */ FD_ZERO (&set); FD_SET (socket_id, &set); /* Initialise the a68g_timeout data structure */ TV_SEC (&a68g_timeout) = TIMEOUT_INTERVAL; TV_USEC (&a68g_timeout) = 0; /* Block until server replies or a68g_timeout blows up */ switch (select (FD_SETSIZE, &set, NULL, NULL, &a68g_timeout)) { case 0: { errno = ETIMEDOUT; PUSH_PRIMITIVE (p, errno, A68_INT); ASSERT (close (socket_id) == 0); return; } case -1: { PUSH_PRIMITIVE (p, errno, A68_INT); ASSERT (close (socket_id) == 0); return; } case 1: { break; } default: { ABEND (A68_TRUE, "unexpected result from select", NO_TEXT); } } while ((k = (int) io_read (socket_id, &buffer, (CONTENT_BUFFER_SIZE - 1))) > 0) { buffer[k] = NULL_CHAR; add_string_transput_buffer (p, CONTENT_BUFFER, buffer); } if (k < 0 || errno != 0) { PUSH_PRIMITIVE (p, (errno == 0 ? 1 : errno), A68_INT); ASSERT (close (socket_id) == 0); return; } /* Convert string */ * DEREF (A68_REF, &content_string) = c_to_a_string (p, get_transput_buffer (CONTENT_BUFFER), get_transput_buffer_index (CONTENT_BUFFER)); ASSERT (close (socket_id) == 0); PUSH_PRIMITIVE (p, errno, A68_INT); } #endif /* defined HAVE_WIN32 */ #endif /* HAVE_HTTP */ algol68g-2.4.1/AUTHORS0000644000175000001440000000013311755213124011124 00000000000000Author and copyright holder of Algol 68 Genie is Marcel van der Veer . algol68g-2.4.1/config.sub0000644000175000001440000010457111755213125012050 00000000000000#! /bin/sh # Configuration validation subroutine script. # Copyright (C) 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, # 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, # 2011 Free Software Foundation, Inc. timestamp='2011-06-03' # This file is (in principle) common to ALL GNU software. # The presence of a machine in this file suggests that SOME GNU software # can handle that machine. It does not imply ALL GNU software can. # # This file is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; if not, write to the Free Software # Foundation, Inc., 51 Franklin Street - Fifth Floor, Boston, MA # 02110-1301, USA. # # As a special exception to the GNU General Public License, if you # distribute this file as part of a program that contains a # configuration script generated by Autoconf, you may include it under # the same distribution terms that you use for the rest of that program. # Please send patches to . Submit a context # diff and a properly formatted GNU ChangeLog entry. # # Configuration subroutine to validate and canonicalize a configuration type. # Supply the specified configuration type as an argument. # If it is invalid, we print an error message on stderr and exit with code 1. # Otherwise, we print the canonical config type on stdout and succeed. # You can get the latest version of this script from: # http://git.savannah.gnu.org/gitweb/?p=config.git;a=blob_plain;f=config.sub;hb=HEAD # This file is supposed to be the same for all GNU packages # and recognize all the CPU types, system types and aliases # that are meaningful with *any* GNU software. # Each package is responsible for reporting which valid configurations # it does not support. The user should be able to distinguish # a failure to support a valid configuration from a meaningless # configuration. # The goal of this file is to map all the various variations of a given # machine specification into a single specification in the form: # CPU_TYPE-MANUFACTURER-OPERATING_SYSTEM # or in some cases, the newer four-part form: # CPU_TYPE-MANUFACTURER-KERNEL-OPERATING_SYSTEM # It is wrong to echo any other type of specification. me=`echo "$0" | sed -e 's,.*/,,'` usage="\ Usage: $0 [OPTION] CPU-MFR-OPSYS $0 [OPTION] ALIAS Canonicalize a configuration name. Operation modes: -h, --help print this help, then exit -t, --time-stamp print date of last modification, then exit -v, --version print version number, then exit Report bugs and patches to ." version="\ GNU config.sub ($timestamp) Copyright (C) 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc. This is free software; see the source for copying conditions. There is NO warranty; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE." help=" Try \`$me --help' for more information." # Parse command line while test $# -gt 0 ; do case $1 in --time-stamp | --time* | -t ) echo "$timestamp" ; exit ;; --version | -v ) echo "$version" ; exit ;; --help | --h* | -h ) echo "$usage"; exit ;; -- ) # Stop option processing shift; break ;; - ) # Use stdin as input. break ;; -* ) echo "$me: invalid option $1$help" exit 1 ;; *local*) # First pass through any local machine types. echo $1 exit ;; * ) break ;; esac done case $# in 0) echo "$me: missing argument$help" >&2 exit 1;; 1) ;; *) echo "$me: too many arguments$help" >&2 exit 1;; esac # Separate what the user gave into CPU-COMPANY and OS or KERNEL-OS (if any). # Here we must recognize all the valid KERNEL-OS combinations. maybe_os=`echo $1 | sed 's/^\(.*\)-\([^-]*-[^-]*\)$/\2/'` case $maybe_os in nto-qnx* | linux-gnu* | linux-android* | linux-dietlibc | linux-newlib* | \ linux-uclibc* | uclinux-uclibc* | uclinux-gnu* | kfreebsd*-gnu* | \ knetbsd*-gnu* | netbsd*-gnu* | \ kopensolaris*-gnu* | \ storm-chaos* | os2-emx* | rtmk-nova*) os=-$maybe_os basic_machine=`echo $1 | sed 's/^\(.*\)-\([^-]*-[^-]*\)$/\1/'` ;; *) basic_machine=`echo $1 | sed 's/-[^-]*$//'` if [ $basic_machine != $1 ] then os=`echo $1 | sed 's/.*-/-/'` else os=; fi ;; esac ### Let's recognize common machines as not being operating systems so ### that things like config.sub decstation-3100 work. We also ### recognize some manufacturers as not being operating systems, so we ### can provide default operating systems below. case $os in -sun*os*) # Prevent following clause from handling this invalid input. ;; -dec* | -mips* | -sequent* | -encore* | -pc532* | -sgi* | -sony* | \ -att* | -7300* | -3300* | -delta* | -motorola* | -sun[234]* | \ -unicom* | -ibm* | -next | -hp | -isi* | -apollo | -altos* | \ -convergent* | -ncr* | -news | -32* | -3600* | -3100* | -hitachi* |\ -c[123]* | -convex* | -sun | -crds | -omron* | -dg | -ultra | -tti* | \ -harris | -dolphin | -highlevel | -gould | -cbm | -ns | -masscomp | \ -apple | -axis | -knuth | -cray | -microblaze) os= basic_machine=$1 ;; -bluegene*) os=-cnk ;; -sim | -cisco | -oki | -wec | -winbond) os= basic_machine=$1 ;; -scout) ;; -wrs) os=-vxworks basic_machine=$1 ;; -chorusos*) os=-chorusos basic_machine=$1 ;; -chorusrdb) os=-chorusrdb basic_machine=$1 ;; -hiux*) os=-hiuxwe2 ;; -sco6) os=-sco5v6 basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` ;; -sco5) os=-sco3.2v5 basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` ;; -sco4) os=-sco3.2v4 basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` ;; -sco3.2.[4-9]*) os=`echo $os | sed -e 's/sco3.2./sco3.2v/'` basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` ;; -sco3.2v[4-9]*) # Don't forget version if it is 3.2v4 or newer. basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` ;; -sco5v6*) # Don't forget version if it is 3.2v4 or newer. basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` ;; -sco*) os=-sco3.2v2 basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` ;; -udk*) basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` ;; -isc) os=-isc2.2 basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` ;; -clix*) basic_machine=clipper-intergraph ;; -isc*) basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` ;; -lynx*) os=-lynxos ;; -ptx*) basic_machine=`echo $1 | sed -e 's/86-.*/86-sequent/'` ;; -windowsnt*) os=`echo $os | sed -e 's/windowsnt/winnt/'` ;; -psos*) os=-psos ;; -mint | -mint[0-9]*) basic_machine=m68k-atari os=-mint ;; esac # Decode aliases for certain CPU-COMPANY combinations. case $basic_machine in # Recognize the basic CPU types without company name. # Some are omitted here because they have special meanings below. 1750a | 580 \ | a29k \ | alpha | alphaev[4-8] | alphaev56 | alphaev6[78] | alphapca5[67] \ | alpha64 | alpha64ev[4-8] | alpha64ev56 | alpha64ev6[78] | alpha64pca5[67] \ | am33_2.0 \ | arc | arm | arm[bl]e | arme[lb] | armv[2345] | armv[345][lb] | avr | avr32 \ | bfin \ | c4x | clipper \ | d10v | d30v | dlx | dsp16xx \ | fido | fr30 | frv \ | h8300 | h8500 | hppa | hppa1.[01] | hppa2.0 | hppa2.0[nw] | hppa64 \ | i370 | i860 | i960 | ia64 \ | ip2k | iq2000 \ | lm32 \ | m32c | m32r | m32rle | m68000 | m68k | m88k \ | maxq | mb | microblaze | mcore | mep | metag \ | mips | mipsbe | mipseb | mipsel | mipsle \ | mips16 \ | mips64 | mips64el \ | mips64octeon | mips64octeonel \ | mips64orion | mips64orionel \ | mips64r5900 | mips64r5900el \ | mips64vr | mips64vrel \ | mips64vr4100 | mips64vr4100el \ | mips64vr4300 | mips64vr4300el \ | mips64vr5000 | mips64vr5000el \ | mips64vr5900 | mips64vr5900el \ | mipsisa32 | mipsisa32el \ | mipsisa32r2 | mipsisa32r2el \ | mipsisa64 | mipsisa64el \ | mipsisa64r2 | mipsisa64r2el \ | mipsisa64sb1 | mipsisa64sb1el \ | mipsisa64sr71k | mipsisa64sr71kel \ | mipstx39 | mipstx39el \ | mn10200 | mn10300 \ | moxie \ | mt \ | msp430 \ | nds32 | nds32le | nds32be \ | nios | nios2 \ | ns16k | ns32k \ | open8 \ | or32 \ | pdp10 | pdp11 | pj | pjl \ | powerpc | powerpc64 | powerpc64le | powerpcle \ | pyramid \ | rx \ | score \ | sh | sh[1234] | sh[24]a | sh[24]aeb | sh[23]e | sh[34]eb | sheb | shbe | shle | sh[1234]le | sh3ele \ | sh64 | sh64le \ | sparc | sparc64 | sparc64b | sparc64v | sparc86x | sparclet | sparclite \ | sparcv8 | sparcv9 | sparcv9b | sparcv9v \ | spu \ | tahoe | tic4x | tic54x | tic55x | tic6x | tic80 | tron \ | ubicom32 \ | v850 | v850e | v850e1 | v850e2 | v850es | v850e2v3 \ | we32k \ | x86 | xc16x | xstormy16 | xtensa \ | z8k | z80) basic_machine=$basic_machine-unknown ;; c54x) basic_machine=tic54x-unknown ;; c55x) basic_machine=tic55x-unknown ;; c6x) basic_machine=tic6x-unknown ;; m6811 | m68hc11 | m6812 | m68hc12 | picochip) # Motorola 68HC11/12. basic_machine=$basic_machine-unknown os=-none ;; m88110 | m680[12346]0 | m683?2 | m68360 | m5200 | v70 | w65 | z8k) ;; ms1) basic_machine=mt-unknown ;; strongarm | thumb | xscale) basic_machine=arm-unknown ;; xscaleeb) basic_machine=armeb-unknown ;; xscaleel) basic_machine=armel-unknown ;; # We use `pc' rather than `unknown' # because (1) that's what they normally are, and # (2) the word "unknown" tends to confuse beginning users. i*86 | x86_64) basic_machine=$basic_machine-pc ;; # Object if more than one company name word. *-*-*) echo Invalid configuration \`$1\': machine \`$basic_machine\' not recognized 1>&2 exit 1 ;; # Recognize the basic CPU types with company name. 580-* \ | a29k-* \ | alpha-* | alphaev[4-8]-* | alphaev56-* | alphaev6[78]-* \ | alpha64-* | alpha64ev[4-8]-* | alpha64ev56-* | alpha64ev6[78]-* \ | alphapca5[67]-* | alpha64pca5[67]-* | arc-* \ | arm-* | armbe-* | armle-* | armeb-* | armv*-* \ | avr-* | avr32-* \ | bfin-* | bs2000-* \ | c[123]* | c30-* | [cjt]90-* | c4x-* \ | clipper-* | craynv-* | cydra-* \ | d10v-* | d30v-* | dlx-* \ | elxsi-* \ | f30[01]-* | f700-* | fido-* | fr30-* | frv-* | fx80-* \ | h8300-* | h8500-* \ | hppa-* | hppa1.[01]-* | hppa2.0-* | hppa2.0[nw]-* | hppa64-* \ | i*86-* | i860-* | i960-* | ia64-* \ | ip2k-* | iq2000-* \ | lm32-* \ | m32c-* | m32r-* | m32rle-* \ | m68000-* | m680[012346]0-* | m68360-* | m683?2-* | m68k-* \ | m88110-* | m88k-* | maxq-* | mcore-* | metag-* | microblaze-* \ | mips-* | mipsbe-* | mipseb-* | mipsel-* | mipsle-* \ | mips16-* \ | mips64-* | mips64el-* \ | mips64octeon-* | mips64octeonel-* \ | mips64orion-* | mips64orionel-* \ | mips64r5900-* | mips64r5900el-* \ | mips64vr-* | mips64vrel-* \ | mips64vr4100-* | mips64vr4100el-* \ | mips64vr4300-* | mips64vr4300el-* \ | mips64vr5000-* | mips64vr5000el-* \ | mips64vr5900-* | mips64vr5900el-* \ | mipsisa32-* | mipsisa32el-* \ | mipsisa32r2-* | mipsisa32r2el-* \ | mipsisa64-* | mipsisa64el-* \ | mipsisa64r2-* | mipsisa64r2el-* \ | mipsisa64sb1-* | mipsisa64sb1el-* \ | mipsisa64sr71k-* | mipsisa64sr71kel-* \ | mipstx39-* | mipstx39el-* \ | mmix-* \ | mt-* \ | msp430-* \ | nds32-* | nds32le-* | nds32be-* \ | nios-* | nios2-* \ | none-* | np1-* | ns16k-* | ns32k-* \ | open8-* \ | orion-* \ | pdp10-* | pdp11-* | pj-* | pjl-* | pn-* | power-* \ | powerpc-* | powerpc64-* | powerpc64le-* | powerpcle-* \ | pyramid-* \ | romp-* | rs6000-* | rx-* \ | sh-* | sh[1234]-* | sh[24]a-* | sh[24]aeb-* | sh[23]e-* | sh[34]eb-* | sheb-* | shbe-* \ | shle-* | sh[1234]le-* | sh3ele-* | sh64-* | sh64le-* \ | sparc-* | sparc64-* | sparc64b-* | sparc64v-* | sparc86x-* | sparclet-* \ | sparclite-* \ | sparcv8-* | sparcv9-* | sparcv9b-* | sparcv9v-* | sv1-* | sx?-* \ | tahoe-* \ | tic30-* | tic4x-* | tic54x-* | tic55x-* | tic6x-* | tic80-* \ | tile*-* \ | tron-* \ | ubicom32-* \ | v850-* | v850e-* | v850e1-* | v850es-* | v850e2-* | v850e2v3-* \ | vax-* \ | we32k-* \ | x86-* | x86_64-* | xc16x-* | xps100-* \ | xstormy16-* | xtensa*-* \ | ymp-* \ | z8k-* | z80-*) ;; # Recognize the basic CPU types without company name, with glob match. xtensa*) basic_machine=$basic_machine-unknown ;; # Recognize the various machine names and aliases which stand # for a CPU type and a company and sometimes even an OS. 386bsd) basic_machine=i386-unknown os=-bsd ;; 3b1 | 7300 | 7300-att | att-7300 | pc7300 | safari | unixpc) basic_machine=m68000-att ;; 3b*) basic_machine=we32k-att ;; a29khif) basic_machine=a29k-amd os=-udi ;; abacus) basic_machine=abacus-unknown ;; adobe68k) basic_machine=m68010-adobe os=-scout ;; alliant | fx80) basic_machine=fx80-alliant ;; altos | altos3068) basic_machine=m68k-altos ;; am29k) basic_machine=a29k-none os=-bsd ;; amd64) basic_machine=x86_64-pc ;; amd64-*) basic_machine=x86_64-`echo $basic_machine | sed 's/^[^-]*-//'` ;; amdahl) basic_machine=580-amdahl os=-sysv ;; amiga | amiga-*) basic_machine=m68k-unknown ;; amigaos | amigados) basic_machine=m68k-unknown os=-amigaos ;; amigaunix | amix) basic_machine=m68k-unknown os=-sysv4 ;; apollo68) basic_machine=m68k-apollo os=-sysv ;; apollo68bsd) basic_machine=m68k-apollo os=-bsd ;; aros) basic_machine=i386-pc os=-aros ;; aux) basic_machine=m68k-apple os=-aux ;; balance) basic_machine=ns32k-sequent os=-dynix ;; blackfin) basic_machine=bfin-unknown os=-linux ;; blackfin-*) basic_machine=bfin-`echo $basic_machine | sed 's/^[^-]*-//'` os=-linux ;; bluegene*) basic_machine=powerpc-ibm os=-cnk ;; c54x-*) basic_machine=tic54x-`echo $basic_machine | sed 's/^[^-]*-//'` ;; c55x-*) basic_machine=tic55x-`echo $basic_machine | sed 's/^[^-]*-//'` ;; c6x-*) basic_machine=tic6x-`echo $basic_machine | sed 's/^[^-]*-//'` ;; c90) basic_machine=c90-cray os=-unicos ;; cegcc) basic_machine=arm-unknown os=-cegcc ;; convex-c1) basic_machine=c1-convex os=-bsd ;; convex-c2) basic_machine=c2-convex os=-bsd ;; convex-c32) basic_machine=c32-convex os=-bsd ;; convex-c34) basic_machine=c34-convex os=-bsd ;; convex-c38) basic_machine=c38-convex os=-bsd ;; cray | j90) basic_machine=j90-cray os=-unicos ;; craynv) basic_machine=craynv-cray os=-unicosmp ;; cr16 | cr16-*) basic_machine=cr16-unknown os=-elf ;; crds | unos) basic_machine=m68k-crds ;; crisv32 | crisv32-* | etraxfs*) basic_machine=crisv32-axis ;; cris | cris-* | etrax*) basic_machine=cris-axis ;; crx) basic_machine=crx-unknown os=-elf ;; da30 | da30-*) basic_machine=m68k-da30 ;; decstation | decstation-3100 | pmax | pmax-* | pmin | dec3100 | decstatn) basic_machine=mips-dec ;; decsystem10* | dec10*) basic_machine=pdp10-dec os=-tops10 ;; decsystem20* | dec20*) basic_machine=pdp10-dec os=-tops20 ;; delta | 3300 | motorola-3300 | motorola-delta \ | 3300-motorola | delta-motorola) basic_machine=m68k-motorola ;; delta88) basic_machine=m88k-motorola os=-sysv3 ;; dicos) basic_machine=i686-pc os=-dicos ;; djgpp) basic_machine=i586-pc os=-msdosdjgpp ;; dpx20 | dpx20-*) basic_machine=rs6000-bull os=-bosx ;; dpx2* | dpx2*-bull) basic_machine=m68k-bull os=-sysv3 ;; ebmon29k) basic_machine=a29k-amd os=-ebmon ;; elxsi) basic_machine=elxsi-elxsi os=-bsd ;; encore | umax | mmax) basic_machine=ns32k-encore ;; es1800 | OSE68k | ose68k | ose | OSE) basic_machine=m68k-ericsson os=-ose ;; fx2800) basic_machine=i860-alliant ;; genix) basic_machine=ns32k-ns ;; gmicro) basic_machine=tron-gmicro os=-sysv ;; go32) basic_machine=i386-pc os=-go32 ;; h3050r* | hiux*) basic_machine=hppa1.1-hitachi os=-hiuxwe2 ;; h8300hms) basic_machine=h8300-hitachi os=-hms ;; h8300xray) basic_machine=h8300-hitachi os=-xray ;; h8500hms) basic_machine=h8500-hitachi os=-hms ;; harris) basic_machine=m88k-harris os=-sysv3 ;; hp300-*) basic_machine=m68k-hp ;; hp300bsd) basic_machine=m68k-hp os=-bsd ;; hp300hpux) basic_machine=m68k-hp os=-hpux ;; hp3k9[0-9][0-9] | hp9[0-9][0-9]) basic_machine=hppa1.0-hp ;; hp9k2[0-9][0-9] | hp9k31[0-9]) basic_machine=m68000-hp ;; hp9k3[2-9][0-9]) basic_machine=m68k-hp ;; hp9k6[0-9][0-9] | hp6[0-9][0-9]) basic_machine=hppa1.0-hp ;; hp9k7[0-79][0-9] | hp7[0-79][0-9]) basic_machine=hppa1.1-hp ;; hp9k78[0-9] | hp78[0-9]) # FIXME: really hppa2.0-hp basic_machine=hppa1.1-hp ;; hp9k8[67]1 | hp8[67]1 | hp9k80[24] | hp80[24] | hp9k8[78]9 | hp8[78]9 | hp9k893 | hp893) # FIXME: really hppa2.0-hp basic_machine=hppa1.1-hp ;; hp9k8[0-9][13679] | hp8[0-9][13679]) basic_machine=hppa1.1-hp ;; hp9k8[0-9][0-9] | hp8[0-9][0-9]) basic_machine=hppa1.0-hp ;; hppa-next) os=-nextstep3 ;; hppaosf) basic_machine=hppa1.1-hp os=-osf ;; hppro) basic_machine=hppa1.1-hp os=-proelf ;; i370-ibm* | ibm*) basic_machine=i370-ibm ;; # I'm not sure what "Sysv32" means. Should this be sysv3.2? i*86v32) basic_machine=`echo $1 | sed -e 's/86.*/86-pc/'` os=-sysv32 ;; i*86v4*) basic_machine=`echo $1 | sed -e 's/86.*/86-pc/'` os=-sysv4 ;; i*86v) basic_machine=`echo $1 | sed -e 's/86.*/86-pc/'` os=-sysv ;; i*86sol2) basic_machine=`echo $1 | sed -e 's/86.*/86-pc/'` os=-solaris2 ;; i386mach) basic_machine=i386-mach os=-mach ;; i386-vsta | vsta) basic_machine=i386-unknown os=-vsta ;; iris | iris4d) basic_machine=mips-sgi case $os in -irix*) ;; *) os=-irix4 ;; esac ;; isi68 | isi) basic_machine=m68k-isi os=-sysv ;; m68knommu) basic_machine=m68k-unknown os=-linux ;; m68knommu-*) basic_machine=m68k-`echo $basic_machine | sed 's/^[^-]*-//'` os=-linux ;; m88k-omron*) basic_machine=m88k-omron ;; magnum | m3230) basic_machine=mips-mips os=-sysv ;; merlin) basic_machine=ns32k-utek os=-sysv ;; microblaze) basic_machine=microblaze-xilinx ;; mingw32) basic_machine=i386-pc os=-mingw32 ;; mingw32ce) basic_machine=arm-unknown os=-mingw32ce ;; miniframe) basic_machine=m68000-convergent ;; *mint | -mint[0-9]* | *MiNT | *MiNT[0-9]*) basic_machine=m68k-atari os=-mint ;; mips3*-*) basic_machine=`echo $basic_machine | sed -e 's/mips3/mips64/'` ;; mips3*) basic_machine=`echo $basic_machine | sed -e 's/mips3/mips64/'`-unknown ;; monitor) basic_machine=m68k-rom68k os=-coff ;; morphos) basic_machine=powerpc-unknown os=-morphos ;; msdos) basic_machine=i386-pc os=-msdos ;; ms1-*) basic_machine=`echo $basic_machine | sed -e 's/ms1-/mt-/'` ;; mvs) basic_machine=i370-ibm os=-mvs ;; ncr3000) basic_machine=i486-ncr os=-sysv4 ;; netbsd386) basic_machine=i386-unknown os=-netbsd ;; netwinder) basic_machine=armv4l-rebel os=-linux ;; news | news700 | news800 | news900) basic_machine=m68k-sony os=-newsos ;; news1000) basic_machine=m68030-sony os=-newsos ;; news-3600 | risc-news) basic_machine=mips-sony os=-newsos ;; necv70) basic_machine=v70-nec os=-sysv ;; next | m*-next ) basic_machine=m68k-next case $os in -nextstep* ) ;; -ns2*) os=-nextstep2 ;; *) os=-nextstep3 ;; esac ;; nh3000) basic_machine=m68k-harris os=-cxux ;; nh[45]000) basic_machine=m88k-harris os=-cxux ;; nindy960) basic_machine=i960-intel os=-nindy ;; mon960) basic_machine=i960-intel os=-mon960 ;; nonstopux) basic_machine=mips-compaq os=-nonstopux ;; np1) basic_machine=np1-gould ;; neo-tandem) basic_machine=neo-tandem ;; nse-tandem) basic_machine=nse-tandem ;; nsr-tandem) basic_machine=nsr-tandem ;; op50n-* | op60c-*) basic_machine=hppa1.1-oki os=-proelf ;; openrisc | openrisc-*) basic_machine=or32-unknown ;; os400) basic_machine=powerpc-ibm os=-os400 ;; OSE68000 | ose68000) basic_machine=m68000-ericsson os=-ose ;; os68k) basic_machine=m68k-none os=-os68k ;; pa-hitachi) basic_machine=hppa1.1-hitachi os=-hiuxwe2 ;; paragon) basic_machine=i860-intel os=-osf ;; parisc) basic_machine=hppa-unknown os=-linux ;; parisc-*) basic_machine=hppa-`echo $basic_machine | sed 's/^[^-]*-//'` os=-linux ;; pbd) basic_machine=sparc-tti ;; pbb) basic_machine=m68k-tti ;; pc532 | pc532-*) basic_machine=ns32k-pc532 ;; pc98) basic_machine=i386-pc ;; pc98-*) basic_machine=i386-`echo $basic_machine | sed 's/^[^-]*-//'` ;; pentium | p5 | k5 | k6 | nexgen | viac3) basic_machine=i586-pc ;; pentiumpro | p6 | 6x86 | athlon | athlon_*) basic_machine=i686-pc ;; pentiumii | pentium2 | pentiumiii | pentium3) basic_machine=i686-pc ;; pentium4) basic_machine=i786-pc ;; pentium-* | p5-* | k5-* | k6-* | nexgen-* | viac3-*) basic_machine=i586-`echo $basic_machine | sed 's/^[^-]*-//'` ;; pentiumpro-* | p6-* | 6x86-* | athlon-*) basic_machine=i686-`echo $basic_machine | sed 's/^[^-]*-//'` ;; pentiumii-* | pentium2-* | pentiumiii-* | pentium3-*) basic_machine=i686-`echo $basic_machine | sed 's/^[^-]*-//'` ;; pentium4-*) basic_machine=i786-`echo $basic_machine | sed 's/^[^-]*-//'` ;; pn) basic_machine=pn-gould ;; power) basic_machine=power-ibm ;; ppc | ppcbe) basic_machine=powerpc-unknown ;; ppc-* | ppcbe-*) basic_machine=powerpc-`echo $basic_machine | sed 's/^[^-]*-//'` ;; ppcle | powerpclittle | ppc-le | powerpc-little) basic_machine=powerpcle-unknown ;; ppcle-* | powerpclittle-*) basic_machine=powerpcle-`echo $basic_machine | sed 's/^[^-]*-//'` ;; ppc64) basic_machine=powerpc64-unknown ;; ppc64-*) basic_machine=powerpc64-`echo $basic_machine | sed 's/^[^-]*-//'` ;; ppc64le | powerpc64little | ppc64-le | powerpc64-little) basic_machine=powerpc64le-unknown ;; ppc64le-* | powerpc64little-*) basic_machine=powerpc64le-`echo $basic_machine | sed 's/^[^-]*-//'` ;; ps2) basic_machine=i386-ibm ;; pw32) basic_machine=i586-unknown os=-pw32 ;; rdos) basic_machine=i386-pc os=-rdos ;; rom68k) basic_machine=m68k-rom68k os=-coff ;; rm[46]00) basic_machine=mips-siemens ;; rtpc | rtpc-*) basic_machine=romp-ibm ;; s390 | s390-*) basic_machine=s390-ibm ;; s390x | s390x-*) basic_machine=s390x-ibm ;; sa29200) basic_machine=a29k-amd os=-udi ;; sb1) basic_machine=mipsisa64sb1-unknown ;; sb1el) basic_machine=mipsisa64sb1el-unknown ;; sde) basic_machine=mipsisa32-sde os=-elf ;; sei) basic_machine=mips-sei os=-seiux ;; sequent) basic_machine=i386-sequent ;; sh) basic_machine=sh-hitachi os=-hms ;; sh5el) basic_machine=sh5le-unknown ;; sh64) basic_machine=sh64-unknown ;; sparclite-wrs | simso-wrs) basic_machine=sparclite-wrs os=-vxworks ;; sps7) basic_machine=m68k-bull os=-sysv2 ;; spur) basic_machine=spur-unknown ;; st2000) basic_machine=m68k-tandem ;; stratus) basic_machine=i860-stratus os=-sysv4 ;; strongarm-* | thumb-*) basic_machine=arm-`echo $basic_machine | sed 's/^[^-]*-//'` ;; sun2) basic_machine=m68000-sun ;; sun2os3) basic_machine=m68000-sun os=-sunos3 ;; sun2os4) basic_machine=m68000-sun os=-sunos4 ;; sun3os3) basic_machine=m68k-sun os=-sunos3 ;; sun3os4) basic_machine=m68k-sun os=-sunos4 ;; sun4os3) basic_machine=sparc-sun os=-sunos3 ;; sun4os4) basic_machine=sparc-sun os=-sunos4 ;; sun4sol2) basic_machine=sparc-sun os=-solaris2 ;; sun3 | sun3-*) basic_machine=m68k-sun ;; sun4) basic_machine=sparc-sun ;; sun386 | sun386i | roadrunner) basic_machine=i386-sun ;; sv1) basic_machine=sv1-cray os=-unicos ;; symmetry) basic_machine=i386-sequent os=-dynix ;; t3e) basic_machine=alphaev5-cray os=-unicos ;; t90) basic_machine=t90-cray os=-unicos ;; tile*) basic_machine=$basic_machine-unknown os=-linux-gnu ;; tx39) basic_machine=mipstx39-unknown ;; tx39el) basic_machine=mipstx39el-unknown ;; toad1) basic_machine=pdp10-xkl os=-tops20 ;; tower | tower-32) basic_machine=m68k-ncr ;; tpf) basic_machine=s390x-ibm os=-tpf ;; udi29k) basic_machine=a29k-amd os=-udi ;; ultra3) basic_machine=a29k-nyu os=-sym1 ;; v810 | necv810) basic_machine=v810-nec os=-none ;; vaxv) basic_machine=vax-dec os=-sysv ;; vms) basic_machine=vax-dec os=-vms ;; vpp*|vx|vx-*) basic_machine=f301-fujitsu ;; vxworks960) basic_machine=i960-wrs os=-vxworks ;; vxworks68) basic_machine=m68k-wrs os=-vxworks ;; vxworks29k) basic_machine=a29k-wrs os=-vxworks ;; w65*) basic_machine=w65-wdc os=-none ;; w89k-*) basic_machine=hppa1.1-winbond os=-proelf ;; xbox) basic_machine=i686-pc os=-mingw32 ;; xps | xps100) basic_machine=xps100-honeywell ;; xscale-* | xscalee[bl]-*) basic_machine=`echo $basic_machine | sed 's/^xscale/arm/'` ;; ymp) basic_machine=ymp-cray os=-unicos ;; z8k-*-coff) basic_machine=z8k-unknown os=-sim ;; z80-*-coff) basic_machine=z80-unknown os=-sim ;; none) basic_machine=none-none os=-none ;; # Here we handle the default manufacturer of certain CPU types. It is in # some cases the only manufacturer, in others, it is the most popular. w89k) basic_machine=hppa1.1-winbond ;; op50n) basic_machine=hppa1.1-oki ;; op60c) basic_machine=hppa1.1-oki ;; romp) basic_machine=romp-ibm ;; mmix) basic_machine=mmix-knuth ;; rs6000) basic_machine=rs6000-ibm ;; vax) basic_machine=vax-dec ;; pdp10) # there are many clones, so DEC is not a safe bet basic_machine=pdp10-unknown ;; pdp11) basic_machine=pdp11-dec ;; we32k) basic_machine=we32k-att ;; sh[1234] | sh[24]a | sh[24]aeb | sh[34]eb | sh[1234]le | sh[23]ele) basic_machine=sh-unknown ;; sparc | sparcv8 | sparcv9 | sparcv9b | sparcv9v) basic_machine=sparc-sun ;; cydra) basic_machine=cydra-cydrome ;; orion) basic_machine=orion-highlevel ;; orion105) basic_machine=clipper-highlevel ;; mac | mpw | mac-mpw) basic_machine=m68k-apple ;; pmac | pmac-mpw) basic_machine=powerpc-apple ;; *-unknown) # Make sure to match an already-canonicalized machine name. ;; *) echo Invalid configuration \`$1\': machine \`$basic_machine\' not recognized 1>&2 exit 1 ;; esac # Here we canonicalize certain aliases for manufacturers. case $basic_machine in *-digital*) basic_machine=`echo $basic_machine | sed 's/digital.*/dec/'` ;; *-commodore*) basic_machine=`echo $basic_machine | sed 's/commodore.*/cbm/'` ;; *) ;; esac # Decode manufacturer-specific aliases for certain operating systems. if [ x"$os" != x"" ] then case $os in # First match some system type aliases # that might get confused with valid system types. # -solaris* is a basic system type, with this one exception. -auroraux) os=-auroraux ;; -solaris1 | -solaris1.*) os=`echo $os | sed -e 's|solaris1|sunos4|'` ;; -solaris) os=-solaris2 ;; -svr4*) os=-sysv4 ;; -unixware*) os=-sysv4.2uw ;; -gnu/linux*) os=`echo $os | sed -e 's|gnu/linux|linux-gnu|'` ;; # First accept the basic system types. # The portable systems comes first. # Each alternative MUST END IN A *, to match a version number. # -sysv* is not here because it comes later, after sysvr4. -gnu* | -bsd* | -mach* | -minix* | -genix* | -ultrix* | -irix* \ | -*vms* | -sco* | -esix* | -isc* | -aix* | -cnk* | -sunos | -sunos[34]*\ | -hpux* | -unos* | -osf* | -luna* | -dgux* | -auroraux* | -solaris* \ | -sym* | -kopensolaris* \ | -amigaos* | -amigados* | -msdos* | -newsos* | -unicos* | -aof* \ | -aos* | -aros* \ | -nindy* | -vxsim* | -vxworks* | -ebmon* | -hms* | -mvs* \ | -clix* | -riscos* | -uniplus* | -iris* | -rtu* | -xenix* \ | -hiux* | -386bsd* | -knetbsd* | -mirbsd* | -netbsd* \ | -openbsd* | -solidbsd* \ | -ekkobsd* | -kfreebsd* | -freebsd* | -riscix* | -lynxos* \ | -bosx* | -nextstep* | -cxux* | -aout* | -elf* | -oabi* \ | -ptx* | -coff* | -ecoff* | -winnt* | -domain* | -vsta* \ | -udi* | -eabi* | -lites* | -ieee* | -go32* | -aux* \ | -chorusos* | -chorusrdb* | -cegcc* \ | -cygwin* | -pe* | -psos* | -moss* | -proelf* | -rtems* \ | -mingw32* | -linux-gnu* | -linux-android* \ | -linux-newlib* | -linux-uclibc* \ | -uxpv* | -beos* | -mpeix* | -udk* \ | -interix* | -uwin* | -mks* | -rhapsody* | -darwin* | -opened* \ | -openstep* | -oskit* | -conix* | -pw32* | -nonstopux* \ | -storm-chaos* | -tops10* | -tenex* | -tops20* | -its* \ | -os2* | -vos* | -palmos* | -uclinux* | -nucleus* \ | -morphos* | -superux* | -rtmk* | -rtmk-nova* | -windiss* \ | -powermax* | -dnix* | -nx6 | -nx7 | -sei* | -dragonfly* \ | -skyos* | -haiku* | -rdos* | -toppers* | -drops* | -es*) # Remember, each alternative MUST END IN *, to match a version number. ;; -qnx*) case $basic_machine in x86-* | i*86-*) ;; *) os=-nto$os ;; esac ;; -nto-qnx*) ;; -nto*) os=`echo $os | sed -e 's|nto|nto-qnx|'` ;; -sim | -es1800* | -hms* | -xray | -os68k* | -none* | -v88r* \ | -windows* | -osx | -abug | -netware* | -os9* | -beos* | -haiku* \ | -macos* | -mpw* | -magic* | -mmixware* | -mon960* | -lnews*) ;; -mac*) os=`echo $os | sed -e 's|mac|macos|'` ;; -linux-dietlibc) os=-linux-dietlibc ;; -linux*) os=`echo $os | sed -e 's|linux|linux-gnu|'` ;; -sunos5*) os=`echo $os | sed -e 's|sunos5|solaris2|'` ;; -sunos6*) os=`echo $os | sed -e 's|sunos6|solaris3|'` ;; -opened*) os=-openedition ;; -os400*) os=-os400 ;; -wince*) os=-wince ;; -osfrose*) os=-osfrose ;; -osf*) os=-osf ;; -utek*) os=-bsd ;; -dynix*) os=-bsd ;; -acis*) os=-aos ;; -atheos*) os=-atheos ;; -syllable*) os=-syllable ;; -386bsd) os=-bsd ;; -ctix* | -uts*) os=-sysv ;; -nova*) os=-rtmk-nova ;; -ns2 ) os=-nextstep2 ;; -nsk*) os=-nsk ;; # Preserve the version number of sinix5. -sinix5.*) os=`echo $os | sed -e 's|sinix|sysv|'` ;; -sinix*) os=-sysv4 ;; -tpf*) os=-tpf ;; -triton*) os=-sysv3 ;; -oss*) os=-sysv3 ;; -svr4) os=-sysv4 ;; -svr3) os=-sysv3 ;; -sysvr4) os=-sysv4 ;; # This must come after -sysvr4. -sysv*) ;; -ose*) os=-ose ;; -es1800*) os=-ose ;; -xenix) os=-xenix ;; -*mint | -mint[0-9]* | -*MiNT | -MiNT[0-9]*) os=-mint ;; -aros*) os=-aros ;; -kaos*) os=-kaos ;; -zvmoe) os=-zvmoe ;; -dicos*) os=-dicos ;; -nacl*) ;; -none) ;; *) # Get rid of the `-' at the beginning of $os. os=`echo $os | sed 's/[^-]*-//'` echo Invalid configuration \`$1\': system \`$os\' not recognized 1>&2 exit 1 ;; esac else # Here we handle the default operating systems that come with various machines. # The value should be what the vendor currently ships out the door with their # machine or put another way, the most popular os provided with the machine. # Note that if you're going to try to match "-MANUFACTURER" here (say, # "-sun"), then you have to tell the case statement up towards the top # that MANUFACTURER isn't an operating system. Otherwise, code above # will signal an error saying that MANUFACTURER isn't an operating # system, and we'll never get to this point. case $basic_machine in score-*) os=-elf ;; spu-*) os=-elf ;; *-acorn) os=-riscix1.2 ;; arm*-rebel) os=-linux ;; arm*-semi) os=-aout ;; c4x-* | tic4x-*) os=-coff ;; tic54x-*) os=-coff ;; tic55x-*) os=-coff ;; tic6x-*) os=-coff ;; # This must come before the *-dec entry. pdp10-*) os=-tops20 ;; pdp11-*) os=-none ;; *-dec | vax-*) os=-ultrix4.2 ;; m68*-apollo) os=-domain ;; i386-sun) os=-sunos4.0.2 ;; m68000-sun) os=-sunos3 # This also exists in the configure program, but was not the # default. # os=-sunos4 ;; m68*-cisco) os=-aout ;; mep-*) os=-elf ;; mips*-cisco) os=-elf ;; mips*-*) os=-elf ;; or32-*) os=-coff ;; *-tti) # must be before sparc entry or we get the wrong os. os=-sysv3 ;; sparc-* | *-sun) os=-sunos4.1.1 ;; *-be) os=-beos ;; *-haiku) os=-haiku ;; *-ibm) os=-aix ;; *-knuth) os=-mmixware ;; *-wec) os=-proelf ;; *-winbond) os=-proelf ;; *-oki) os=-proelf ;; *-hp) os=-hpux ;; *-hitachi) os=-hiux ;; i860-* | *-att | *-ncr | *-altos | *-motorola | *-convergent) os=-sysv ;; *-cbm) os=-amigaos ;; *-dg) os=-dgux ;; *-dolphin) os=-sysv3 ;; m68k-ccur) os=-rtu ;; m88k-omron*) os=-luna ;; *-next ) os=-nextstep ;; *-sequent) os=-ptx ;; *-crds) os=-unos ;; *-ns) os=-genix ;; i370-*) os=-mvs ;; *-next) os=-nextstep3 ;; *-gould) os=-sysv ;; *-highlevel) os=-bsd ;; *-encore) os=-bsd ;; *-sgi) os=-irix ;; *-siemens) os=-sysv4 ;; *-masscomp) os=-rtu ;; f30[01]-fujitsu | f700-fujitsu) os=-uxpv ;; *-rom68k) os=-coff ;; *-*bug) os=-coff ;; *-apple) os=-macos ;; *-atari*) os=-mint ;; *) os=-none ;; esac fi # Here we handle the case where we know the os, and the CPU type, but not the # manufacturer. We pick the logical manufacturer. vendor=unknown case $basic_machine in *-unknown) case $os in -riscix*) vendor=acorn ;; -sunos*) vendor=sun ;; -cnk*|-aix*) vendor=ibm ;; -beos*) vendor=be ;; -hpux*) vendor=hp ;; -mpeix*) vendor=hp ;; -hiux*) vendor=hitachi ;; -unos*) vendor=crds ;; -dgux*) vendor=dg ;; -luna*) vendor=omron ;; -genix*) vendor=ns ;; -mvs* | -opened*) vendor=ibm ;; -os400*) vendor=ibm ;; -ptx*) vendor=sequent ;; -tpf*) vendor=ibm ;; -vxsim* | -vxworks* | -windiss*) vendor=wrs ;; -aux*) vendor=apple ;; -hms*) vendor=hitachi ;; -mpw* | -macos*) vendor=apple ;; -*mint | -mint[0-9]* | -*MiNT | -MiNT[0-9]*) vendor=atari ;; -vos*) vendor=stratus ;; esac basic_machine=`echo $basic_machine | sed "s/unknown/$vendor/"` ;; esac echo $basic_machine$os exit # Local variables: # eval: (add-hook 'write-file-hooks 'time-stamp) # time-stamp-start: "timestamp='" # time-stamp-format: "%:y-%02m-%02d" # time-stamp-end: "'" # End: algol68g-2.4.1/install-sh0000755000175000001440000003246411551405127012074 00000000000000#!/bin/sh # install - install a program, script, or datafile scriptversion=2006-12-25.00 # This originates from X11R5 (mit/util/scripts/install.sh), which was # later released in X11R6 (xc/config/util/install.sh) with the # following copyright and license. # # Copyright (C) 1994 X Consortium # # Permission is hereby granted, free of charge, to any person obtaining a copy # of this software and associated documentation files (the "Software"), to # deal in the Software without restriction, including without limitation the # rights to use, copy, modify, merge, publish, distribute, sublicense, and/or # sell copies of the Software, and to permit persons to whom the Software is # furnished to do so, subject to the following conditions: # # The above copyright notice and this permission notice shall be included in # all copies or substantial portions of the Software. # # THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR # IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, # FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE # X CONSORTIUM BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN # AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNEC- # TION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. # # Except as contained in this notice, the name of the X Consortium shall not # be used in advertising or otherwise to promote the sale, use or other deal- # ings in this Software without prior written authorization from the X Consor- # tium. # # # FSF changes to this file are in the public domain. # # Calling this script install-sh is preferred over install.sh, to prevent # `make' implicit rules from creating a file called install from it # when there is no Makefile. # # This script is compatible with the BSD install script, but was written # from scratch. nl=' ' IFS=" "" $nl" # set DOITPROG to echo to test this script # Don't use :- since 4.3BSD and earlier shells don't like it. doit=${DOITPROG-} if test -z "$doit"; then doit_exec=exec else doit_exec=$doit fi # Put in absolute file names if you don't have them in your path; # or use environment vars. chgrpprog=${CHGRPPROG-chgrp} chmodprog=${CHMODPROG-chmod} chownprog=${CHOWNPROG-chown} cmpprog=${CMPPROG-cmp} cpprog=${CPPROG-cp} mkdirprog=${MKDIRPROG-mkdir} mvprog=${MVPROG-mv} rmprog=${RMPROG-rm} stripprog=${STRIPPROG-strip} posix_glob='?' initialize_posix_glob=' test "$posix_glob" != "?" || { if (set -f) 2>/dev/null; then posix_glob= else posix_glob=: fi } ' posix_mkdir= # Desired mode of installed file. mode=0755 chgrpcmd= chmodcmd=$chmodprog chowncmd= mvcmd=$mvprog rmcmd="$rmprog -f" stripcmd= src= dst= dir_arg= dst_arg= copy_on_change=false no_target_directory= usage="\ Usage: $0 [OPTION]... [-T] SRCFILE DSTFILE or: $0 [OPTION]... SRCFILES... DIRECTORY or: $0 [OPTION]... -t DIRECTORY SRCFILES... or: $0 [OPTION]... -d DIRECTORIES... In the 1st form, copy SRCFILE to DSTFILE. In the 2nd and 3rd, copy all SRCFILES to DIRECTORY. In the 4th, create DIRECTORIES. Options: --help display this help and exit. --version display version info and exit. -c (ignored) -C install only if different (preserve the last data modification time) -d create directories instead of installing files. -g GROUP $chgrpprog installed files to GROUP. -m MODE $chmodprog installed files to MODE. -o USER $chownprog installed files to USER. -s $stripprog installed files. -t DIRECTORY install into DIRECTORY. -T report an error if DSTFILE is a directory. Environment variables override the default commands: CHGRPPROG CHMODPROG CHOWNPROG CMPPROG CPPROG MKDIRPROG MVPROG RMPROG STRIPPROG " while test $# -ne 0; do case $1 in -c) ;; -C) copy_on_change=true;; -d) dir_arg=true;; -g) chgrpcmd="$chgrpprog $2" shift;; --help) echo "$usage"; exit $?;; -m) mode=$2 case $mode in *' '* | *' '* | *' '* | *'*'* | *'?'* | *'['*) echo "$0: invalid mode: $mode" >&2 exit 1;; esac shift;; -o) chowncmd="$chownprog $2" shift;; -s) stripcmd=$stripprog;; -t) dst_arg=$2 shift;; -T) no_target_directory=true;; --version) echo "$0 $scriptversion"; exit $?;; --) shift break;; -*) echo "$0: invalid option: $1" >&2 exit 1;; *) break;; esac shift done if test $# -ne 0 && test -z "$dir_arg$dst_arg"; then # When -d is used, all remaining arguments are directories to create. # When -t is used, the destination is already specified. # Otherwise, the last argument is the destination. Remove it from $@. for arg do if test -n "$dst_arg"; then # $@ is not empty: it contains at least $arg. set fnord "$@" "$dst_arg" shift # fnord fi shift # arg dst_arg=$arg done fi if test $# -eq 0; then if test -z "$dir_arg"; then echo "$0: no input file specified." >&2 exit 1 fi # It's OK to call `install-sh -d' without argument. # This can happen when creating conditional directories. exit 0 fi if test -z "$dir_arg"; then trap '(exit $?); exit' 1 2 13 15 # Set umask so as not to create temps with too-generous modes. # However, 'strip' requires both read and write access to temps. case $mode in # Optimize common cases. *644) cp_umask=133;; *755) cp_umask=22;; *[0-7]) if test -z "$stripcmd"; then u_plus_rw= else u_plus_rw='% 200' fi cp_umask=`expr '(' 777 - $mode % 1000 ')' $u_plus_rw`;; *) if test -z "$stripcmd"; then u_plus_rw= else u_plus_rw=,u+rw fi cp_umask=$mode$u_plus_rw;; esac fi for src do # Protect names starting with `-'. case $src in -*) src=./$src;; esac if test -n "$dir_arg"; then dst=$src dstdir=$dst test -d "$dstdir" dstdir_status=$? else # Waiting for this to be detected by the "$cpprog $src $dsttmp" command # might cause directories to be created, which would be especially bad # if $src (and thus $dsttmp) contains '*'. if test ! -f "$src" && test ! -d "$src"; then echo "$0: $src does not exist." >&2 exit 1 fi if test -z "$dst_arg"; then echo "$0: no destination specified." >&2 exit 1 fi dst=$dst_arg # Protect names starting with `-'. case $dst in -*) dst=./$dst;; esac # If destination is a directory, append the input filename; won't work # if double slashes aren't ignored. if test -d "$dst"; then if test -n "$no_target_directory"; then echo "$0: $dst_arg: Is a directory" >&2 exit 1 fi dstdir=$dst dst=$dstdir/`basename "$src"` dstdir_status=0 else # Prefer dirname, but fall back on a substitute if dirname fails. dstdir=` (dirname "$dst") 2>/dev/null || expr X"$dst" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ X"$dst" : 'X\(//\)[^/]' \| \ X"$dst" : 'X\(//\)$' \| \ X"$dst" : 'X\(/\)' \| . 2>/dev/null || echo X"$dst" | sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ s//\1/ q } /^X\(\/\/\)[^/].*/{ s//\1/ q } /^X\(\/\/\)$/{ s//\1/ q } /^X\(\/\).*/{ s//\1/ q } s/.*/./; q' ` test -d "$dstdir" dstdir_status=$? fi fi obsolete_mkdir_used=false if test $dstdir_status != 0; then case $posix_mkdir in '') # Create intermediate dirs using mode 755 as modified by the umask. # This is like FreeBSD 'install' as of 1997-10-28. umask=`umask` case $stripcmd.$umask in # Optimize common cases. *[2367][2367]) mkdir_umask=$umask;; .*0[02][02] | .[02][02] | .[02]) mkdir_umask=22;; *[0-7]) mkdir_umask=`expr $umask + 22 \ - $umask % 100 % 40 + $umask % 20 \ - $umask % 10 % 4 + $umask % 2 `;; *) mkdir_umask=$umask,go-w;; esac # With -d, create the new directory with the user-specified mode. # Otherwise, rely on $mkdir_umask. if test -n "$dir_arg"; then mkdir_mode=-m$mode else mkdir_mode= fi posix_mkdir=false case $umask in *[123567][0-7][0-7]) # POSIX mkdir -p sets u+wx bits regardless of umask, which # is incompatible with FreeBSD 'install' when (umask & 300) != 0. ;; *) tmpdir=${TMPDIR-/tmp}/ins$RANDOM-$$ trap 'ret=$?; rmdir "$tmpdir/d" "$tmpdir" 2>/dev/null; exit $ret' 0 if (umask $mkdir_umask && exec $mkdirprog $mkdir_mode -p -- "$tmpdir/d") >/dev/null 2>&1 then if test -z "$dir_arg" || { # Check for POSIX incompatibilities with -m. # HP-UX 11.23 and IRIX 6.5 mkdir -m -p sets group- or # other-writeable bit of parent directory when it shouldn't. # FreeBSD 6.1 mkdir -m -p sets mode of existing directory. ls_ld_tmpdir=`ls -ld "$tmpdir"` case $ls_ld_tmpdir in d????-?r-*) different_mode=700;; d????-?--*) different_mode=755;; *) false;; esac && $mkdirprog -m$different_mode -p -- "$tmpdir" && { ls_ld_tmpdir_1=`ls -ld "$tmpdir"` test "$ls_ld_tmpdir" = "$ls_ld_tmpdir_1" } } then posix_mkdir=: fi rmdir "$tmpdir/d" "$tmpdir" else # Remove any dirs left behind by ancient mkdir implementations. rmdir ./$mkdir_mode ./-p ./-- 2>/dev/null fi trap '' 0;; esac;; esac if $posix_mkdir && ( umask $mkdir_umask && $doit_exec $mkdirprog $mkdir_mode -p -- "$dstdir" ) then : else # The umask is ridiculous, or mkdir does not conform to POSIX, # or it failed possibly due to a race condition. Create the # directory the slow way, step by step, checking for races as we go. case $dstdir in /*) prefix='/';; -*) prefix='./';; *) prefix='';; esac eval "$initialize_posix_glob" oIFS=$IFS IFS=/ $posix_glob set -f set fnord $dstdir shift $posix_glob set +f IFS=$oIFS prefixes= for d do test -z "$d" && continue prefix=$prefix$d if test -d "$prefix"; then prefixes= else if $posix_mkdir; then (umask=$mkdir_umask && $doit_exec $mkdirprog $mkdir_mode -p -- "$dstdir") && break # Don't fail if two instances are running concurrently. test -d "$prefix" || exit 1 else case $prefix in *\'*) qprefix=`echo "$prefix" | sed "s/'/'\\\\\\\\''/g"`;; *) qprefix=$prefix;; esac prefixes="$prefixes '$qprefix'" fi fi prefix=$prefix/ done if test -n "$prefixes"; then # Don't fail if two instances are running concurrently. (umask $mkdir_umask && eval "\$doit_exec \$mkdirprog $prefixes") || test -d "$dstdir" || exit 1 obsolete_mkdir_used=true fi fi fi if test -n "$dir_arg"; then { test -z "$chowncmd" || $doit $chowncmd "$dst"; } && { test -z "$chgrpcmd" || $doit $chgrpcmd "$dst"; } && { test "$obsolete_mkdir_used$chowncmd$chgrpcmd" = false || test -z "$chmodcmd" || $doit $chmodcmd $mode "$dst"; } || exit 1 else # Make a couple of temp file names in the proper directory. dsttmp=$dstdir/_inst.$$_ rmtmp=$dstdir/_rm.$$_ # Trap to clean up those temp files at exit. trap 'ret=$?; rm -f "$dsttmp" "$rmtmp" && exit $ret' 0 # Copy the file name to the temp name. (umask $cp_umask && $doit_exec $cpprog "$src" "$dsttmp") && # and set any options; do chmod last to preserve setuid bits. # # If any of these fail, we abort the whole thing. If we want to # ignore errors from any of these, just make sure not to ignore # errors from the above "$doit $cpprog $src $dsttmp" command. # { test -z "$chowncmd" || $doit $chowncmd "$dsttmp"; } && { test -z "$chgrpcmd" || $doit $chgrpcmd "$dsttmp"; } && { test -z "$stripcmd" || $doit $stripcmd "$dsttmp"; } && { test -z "$chmodcmd" || $doit $chmodcmd $mode "$dsttmp"; } && # If -C, don't bother to copy if it wouldn't change the file. if $copy_on_change && old=`LC_ALL=C ls -dlL "$dst" 2>/dev/null` && new=`LC_ALL=C ls -dlL "$dsttmp" 2>/dev/null` && eval "$initialize_posix_glob" && $posix_glob set -f && set X $old && old=:$2:$4:$5:$6 && set X $new && new=:$2:$4:$5:$6 && $posix_glob set +f && test "$old" = "$new" && $cmpprog "$dst" "$dsttmp" >/dev/null 2>&1 then rm -f "$dsttmp" else # Rename the file to the real destination. $doit $mvcmd -f "$dsttmp" "$dst" 2>/dev/null || # The rename failed, perhaps because mv can't rename something else # to itself, or perhaps because mv is so ancient that it does not # support -f. { # Now remove or move aside any old file at destination location. # We try this two ways since rm can't unlink itself on some # systems and the destination file might be busy for other # reasons. In this case, the final cleanup might fail but the new # file should still install successfully. { test ! -f "$dst" || $doit $rmcmd -f "$dst" 2>/dev/null || { $doit $mvcmd -f "$dst" "$rmtmp" 2>/dev/null && { $doit $rmcmd -f "$rmtmp" 2>/dev/null; :; } } || { echo "$0: cannot unlink or rename $dst" >&2 (exit 1); exit 1 } } && # Now rename the file to the real destination. $doit $mvcmd "$dsttmp" "$dst" } fi || exit 1 trap '' 0 fi done # Local variables: # eval: (add-hook 'write-file-hooks 'time-stamp) # time-stamp-start: "scriptversion=" # time-stamp-format: "%:y-%02m-%02d.%02H" # time-stamp-end: "$" # End: algol68g-2.4.1/README0000644000175000001440000000267011771611166010752 00000000000000ALGOL68G - ALGOL 68 GENIE Algol68G is an implementation of Algol 68 as defined by the Revised Report. It ranks among the most complete implementations of the language. Algol68G is free software, you can redistribute it and/or modify it under the terms of the GNU General Public License. This software is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. The author of this software does not accept responsibility to anyone for the consequences of using it or for whether it serves any particular purpose or works at all. See the GNU General Public License for more details. The GNU General Public License does not permit this software to be redistributed in proprietary programs. Author of Algol68G is Marcel van der Veer . Web pages for Algol68G are at . Documentation is available from the web pages for Algol68G. INSTALLATION 1) WIN32 BINARY PACKAGE Unpack the distribution and start command shell cmd.exe. From this shell, enter algol68g-VERSION's directory and start a68g.exe. 2) LINUX, UNIX, BSD, MACOS X Please refer to file INSTALL or the manual for detailed instructions. Since Algol 68 Genie complies with the GNU build system, a reasonably experienced user can execute: tar -xzvf algol68g-VERSION.tgz cd algol68g-VERSION ./configure make make check [su] make install algol68g-2.4.1/check/0000777000175000001440000000000011771660256011232 500000000000000algol68g-2.4.1/check/check-03.a680000644000175000001440000000764511767446573013010 00000000000000COMMENT Example input for this nano-LISP interpreter 1 b 3 d evaluate append (+ 1 2) (a b) (+ 1 2) * 2 (+ 1 (^ 2 3)) quit COMMENT PR echo "[3] Nano-LISP interpreter" PR # Data structure to represent a list # MODE VALUE = UNION (ATOM, LIST), ATOM = STRING, LIST = REF NODE, NODE = STRUCT (VALUE head, tail); LIST no list = NIL; OP NOLIST = (VALUE v) BOOL: (v | (LIST l): l IS no list | FALSE); OP HEAD = (VALUE v) VALUE: (v | (LIST l): (NOLIST l | no list | head OF l) | no list); OP TAIL = (VALUE v) VALUE: (v | (LIST l): (NOLIST l | no list | tail OF l) | no list); OP NUMBER = (VALUE v) INT: CASE v IN (ATOM a): BEGIN # use transput library for conversion # FILE g, INT n; associate (g, NEW ATOM := a); get (g, n); close (g); n END, (LIST l): (NOLIST l | SKIP | NUMBER HEAD l) ESAC; OP NUMBER = (INT n) ATOM: whole (n, 0); OP CONS = (VALUE v, w) VALUE: NEW NODE := (v, w); PRIO CONS = 9; OP + = (VALUE v, w) VALUE: CASE v IN (ATOM a): v CONS (w | (ATOM): w, (LIST): HEAD w), (LIST k): IF NOLIST k THEN w ELSE HEAD k CONS IF NOLIST TAIL k THEN (w | (ATOM): w, (LIST): HEAD w) ELSE TAIL k + w FI FI ESAC; PROC print value = (VALUE v) VOID: CASE v IN (ATOM a): print (a), (LIST l): IF NOLIST l THEN print ("nil") ELSE PROC print list = (LIST l) VOID: CASE print value (HEAD l); TAIL l IN (ATOM a): (print (blank); print value (a)), (LIST k): (~ NOLIST k | print (blank); print list (k)) ESAC; print ("("); print list (l); print (")") FI ESAC; OP EVAL = (VALUE v) VALUE: CASE v IN (ATOM a): a, (LIST k): IF NOLIST k THEN no list ELSE CASE HEAD k IN (ATOM a): interpreter (a, TAIL k), (LIST l): EVAL HEAD k CONS EVAL TAIL k ESAC FI ESAC; PROC interpreter = (ATOM cmd, VALUE arg) VALUE: IF BOOL found := FALSE, VALUE v; [] STRUCT (STRING cmd, PROC (VALUE) VALUE action) table = (("'", (VALUE arg) VALUE: HEAD arg), ("+", (VALUE arg) VALUE: NUMBER (NUMBER EVAL HEAD arg + NUMBER EVAL TAIL arg)), ("-", (VALUE arg) VALUE: NUMBER (NUMBER EVAL HEAD arg - NUMBER EVAL TAIL arg)), ("*", (VALUE arg) VALUE: NUMBER (NUMBER EVAL HEAD arg * NUMBER EVAL TAIL arg)), ("/", (VALUE arg) VALUE: NUMBER (NUMBER EVAL HEAD arg OVER NUMBER EVAL TAIL arg)), ("^", (VALUE arg) VALUE: NUMBER (NUMBER EVAL HEAD arg ** NUMBER EVAL TAIL arg)), ("append", (VALUE arg) VALUE: EVAL HEAD arg + EVAL TAIL arg), ("evaluate", (VALUE arg) VALUE: EVAL arg), ("quit", (VALUE arg) VALUE: stop) ); FOR k TO UPB table WHILE ~found DO (found := cmd = cmd OF table[k] | v := (action OF table[k]) (arg)) OD; found THEN v ELSE cmd CONS arg FI; # Driver program executes commands at top of file # FILE f; VOID (open (f, program idf, standin channel)); get (f, new line); DO STRING s, INT i; get (f, (s, new line)); i := LWB s; PROC to rpn = VALUE: IF WHILE i <= UPB s THEF is space (s[i]) DO i +:= 1 OD; i > UPB s THEN no list ELIF s[i] = ")" THEN i +:= 1; no list ELIF s[i] = "(" THEN i +:= 1; VALUE lhs := to rpn; VALUE rhs := to rpn; lhs CONS rhs ELSE STRING arg := s[i]; i +:= 1; WHILE i <= UPB s THEF is alnum (s[i]) DO arg +:= s[i]; i +:= 1 OD; VALUE lhs := NEW VALUE := arg; VALUE rhs := to rpn; lhs CONS rhs FI; VALUE l := to rpn; print value (l); new line (stand out); print value (EVAL l); new line (stand out) OD algol68g-2.4.1/check/check-08.a680000644000175000001440000000061011755213124012753 00000000000000# Test deep recursion using the Ackermann function # PR echo "[8] Ackermann function" PR PROC ack = (INT m, n) INT: IF m = 0 THEN n + 1 ELSE (n = 0 | ack(m - 1, 1) | ack(m - 1, ack(m, n - 1))) FI; FOR i TO 3 DO FOR j TO i DO print(("A(", whole(i, 0), ", ", whole(j, 0), ") = ", whole(ack(i, j), 0), new line)) OD OD; SKIP algol68g-2.4.1/check/check-07.a680000644000175000001440000000272011755213124012756 00000000000000PR echo "[7] Hamming numbers" precision=100 storage=16 PR MODE SERIES = FLEX [1 : 0] UNT, # Initially, no elements # UNT = LONG LONG INT; # A 100-digit unsigned integer # OP LAST = (SERIES h) UNT: h[UPB h]; # Last element of a series # 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 SERIES h := 1, # Series, initally one element # UNT m2 := 2, m3 := 3, m5 := 5, # Multipliers # INT i := 1, j := 1, k := 1; # Counters # TO n - 1 DO OP MIN = (INT i, j) INT: (i < j | i | j), MIN = (UNT i, j) UNT: (i < j | i | j); PRIO MIN = 9; 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; 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 # 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 TO 20 DO print ((whole (hamming number (k), 0), newline)); preemptive sweep heap OD; print (whole (hamming number (1 691), 0)) algol68g-2.4.1/check/check-06.a680000644000175000001440000001035011755213124012753 00000000000000PR echo "(6) Exact determinant of Hilbert matrices using fractions" PR BEGIN # Fraction data structure and denotation through the "DIV" operator. A fraction has positive denominator; the nominator holds the sign. # MODE FRAC = STRUCT (NUM nom, den), NUM = LONG LONG INT; OP N = (FRAC u) NUM: nom OF u, D = (FRAC u) NUM: den OF u; PR precision=101 PR # NUM can hold a googol! # FRAC zero = 0 DIV 1, one = 1 DIV 1; OP DIV = (NUM n, d) FRAC: IF d = 0 THEN print ("Zero denominator"); stop ELSE NUM gcd = ABS n GCD ABS d; (SIGN n * SIGN d * ABS n OVER gcd, ABS d OVER gcd) FI; OP DIV = (INT n, d) FRAC: NUM (n) DIV NUM (d); PRIO DIV = 2; OP GCD = (NUM a, b) NUM: IF b = 0 THEN ABS a ELSE b GCD (a MOD b) FI; PRIO GCD = 8; # Basic operators for fractions. # OP - = (FRAC u) FRAC: - N u DIV D u; OP + = (FRAC u, v) FRAC: N u * D v + N v * D u DIV D u * D v; OP - = (FRAC u, v) FRAC: u + - v; OP * = (FRAC u, v) FRAC: N u * N v DIV D u * D v; OP / = (FRAC u, v) FRAC: u * (D v DIV N v); OP +:= = (REF FRAC u, FRAC v) REF FRAC: u := u + v; OP -:= = (REF FRAC u, FRAC v) REF FRAC: u := u - v; OP *:= = (REF FRAC u, FRAC v) REF FRAC: u := u * v; OP /:= = (REF FRAC u, FRAC v) REF FRAC: u := u / v; OP = = (FRAC u, v) BOOL: N u = N v ANDF D u = D v; OP /= = (FRAC u, v) BOOL: NOT (u = v); # Matrix algebra. # OP INNER = (() FRAC u, v) FRAC: # Innerproduct of two arrays of rationals # BEGIN FRAC s := zero; 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 := zero, 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 = zero ANDF aik(i) /= zero THEN piv := aik(i); pk := i FI OD; IF piv = zero THEN print((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 := one; FOR i TO 1 UPB a DO d *:= a(i, i) OD; d END; # Table of required results. # () NUM table = BEGIN 1, 12, 2 160, 6 048 000, 266 716 800 000, 186 313 420 339 200 000, 2 067 909 047 925 770 649 600 000, 365 356 847 125 734 485 878 112 256 000 000, 1 028 781 784 378 569 697 887 052 962 909 388 800 000 000, 46 206 893 947 914 691 316 295 628 839 036 278 726 983 680 000 000 000 END; # Compute determinant of Hilbert matrix of increasing rank. # FOR n TO UPB table DO (1 : n, 1 : n) FRAC a; FOR i TO n DO a(i, i) := 1 DIV 2 * i - 1; FOR j FROM i + 1 TO n DO a(i, j) := a(j, i) := 1 DIV i + j - 1 OD OD; lu decomposition(a, LOC (1 : n) INT); FRAC det = determinant (a); print(("Rank ", whole (n, -2), ", determinant ", whole (N det, 0), " / ", whole (D det, 0), (N det = 1 AND D det = table(n) | ", ok" | ", not ok" ), newline)) OD END algol68g-2.4.1/check/check-04.a680000644000175000001440000000130411755213125012751 00000000000000PR echo "[4] Recursive back-tracking algorithm" PR # How many ways are there to split 10 euros in 2 euro, 1 euro, 50 ct, 20 ct, 10 ct, 5 ct? # 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 values = (5, 10, 20, 50, 100, 200), INT amount = 1000 # cents #; printf (($"There are"xg(0)x"ways to split",xg(0)x"cents in", n(UPB (values)) (xg(0))x"cent coins"$, count (amount, amount), amount, values)) algol68g-2.4.1/check/check-05.a680000644000175000001440000000460511755213125012761 00000000000000COMMENT Input for this program rectangle no square does it have four sides of equal length yes yes no no cube does it have three dimensions yes no COMMENT PR echo "[5] Building a decision-tree" PR # This is a classic example for building a decision tree in Algol 68. We wrote programs like this for ALGOL68C/TOPS-20 in the eighties - MvdV. # BEGIN FILE input; VOID (open (input, program idf, standin channel)); # read self # get (input, new line); # skip COMMENT line # OBJECTS library := get reply("Please name an object"); WHILE print(("I will guess the object you are thinking of", new line)); guess object(library); ask("Another round") DO # Q&A # SKIP OD; PROC guess object = (REF OBJECTS object) VOID: # How to guess an object # CASE object IN (STRING s): (ask(s) | SKIP | object := learn(s)), (FORK d): guess object((ask(TEXT d) | HAS d | HASNT d)) ESAC; PROC learn = (STRING guess) OBJECTS: # How to improve on a guess # IF STRING object = get reply("What was the object?"), question = get reply("Give a question to distinguish '" + object + "'"); ask("Does '" + question + "' apply to '" + object + "'") THEN new fork(question, object, guess) ELSE new fork(question, guess, object) FI; PROC get reply = (STRING prompt) STRING: BEGIN STRING s; print((prompt, new line)); get(input, (s, new line)); print (("'", s, "'", new line)); s END; PROC ask = (STRING question) BOOL: IF STRING s = get reply (question + "?"); UPB s > 0 THEN s[1] = "y" ORF s[1] = "Y" ELSE ask (question) FI; OP TEXT = (FORK d) STRING: text OF d, # Access operators to "hide" the data structure # HAS = (FORK d) REF OBJECTS: has OF d, HASNT = (FORK d) REF OBJECTS: hasnt OF d; MODE OBJECTS = UNION(STRING, FORK), # The data structure # FORK = STRUCT(STRING text, REF OBJECTS has, hasnt); PROC new fork = (STRING text, OBJECTS has, hasnt) FORK: (HEAP STRING := text, HEAP OBJECTS := has, HEAP OBJECTS := hasnt); SKIP # since a clause can not end in a declaration # END algol68g-2.4.1/check/check-10.a680000644000175000001440000000444311771422123012753 00000000000000PR echo "[10] 'Mastermind' code breaker" 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; # The code that this program will crack: # COMBINATION code := (4, 3, 6, 5); OP +:= = (REF LIST u, COMBINATION v) REF LIST: # Add one combination to a list. # (sweep heap; [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); INT len = UPB (whole (UPB all combs, 0)); PROC rate = (COMBINATION ref, guess, REF INT pos ok, col ok) VOID: (col ok := pos ok := 0; FOR u TO pegs DO FOR v TO pegs DO IF ref[u] = guess[v] THEN (u = v | pos ok | col ok) +:= 1 FI OD OD); PROC end = (COMBINATION win) VOID: BEGIN printf (($l"solution is "n(pegs)(d)$, win)); printf (($lg(0)" collections"$, collections)); stop END; PROC break code = (REF LIST sieved) VOID: # Present a trial and sieve the list with the score. # CASE UPB sieved + 1 IN printf ($"Inconsistent scores"$), end (sieved[1]) OUT printf (($l"guess out of "g(-len)" candidates is"xn(pegs)(d)$, UPB sieved, sieved[1])); INT col ok := 0, pos ok := 0; rate (code, sieved[1], pos ok, col ok); printf (($" rating: ", n(pos ok)"B", n(col ok)"W" $)); (pos ok = pegs | end (sieved[1])); # Survivors are combinations with score as rated. # LIST survivors; FOR i FROM 2 TO UPB sieved DO INT col ok i, pos ok i; rate (sieved[1], sieved[i], pos ok i, col ok i); (col ok = col ok i AND pos ok = pos ok i | survivors +:= sieved[i]) OD; break code (survivors) ESAC; break code (all combs) algol68g-2.4.1/check/check-01.a680000644000175000001440000000357111755213177012765 00000000000000PR echo "[1] Peano curve using Van Wijngaarden's algorithm" PR PROC go 1 = (INT n) VOID: IF n ~= 0 THEN go 2 (n - 1); plot (x + d, y); go 1 (n - 1); plot (x, y + d); go 1 (n - 1); plot (x - d, y); go 4 (n - 1) FI; PROC go 2 = (INT n) VOID: IF n~= 0 THEN go 1 (n - 1); plot (x, y + d); go 2 (n - 1); plot (x + d, y); go 2 (n - 1); plot (x, y - d); go 3 (n - 1) FI; PROC go 3 = (INT n) VOID: IF n~= 0 THEN go 4 (n - 1); plot (x - d, y); go 3 (n - 1); plot (x, y - d); go 3 (n - 1); plot (x + d, y); go 2 (n - 1) FI; PROC go 4 = (INT n) VOID: IF n~= 0 THEN go 3 (n - 1); plot (x, y - d); go 4 (n - 1); plot (x - d, y); go 4 (n - 1); plot (x, y + d); go 1 (n - 1) FI; PROC plot = (REAL x n, y n) VOID: BEGIN INT j x = 1 + ENTIER (x * (n x - 1)), j y = 1 + ENTIER (y * (n y - 1)), k x = 1 + ENTIER (x n * (n x - 1)), k y = 1 + ENTIER (y n * (n y - 1)); IF j x = k x THEN INT m = (j y < k y | j y | k y), n = (j y > k y | j y | k y); FOR l FROM m TO n DO p [k x, l] := "." OD ELSE INT m = (j x < k x | j x | k x), n = (j x > k x | j x | k x); FOR l FROM m TO n DO p [l, k y] := "." OD FI; x := x n; y := y n END; INT n x = 60, n y = 35; [1 : n x, 1 : n y] CHAR p; FOR i TO n x DO FOR j TO n y DO p [i, j] := " " OD OD; INT n = 4; REAL d = 2.0 ** (- n); REAL x := d / 2, y := d / 2; go 1 (n); FOR i TO n y DO FOR j TO n x DO print (p [j, i]) OD; print (new line) OD algol68g-2.4.1/check/check-02.a680000644000175000001440000000161411755213177012762 00000000000000CO Lucas-Lehmer Test: For p an odd prime, the Mersenne number 2**p-1 is prime if and only if 2**p-1 divides S(p-1) where S(n+1) = S(n)**2-2, and S(1)=4. CO PR echo "[2] Mersenne primes by the Lucas-Lehmer test" precision=600 timelimit=60 PR # Theorem: If 2**p-1 is prime, then so is p. Preprocess by sieving prime exponents first. # INT max = 1000, [max] BOOL prime; FOR k TO max DO prime[k] := TRUE OD; FOR mult FROM 2 TO ENTIER sqrt (max) DO INT k := 2 * mult; WHILE k < max DO prime[k] := FALSE; k +:= mult OD OD; # Now determine Mersenne primes using Lucas-Lehmer test # FOR k FROM 2 TO max DO IF prime[k] THEN IF 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; s = 0 THEN printf (($l"M_"g(0)" has "g(0)" digits"$, k, ENTIER (1 + long long log (cand)))) FI FI OD algol68g-2.4.1/check/check-09.a680000644000175000001440000000543511755213177012776 00000000000000PR echo "[9] Synthetic benchmark after Curnow & Wichmann" PR # After HJ Curnow and BA Wichmann, Computer Journal 19(1) 43 [1976] Free versions for other languages are available on the i-net. # [1 : 4] REAL e1, REAL x1, x2, x3, x4, x, y, z, INT j, k, l; 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; # weight = 10 means 1e6 whetstone instructions per loop # INT weight = 100, duration = 5, INT cycles := 0; INT n2 = 12 * weight, n3 = 14 * weight, n4 = 345 * weight, n6 = 210 * weight, n7 = 32 * weight, n8 = 899 * weight, n9 = 616 * weight, n11 = 93 * weight; REAL t = 0.499975, t1 = 0.50025, t2 = 2.0, cpu1 = seconds; WHILE (seconds - cpu1) < duration DO cycles +:= 1; # 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 10. Zero frequency # # MODULE 11. Standard functions # x := 0.75; TO n11 DO x := sqrt(exp(ln(x) / t1)) OD OD; REAL time = (seconds - cpu1) / cycles; printf (($x3z-d.d" MWhets"$, 1 / (time / (weight / 10)))) algol68g-2.4.1/INSTALL0000644000175000001440000002245011551405127011113 00000000000000Installation Instructions ************************* Copyright (C) 1994, 1995, 1996, 1999, 2000, 2001, 2002, 2004, 2005, 2006, 2007 Free Software Foundation, Inc. This file is free documentation; the Free Software Foundation gives unlimited permission to copy, distribute and modify it. Basic Installation ================== Briefly, the shell commands `./configure; make; make install' should configure, build, and install this package. The following more-detailed instructions are generic; see the `README' file for instructions specific to this package. The `configure' shell script attempts to guess correct values for various system-dependent variables used during compilation. It uses those values to create a `Makefile' in each directory of the package. It may also create one or more `.h' files containing system-dependent definitions. Finally, it creates a shell script `config.status' that you can run in the future to recreate the current configuration, and a file `config.log' containing compiler output (useful mainly for debugging `configure'). It can also use an optional file (typically called `config.cache' and enabled with `--cache-file=config.cache' or simply `-C') that saves the results of its tests to speed up reconfiguring. Caching is disabled by default to prevent problems with accidental use of stale cache files. If you need to do unusual things to compile the package, please try to figure out how `configure' could check whether to do them, and mail diffs or instructions to the address given in the `README' so they can be considered for the next release. If you are using the cache, and at some point `config.cache' contains results you don't want to keep, you may remove or edit it. The file `configure.ac' (or `configure.in') is used to create `configure' by a program called `autoconf'. You need `configure.ac' if you want to change it or regenerate `configure' using a newer version of `autoconf'. The simplest way to compile this package is: 1. `cd' to the directory containing the package's source code and type `./configure' to configure the package for your system. Running `configure' might take a while. While running, it prints some messages telling which features it is checking for. 2. Type `make' to compile the package. 3. Optionally, type `make check' to run any self-tests that come with the package. 4. Type `make install' to install the programs and any data files and documentation. 5. You can remove the program binaries and object files from the source code directory by typing `make clean'. To also remove the files that `configure' created (so you can compile the package for a different kind of computer), type `make distclean'. There is also a `make maintainer-clean' target, but that is intended mainly for the package's developers. If you use it, you may have to get all sorts of other programs in order to regenerate files that came with the distribution. 6. Often, you can also type `make uninstall' to remove the installed files again. Compilers and Options ===================== Some systems require unusual options for compilation or linking that the `configure' script does not know about. Run `./configure --help' for details on some of the pertinent environment variables. You can give `configure' initial values for configuration parameters by setting variables in the command line or in the environment. Here is an example: ./configure CC=c99 CFLAGS=-g LIBS=-lposix *Note Defining Variables::, for more details. Compiling For Multiple Architectures ==================================== You can compile the package for more than one kind of computer at the same time, by placing the object files for each architecture in their own directory. To do this, you can use GNU `make'. `cd' to the directory where you want the object files and executables to go and run the `configure' script. `configure' automatically checks for the source code in the directory that `configure' is in and in `..'. With a non-GNU `make', it is safer to compile the package for one architecture at a time in the source code directory. After you have installed the package for one architecture, use `make distclean' before reconfiguring for another architecture. Installation Names ================== By default, `make install' installs the package's commands under `/usr/local/bin', include files under `/usr/local/include', etc. You can specify an installation prefix other than `/usr/local' by giving `configure' the option `--prefix=PREFIX'. You can specify separate installation prefixes for architecture-specific files and architecture-independent files. If you pass the option `--exec-prefix=PREFIX' to `configure', the package uses PREFIX as the prefix for installing programs and libraries. Documentation and other data files still use the regular prefix. In addition, if you use an unusual directory layout you can give options like `--bindir=DIR' to specify different values for particular kinds of files. Run `configure --help' for a list of the directories you can set and what kinds of files go in them. If the package supports it, you can cause programs to be installed with an extra prefix or suffix on their names by giving `configure' the option `--program-prefix=PREFIX' or `--program-suffix=SUFFIX'. Optional Features ================= Some packages pay attention to `--enable-FEATURE' options to `configure', where FEATURE indicates an optional part of the package. They may also pay attention to `--with-PACKAGE' options, where PACKAGE is something like `gnu-as' or `x' (for the X Window System). The `README' should mention any `--enable-' and `--with-' options that the package recognizes. For packages that use the X Window System, `configure' can usually find the X include and library files automatically, but if it doesn't, you can use the `configure' options `--x-includes=DIR' and `--x-libraries=DIR' to specify their locations. Specifying the System Type ========================== There may be some features `configure' cannot figure out automatically, but needs to determine by the type of machine the package will run on. Usually, assuming the package is built to be run on the _same_ architectures, `configure' can figure that out, but if it prints a message saying it cannot guess the machine type, give it the `--build=TYPE' option. TYPE can either be a short name for the system type, such as `sun4', or a canonical name which has the form: CPU-COMPANY-SYSTEM where SYSTEM can have one of these forms: OS KERNEL-OS See the file `config.sub' for the possible values of each field. If `config.sub' isn't included in this package, then this package doesn't need to know the machine type. If you are _building_ compiler tools for cross-compiling, you should use the option `--target=TYPE' to select the type of system they will produce code for. If you want to _use_ a cross compiler, that generates code for a platform different from the build platform, you should specify the "host" platform (i.e., that on which the generated programs will eventually be run) with `--host=TYPE'. Sharing Defaults ================ If you want to set default values for `configure' scripts to share, you can create a site shell script called `config.site' that gives default values for variables like `CC', `cache_file', and `prefix'. `configure' looks for `PREFIX/share/config.site' if it exists, then `PREFIX/etc/config.site' if it exists. Or, you can set the `CONFIG_SITE' environment variable to the location of the site script. A warning: not all `configure' scripts look for a site script. Defining Variables ================== Variables not defined in a site shell script can be set in the environment passed to `configure'. However, some packages may run configure again during the build, and the customized values of these variables may be lost. In order to avoid this problem, you should set them in the `configure' command line, using `VAR=value'. For example: ./configure CC=/usr/local2/bin/gcc causes the specified `gcc' to be used as the C compiler (unless it is overridden in the site shell script). Unfortunately, this technique does not work for `CONFIG_SHELL' due to an Autoconf bug. Until the bug is fixed you can use this workaround: CONFIG_SHELL=/bin/bash /bin/bash ./configure CONFIG_SHELL=/bin/bash `configure' Invocation ====================== `configure' recognizes the following options to control how it operates. `--help' `-h' Print a summary of the options to `configure', and exit. `--version' `-V' Print the version of Autoconf used to generate the `configure' script, and exit. `--cache-file=FILE' Enable the cache: use and save the results of the tests in FILE, traditionally `config.cache'. FILE defaults to `/dev/null' to disable caching. `--config-cache' `-C' Alias for `--cache-file=config.cache'. `--quiet' `--silent' `-q' Do not print messages saying which checks are being made. To suppress all normal output, redirect it to `/dev/null' (any error messages will still be shown). `--srcdir=DIR' Look for the package's source code in directory DIR. Usually `configure' can determine that directory automatically. `configure' also accepts some other, not widely useful, options. Run `configure --help' for more details. algol68g-2.4.1/NEWS0000644000175000001440000002154511771420531010565 00000000000000Version 2.4.1, June 2012 * Fixes issue in transput library. * Fixes issue in garbage collector. * Documentation updates. * Better distribution lay-out. Version 2.4, June 2012 * Adds pretty-printer. * Simplified garbage collector. * Adds procedure "read line" (calls GNU readline). * Adds procedure "on gc event". * Adds option --storage [=] n. * Fixes error in option --handles. * Removed the field-selector extension. Version 2.3.9, April 2012 * Fixes curses build issue. * Documentation updates. Version 2.3.8, April 2012 * Fixes build issues on Solaris and Cygwin. * Adds procedures "rows" and "columns". * Documentation updates. Version 2.3.7, February 2012 * Fixes build issue occuring on some platforms. Version 2.3.6, February 2012 * Source code maintenance. * Documentation updates. Version 2.3.5, December 2011 * Fixes issues in 2.3.4. * Source code maintenance. * Documentation updates. Version 2.3.4, November 2011 * Fixes issues in 2.3.3. * Source code maintenance. * Documentation updates. Version 2.3.3, October 2011 * Adds code clause. * Fixes issues in 2.3.2. * Source code maintenance. * Documentation updates. Version 2.3.2, October 2011 * Fixes issues in 2.3.1. * Source code maintenance. * Documentation updates. Version 2.3.1, September 2011 * Adds building on NetBSD. * Fixes minor issues in 2.3.0. * Lint-free source code. Version 2.3.0, September 2011 * Implements ghost elements for empty rows. * Implements non-local environs. * Fixes issues in 2.2.0. * Updates documentation. Version 2.2.0, July 2011 * Improves the parser. * Improves handling of unclosed files. * Adds compilation of uniting. * Adds routine grep in substring. * Fixes minor issues in 2.1.2. * Updates documentation. Version 2.1.2, January 2011 * Updates documentation. * Fixes reported problem in version 2.1.1. Version 2.1.1, January 2011 * Adds configuration options to configure script. * Updates the documentation. * Fixes reported problems in version 2.1.0. * Improves error messages for options to a68g. Version 2.1.0, January 2011 * Upgrades to the GNU build system using autoconf and automake. * Updates the memory management system. * Adds compilation of basic integer-case-clauses. * Adds compilation of LONG INT and LONG REAL units. * Adds optimisation options -O0, -O1, -O2 and -O3. * Adds option --clock. * Fixes reported problems in version 2.0.3. Version 2.0.3, November 2010 * Adds compilation of basic loops; complex loops are interpreted. * Fixes reported build problem on platforms without the GNU Scientific Library. Version 2.0.2, November 2010 * Adds option --script. * Adds Algol 68 comment syntax for shell interpreter call. * Updates documentation. * Regression fixes: 1. A buffering problem could occur when using routines --set or --backspace 2. Some minor errors in the compiler Version 2.0.1, September 2010 * Fix minor inconsistencies between source code and documentation. Version 2.0.0, September 2010 * Adds compiler for units to speed execution. * Adds options --optimise and --no-optimise. * Adds options --compile and --no-compile. * Adds options --object and --no-object. * Adds option --strict. * Improves parser. * Improves diagnostics. * Updates documentation. * Regression fixes: 1. Zero-suppression sometimes failed in formatted transput. 2. The default draw fill style was 1, not 0 as stated in the manual. Version 1.18.0, August 2009 * Regression fixes: 1. Rowing failed for some flexible rows. 2. Generator failed for some structures. 3. Garbage collector could crash under rare circumstances. 4. Some flexible mode declarations were not accepted. 5. Some modes were incorrectly marked as equivalent. 6. Unnecessary size limitations in some matrix operations. 7. Build error on Mac OS X. 8. Alignment error on AMD64. * Adds field-selections as an alternative to selections. * Adds NEW as alternative to HEAP. * More efficient use of memory during compilation. * Documentation updates. * Upon request, re-post the HTML translation of the Revised Report. * Change to a common Linux-style version numbering (former Mark j will now read Version 1.j.0, and former Mark j.k will now read Version 1.j.k) Version 1.17.0, May 2009 * Adds C-style placeholders in formats. * Adds warnings when tags hide declarations with larger reach. * Regression fixes: 1. The while-part range was not visible from deeper ranges in case a loop-clause was the sole unit of a routine-text. 2. SKIP did not generate a value for some modes. * Lint-free source code. * Documentation updates. Version 1.16.0, April 2009 * Regression fixes. * Documentation updates: 1. Adds Revised Report to the LaTeX documentation. 2. Discontinues HTML translation of the Revised Report. Version 1.15.1, January 2009 * Adds Laplace transform. * Regression fixes and documentation updates. Version 1.15.0, December 2008 * Regression fixes and documentation updates. * Improves diagnostics. Version 1.14.1, November 2008 * Implements zero replicators as required by the Revised Report. * Decommissions (undocumented) VMS option syntax. Version 1.14.0, October 2008 * Adds first edition of the Algol 68 Genie User Manual. * Adds Revised Report (HTML translation 1.2) to the documentation. * Adds option --link to the monitor. Version 1.13.0, June 2008 * Adds procedures to interrogate files and directories. * Adds various operators and procedures. * Adds --apropos to command line options and monitor options. Version 1.12.0, May 2008 * Improves code for the parallel clause. * Improves interpreter efficiency. * Improves breakpoint commands in the monitor. * Adds options UNTIL, FINISH and OUT to the monitor. * Adds Revised Report (HTML translation 1.1) to the documentation. Version 1.11.1, March 2008 * Adds options RERUN, RESET and RESTART to monitor. * Adds Revised Report (HTML translation 1.0) to the documentation. Version 1.11.0, November 2007 * Adds support for sound. * Adds Fourier transforms. * Adds pseudo operator DIAG. * Adds pseudo operator TRNSP. * Adds pseudo operator COL. * Adds pseudo operator ROW. * Improves diagnostics in formatted transput. * Improves monitor. Version 1.10.2, April 2007 * Adds procedure "real". * Adds format pattern 'h'. * Adds operator OP SET = (INT, L BITS) L BITS. * Adds operator OP CLEAR = (INT, L BITS) L BITS. Version 1.10.1, December 2006 * Improves interpreter efficiency. Version 1.10.0, August 2006 * Adds basic linear algebra. * Adds procedures "arctan2", "long arctan2" and "long long arctan2". * Adds procedure "execve output". * Improves diagnostics. * Adds option --no-backtrace. Version 1.9.2, July 2006 * Adds typographical display features. Version 1.9.1, May 2006 * 64-bit safe interpreter. * Improves monitor/debugger. * Adds option --monitor (or --debug). * Adds procedure "monitor". Version 1.9.0, March 2006 * Adds basic PostgreSQL support. * Adds procedure "utc time" (UNIX). * Adds procedure "local time" (UNIX). * Improves diagnostic messages. Version 1.8.1, November 2005 * Adds procedure "sub in string" (UNIX). * Adds option --portcheck cf. standard hardware representation. * Adds option --pedantic. Version 1.8.0, July 2005 * Adds procedure "http content" (UNIX). * Adds procedure "tcp request" (UNIX). * Adds procedure "grep in string" (UNIX). * Adds procedure "last char in string". * Adds procedure "string in string". * Adds keyword UNTIL to implement post checked loop. * Adds keyword DOWNTO to complement TO. * Adds keyword ANDTH as alternative for ANDF and keyword OREL as alternative for ORF. * Makes ~ a SKIP when used as a unit (cf. RR). Version 1.7.0, May 2005 * Adds partial parameterisation following C. H. Lindsey's proposal. * Adds elementary and trigonometric functions for complex numbers, independent of GSL. Version 1.6.0, March 2005 * Adds parallel clause on platforms that support POSIX threads. Version 1.5.0, October 2004 * Improves interpreter efficiency. * Adds transput on STRING as well as FILE and PIPE. * Adds dynamic scope checking. * Adds basic preprocessor. * Adds curses support. Version 1.4.0, June 2004 * Adds more GSL support. * Adds modes LONG BITS and LONG LONG BITS. * Makes parser accept ( .. ) as alternative for [ .. ]. * Makes parser optionally treat { .. }, [ .. ] and ( .. ) as equivalent. * Makes parser accept loop clause as encloses clause. * Makes mode checker accept UNION with components relates through deflexing. * Changes to thread safe plotutils interface. Version 1.3.2, March 2004 * Adds overflow checks for primitive modes. Version 1.3.1, January 2004 * Adds optional system stack overflow handling to interpreter. * Improves multiprecision library. Version 1.3.0, September 2003 * Adds formatted transput. * Improves speed of multiprecision library. Version 1.2.0, March 2003 * Adds mode BYTES and LONG BYTES. * Adds mode FORMAT and parsing of FORMAT texts. * Adds straightening in unformatted transput. * Adds mode PIPE and UNIX support. * Changes to UNIX system level IO. Version 1.1.0, November 2002 Version 1.0.0, September 2002 Beta releases from November 2001 onward. algol68g-2.4.1/COPYING0000644000175000001440000010451311551405127011116 00000000000000 GNU GENERAL PUBLIC LICENSE Version 3, 29 June 2007 Copyright (C) 2007 Free Software Foundation, Inc. Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. Preamble The GNU General Public License is a free, copyleft license for software and other kinds of works. The licenses for most software and other practical works are designed to take away your freedom to share and change the works. By contrast, the GNU General Public License is intended to guarantee your freedom to share and change all versions of a program--to make sure it remains free software for all its users. We, the Free Software Foundation, use the GNU General Public License for most of our software; it applies also to any other work released this way by its authors. You can apply it to your programs, too. When we speak of free software, we are referring to freedom, not price. Our General Public Licenses are designed to make sure that you have the freedom to distribute copies of free software (and charge for them if you wish), that you receive source code or can get it if you want it, that you can change the software or use pieces of it in new free programs, and that you know you can do these things. To protect your rights, we need to prevent others from denying you these rights or asking you to surrender the rights. Therefore, you have certain responsibilities if you distribute copies of the software, or if you modify it: responsibilities to respect the freedom of others. For example, if you distribute copies of such a program, whether gratis or for a fee, you must pass on to the recipients the same freedoms that you received. You must make sure that they, too, receive or can get the source code. And you must show them these terms so they know their rights. Developers that use the GNU GPL protect your rights with two steps: (1) assert copyright on the software, and (2) offer you this License giving you legal permission to copy, distribute and/or modify it. For the developers' and authors' protection, the GPL clearly explains that there is no warranty for this free software. For both users' and authors' sake, the GPL requires that modified versions be marked as changed, so that their problems will not be attributed erroneously to authors of previous versions. Some devices are designed to deny users access to install or run modified versions of the software inside them, although the manufacturer can do so. This is fundamentally incompatible with the aim of protecting users' freedom to change the software. The systematic pattern of such abuse occurs in the area of products for individuals to use, which is precisely where it is most unacceptable. Therefore, we have designed this version of the GPL to prohibit the practice for those products. If such problems arise substantially in other domains, we stand ready to extend this provision to those domains in future versions of the GPL, as needed to protect the freedom of users. Finally, every program is threatened constantly by software patents. States should not allow patents to restrict development and use of software on general-purpose computers, but in those that do, we wish to avoid the special danger that patents applied to a free program could make it effectively proprietary. To prevent this, the GPL assures that patents cannot be used to render the program non-free. The precise terms and conditions for copying, distribution and modification follow. TERMS AND CONDITIONS 0. Definitions. "This License" refers to version 3 of the GNU General Public License. "Copyright" also means copyright-like laws that apply to other kinds of works, such as semiconductor masks. "The Program" refers to any copyrightable work licensed under this License. Each licensee is addressed as "you". "Licensees" and "recipients" may be individuals or organizations. To "modify" a work means to copy from or adapt all or part of the work in a fashion requiring copyright permission, other than the making of an exact copy. The resulting work is called a "modified version" of the earlier work or a work "based on" the earlier work. A "covered work" means either the unmodified Program or a work based on the Program. To "propagate" a work means to do anything with it that, without permission, would make you directly or secondarily liable for infringement under applicable copyright law, except executing it on a computer or modifying a private copy. Propagation includes copying, distribution (with or without modification), making available to the public, and in some countries other activities as well. To "convey" a work means any kind of propagation that enables other parties to make or receive copies. Mere interaction with a user through a computer network, with no transfer of a copy, is not conveying. An interactive user interface displays "Appropriate Legal Notices" to the extent that it includes a convenient and prominently visible feature that (1) displays an appropriate copyright notice, and (2) tells the user that there is no warranty for the work (except to the extent that warranties are provided), that licensees may convey the work under this License, and how to view a copy of this License. If the interface presents a list of user commands or options, such as a menu, a prominent item in the list meets this criterion. 1. Source Code. The "source code" for a work means the preferred form of the work for making modifications to it. "Object code" means any non-source form of a work. A "Standard Interface" means an interface that either is an official standard defined by a recognized standards body, or, in the case of interfaces specified for a particular programming language, one that is widely used among developers working in that language. The "System Libraries" of an executable work include anything, other than the work as a whole, that (a) is included in the normal form of packaging a Major Component, but which is not part of that Major Component, and (b) serves only to enable use of the work with that Major Component, or to implement a Standard Interface for which an implementation is available to the public in source code form. A "Major Component", in this context, means a major essential component (kernel, window system, and so on) of the specific operating system (if any) on which the executable work runs, or a compiler used to produce the work, or an object code interpreter used to run it. The "Corresponding Source" for a work in object code form means all the source code needed to generate, install, and (for an executable work) run the object code and to modify the work, including scripts to control those activities. However, it does not include the work's System Libraries, or general-purpose tools or generally available free programs which are used unmodified in performing those activities but which are not part of the work. For example, Corresponding Source includes interface definition files associated with source files for the work, and the source code for shared libraries and dynamically linked subprograms that the work is specifically designed to require, such as by intimate data communication or control flow between those subprograms and other parts of the work. The Corresponding Source need not include anything that users can regenerate automatically from other parts of the Corresponding Source. The Corresponding Source for a work in source code form is that same work. 2. Basic Permissions. All rights granted under this License are granted for the term of copyright on the Program, and are irrevocable provided the stated conditions are met. This License explicitly affirms your unlimited permission to run the unmodified Program. The output from running a covered work is covered by this License only if the output, given its content, constitutes a covered work. This License acknowledges your rights of fair use or other equivalent, as provided by copyright law. You may make, run and propagate covered works that you do not convey, without conditions so long as your license otherwise remains in force. You may convey covered works to others for the sole purpose of having them make modifications exclusively for you, or provide you with facilities for running those works, provided that you comply with the terms of this License in conveying all material for which you do not control copyright. Those thus making or running the covered works for you must do so exclusively on your behalf, under your direction and control, on terms that prohibit them from making any copies of your copyrighted material outside their relationship with you. Conveying under any other circumstances is permitted solely under the conditions stated below. Sublicensing is not allowed; section 10 makes it unnecessary. 3. Protecting Users' Legal Rights From Anti-Circumvention Law. No covered work shall be deemed part of an effective technological measure under any applicable law fulfilling obligations under article 11 of the WIPO copyright treaty adopted on 20 December 1996, or similar laws prohibiting or restricting circumvention of such measures. When you convey a covered work, you waive any legal power to forbid circumvention of technological measures to the extent such circumvention is effected by exercising rights under this License with respect to the covered work, and you disclaim any intention to limit operation or modification of the work as a means of enforcing, against the work's users, your or third parties' legal rights to forbid circumvention of technological measures. 4. Conveying Verbatim Copies. You may convey verbatim copies of the Program's source code as you receive it, in any medium, provided that you conspicuously and appropriately publish on each copy an appropriate copyright notice; keep intact all notices stating that this License and any non-permissive terms added in accord with section 7 apply to the code; keep intact all notices of the absence of any warranty; and give all recipients a copy of this License along with the Program. You may charge any price or no price for each copy that you convey, and you may offer support or warranty protection for a fee. 5. Conveying Modified Source Versions. You may convey a work based on the Program, or the modifications to produce it from the Program, in the form of source code under the terms of section 4, provided that you also meet all of these conditions: a) The work must carry prominent notices stating that you modified it, and giving a relevant date. b) The work must carry prominent notices stating that it is released under this License and any conditions added under section 7. This requirement modifies the requirement in section 4 to "keep intact all notices". c) You must license the entire work, as a whole, under this License to anyone who comes into possession of a copy. This License will therefore apply, along with any applicable section 7 additional terms, to the whole of the work, and all its parts, regardless of how they are packaged. This License gives no permission to license the work in any other way, but it does not invalidate such permission if you have separately received it. d) If the work has interactive user interfaces, each must display Appropriate Legal Notices; however, if the Program has interactive interfaces that do not display Appropriate Legal Notices, your work need not make them do so. A compilation of a covered work with other separate and independent works, which are not by their nature extensions of the covered work, and which are not combined with it such as to form a larger program, in or on a volume of a storage or distribution medium, is called an "aggregate" if the compilation and its resulting copyright are not used to limit the access or legal rights of the compilation's users beyond what the individual works permit. Inclusion of a covered work in an aggregate does not cause this License to apply to the other parts of the aggregate. 6. Conveying Non-Source Forms. You may convey a covered work in object code form under the terms of sections 4 and 5, provided that you also convey the machine-readable Corresponding Source under the terms of this License, in one of these ways: a) Convey the object code in, or embodied in, a physical product (including a physical distribution medium), accompanied by the Corresponding Source fixed on a durable physical medium customarily used for software interchange. b) Convey the object code in, or embodied in, a physical product (including a physical distribution medium), accompanied by a written offer, valid for at least three years and valid for as long as you offer spare parts or customer support for that product model, to give anyone who possesses the object code either (1) a copy of the Corresponding Source for all the software in the product that is covered by this License, on a durable physical medium customarily used for software interchange, for a price no more than your reasonable cost of physically performing this conveying of source, or (2) access to copy the Corresponding Source from a network server at no charge. c) Convey individual copies of the object code with a copy of the written offer to provide the Corresponding Source. This alternative is allowed only occasionally and noncommercially, and only if you received the object code with such an offer, in accord with subsection 6b. d) Convey the object code by offering access from a designated place (gratis or for a charge), and offer equivalent access to the Corresponding Source in the same way through the same place at no further charge. You need not require recipients to copy the Corresponding Source along with the object code. If the place to copy the object code is a network server, the Corresponding Source may be on a different server (operated by you or a third party) that supports equivalent copying facilities, provided you maintain clear directions next to the object code saying where to find the Corresponding Source. Regardless of what server hosts the Corresponding Source, you remain obligated to ensure that it is available for as long as needed to satisfy these requirements. e) Convey the object code using peer-to-peer transmission, provided you inform other peers where the object code and Corresponding Source of the work are being offered to the general public at no charge under subsection 6d. A separable portion of the object code, whose source code is excluded from the Corresponding Source as a System Library, need not be included in conveying the object code work. A "User Product" is either (1) a "consumer product", which means any tangible personal property which is normally used for personal, family, or household purposes, or (2) anything designed or sold for incorporation into a dwelling. In determining whether a product is a consumer product, doubtful cases shall be resolved in favor of coverage. For a particular product received by a particular user, "normally used" refers to a typical or common use of that class of product, regardless of the status of the particular user or of the way in which the particular user actually uses, or expects or is expected to use, the product. A product is a consumer product regardless of whether the product has substantial commercial, industrial or non-consumer uses, unless such uses represent the only significant mode of use of the product. "Installation Information" for a User Product means any methods, procedures, authorization keys, or other information required to install and execute modified versions of a covered work in that User Product from a modified version of its Corresponding Source. The information must suffice to ensure that the continued functioning of the modified object code is in no case prevented or interfered with solely because modification has been made. If you convey an object code work under this section in, or with, or specifically for use in, a User Product, and the conveying occurs as part of a transaction in which the right of possession and use of the User Product is transferred to the recipient in perpetuity or for a fixed term (regardless of how the transaction is characterized), the Corresponding Source conveyed under this section must be accompanied by the Installation Information. But this requirement does not apply if neither you nor any third party retains the ability to install modified object code on the User Product (for example, the work has been installed in ROM). The requirement to provide Installation Information does not include a requirement to continue to provide support service, warranty, or updates for a work that has been modified or installed by the recipient, or for the User Product in which it has been modified or installed. Access to a network may be denied when the modification itself materially and adversely affects the operation of the network or violates the rules and protocols for communication across the network. Corresponding Source conveyed, and Installation Information provided, in accord with this section must be in a format that is publicly documented (and with an implementation available to the public in source code form), and must require no special password or key for unpacking, reading or copying. 7. Additional Terms. "Additional permissions" are terms that supplement the terms of this License by making exceptions from one or more of its conditions. Additional permissions that are applicable to the entire Program shall be treated as though they were included in this License, to the extent that they are valid under applicable law. If additional permissions apply only to part of the Program, that part may be used separately under those permissions, but the entire Program remains governed by this License without regard to the additional permissions. When you convey a copy of a covered work, you may at your option remove any additional permissions from that copy, or from any part of it. (Additional permissions may be written to require their own removal in certain cases when you modify the work.) You may place additional permissions on material, added by you to a covered work, for which you have or can give appropriate copyright permission. Notwithstanding any other provision of this License, for material you add to a covered work, you may (if authorized by the copyright holders of that material) supplement the terms of this License with terms: a) Disclaiming warranty or limiting liability differently from the terms of sections 15 and 16 of this License; or b) Requiring preservation of specified reasonable legal notices or author attributions in that material or in the Appropriate Legal Notices displayed by works containing it; or c) Prohibiting misrepresentation of the origin of that material, or requiring that modified versions of such material be marked in reasonable ways as different from the original version; or d) Limiting the use for publicity purposes of names of licensors or authors of the material; or e) Declining to grant rights under trademark law for use of some trade names, trademarks, or service marks; or f) Requiring indemnification of licensors and authors of that material by anyone who conveys the material (or modified versions of it) with contractual assumptions of liability to the recipient, for any liability that these contractual assumptions directly impose on those licensors and authors. All other non-permissive additional terms are considered "further restrictions" within the meaning of section 10. If the Program as you received it, or any part of it, contains a notice stating that it is governed by this License along with a term that is a further restriction, you may remove that term. If a license document contains a further restriction but permits relicensing or conveying under this License, you may add to a covered work material governed by the terms of that license document, provided that the further restriction does not survive such relicensing or conveying. If you add terms to a covered work in accord with this section, you must place, in the relevant source files, a statement of the additional terms that apply to those files, or a notice indicating where to find the applicable terms. Additional terms, permissive or non-permissive, may be stated in the form of a separately written license, or stated as exceptions; the above requirements apply either way. 8. Termination. You may not propagate or modify a covered work except as expressly provided under this License. Any attempt otherwise to propagate or modify it is void, and will automatically terminate your rights under this License (including any patent licenses granted under the third paragraph of section 11). However, if you cease all violation of this License, then your license from a particular copyright holder is reinstated (a) provisionally, unless and until the copyright holder explicitly and finally terminates your license, and (b) permanently, if the copyright holder fails to notify you of the violation by some reasonable means prior to 60 days after the cessation. Moreover, your license from a particular copyright holder is reinstated permanently if the copyright holder notifies you of the violation by some reasonable means, this is the first time you have received notice of violation of this License (for any work) from that copyright holder, and you cure the violation prior to 30 days after your receipt of the notice. Termination of your rights under this section does not terminate the licenses of parties who have received copies or rights from you under this License. If your rights have been terminated and not permanently reinstated, you do not qualify to receive new licenses for the same material under section 10. 9. Acceptance Not Required for Having Copies. You are not required to accept this License in order to receive or run a copy of the Program. Ancillary propagation of a covered work occurring solely as a consequence of using peer-to-peer transmission to receive a copy likewise does not require acceptance. However, nothing other than this License grants you permission to propagate or modify any covered work. These actions infringe copyright if you do not accept this License. Therefore, by modifying or propagating a covered work, you indicate your acceptance of this License to do so. 10. Automatic Licensing of Downstream Recipients. Each time you convey a covered work, the recipient automatically receives a license from the original licensors, to run, modify and propagate that work, subject to this License. You are not responsible for enforcing compliance by third parties with this License. An "entity transaction" is a transaction transferring control of an organization, or substantially all assets of one, or subdividing an organization, or merging organizations. If propagation of a covered work results from an entity transaction, each party to that transaction who receives a copy of the work also receives whatever licenses to the work the party's predecessor in interest had or could give under the previous paragraph, plus a right to possession of the Corresponding Source of the work from the predecessor in interest, if the predecessor has it or can get it with reasonable efforts. You may not impose any further restrictions on the exercise of the rights granted or affirmed under this License. For example, you may not impose a license fee, royalty, or other charge for exercise of rights granted under this License, and you may not initiate litigation (including a cross-claim or counterclaim in a lawsuit) alleging that any patent claim is infringed by making, using, selling, offering for sale, or importing the Program or any portion of it. 11. Patents. A "contributor" is a copyright holder who authorizes use under this License of the Program or a work on which the Program is based. The work thus licensed is called the contributor's "contributor version". A contributor's "essential patent claims" are all patent claims owned or controlled by the contributor, whether already acquired or hereafter acquired, that would be infringed by some manner, permitted by this License, of making, using, or selling its contributor version, but do not include claims that would be infringed only as a consequence of further modification of the contributor version. For purposes of this definition, "control" includes the right to grant patent sublicenses in a manner consistent with the requirements of this License. Each contributor grants you a non-exclusive, worldwide, royalty-free patent license under the contributor's essential patent claims, to make, use, sell, offer for sale, import and otherwise run, modify and propagate the contents of its contributor version. In the following three paragraphs, a "patent license" is any express agreement or commitment, however denominated, not to enforce a patent (such as an express permission to practice a patent or covenant not to sue for patent infringement). To "grant" such a patent license to a party means to make such an agreement or commitment not to enforce a patent against the party. If you convey a covered work, knowingly relying on a patent license, and the Corresponding Source of the work is not available for anyone to copy, free of charge and under the terms of this License, through a publicly available network server or other readily accessible means, then you must either (1) cause the Corresponding Source to be so available, or (2) arrange to deprive yourself of the benefit of the patent license for this particular work, or (3) arrange, in a manner consistent with the requirements of this License, to extend the patent license to downstream recipients. "Knowingly relying" means you have actual knowledge that, but for the patent license, your conveying the covered work in a country, or your recipient's use of the covered work in a country, would infringe one or more identifiable patents in that country that you have reason to believe are valid. If, pursuant to or in connection with a single transaction or arrangement, you convey, or propagate by procuring conveyance of, a covered work, and grant a patent license to some of the parties receiving the covered work authorizing them to use, propagate, modify or convey a specific copy of the covered work, then the patent license you grant is automatically extended to all recipients of the covered work and works based on it. A patent license is "discriminatory" if it does not include within the scope of its coverage, prohibits the exercise of, or is conditioned on the non-exercise of one or more of the rights that are specifically granted under this License. You may not convey a covered work if you are a party to an arrangement with a third party that is in the business of distributing software, under which you make payment to the third party based on the extent of your activity of conveying the work, and under which the third party grants, to any of the parties who would receive the covered work from you, a discriminatory patent license (a) in connection with copies of the covered work conveyed by you (or copies made from those copies), or (b) primarily for and in connection with specific products or compilations that contain the covered work, unless you entered into that arrangement, or that patent license was granted, prior to 28 March 2007. Nothing in this License shall be construed as excluding or limiting any implied license or other defenses to infringement that may otherwise be available to you under applicable patent law. 12. No Surrender of Others' Freedom. If conditions are imposed on you (whether by court order, agreement or otherwise) that contradict the conditions of this License, they do not excuse you from the conditions of this License. If you cannot convey a covered work so as to satisfy simultaneously your obligations under this License and any other pertinent obligations, then as a consequence you may not convey it at all. For example, if you agree to terms that obligate you to collect a royalty for further conveying from those to whom you convey the Program, the only way you could satisfy both those terms and this License would be to refrain entirely from conveying the Program. 13. Use with the GNU Affero General Public License. Notwithstanding any other provision of this License, you have permission to link or combine any covered work with a work licensed under version 3 of the GNU Affero General Public License into a single combined work, and to convey the resulting work. The terms of this License will continue to apply to the part which is the covered work, but the special requirements of the GNU Affero General Public License, section 13, concerning interaction through a network will apply to the combination as such. 14. Revised Versions of this License. The Free Software Foundation may publish revised and/or new versions of the GNU General Public License from time to time. Such new versions will be similar in spirit to the present version, but may differ in detail to address new problems or concerns. Each version is given a distinguishing version number. If the Program specifies that a certain numbered version of the GNU General Public License "or any later version" applies to it, you have the option of following the terms and conditions either of that numbered version or of any later version published by the Free Software Foundation. If the Program does not specify a version number of the GNU General Public License, you may choose any version ever published by the Free Software Foundation. If the Program specifies that a proxy can decide which future versions of the GNU General Public License can be used, that proxy's public statement of acceptance of a version permanently authorizes you to choose that version for the Program. Later license versions may give you additional or different permissions. However, no additional obligations are imposed on any author or copyright holder as a result of your choosing to follow a later version. 15. Disclaimer of Warranty. THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. 16. Limitation of Liability. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. 17. Interpretation of Sections 15 and 16. If the disclaimer of warranty and limitation of liability provided above cannot be given local legal effect according to their terms, reviewing courts shall apply local law that most closely approximates an absolute waiver of all civil liability in connection with the Program, unless a warranty or assumption of liability accompanies a copy of the Program in return for a fee. END OF TERMS AND CONDITIONS How to Apply These Terms to Your New Programs If you develop a new program, and you want it to be of the greatest possible use to the public, the best way to achieve this is to make it free software which everyone can redistribute and change under these terms. To do so, attach the following notices to the program. It is safest to attach them to the start of each source file to most effectively state the exclusion of warranty; and each file should have at least the "copyright" line and a pointer to where the full notice is found. Copyright (C) This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 3 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see . Also add information on how to contact you by electronic and paper mail. If the program does terminal interaction, make it output a short notice like this when it starts in an interactive mode: Copyright (C) This program comes with ABSOLUTELY NO WARRANTY; for details type `show w'. This is free software, and you are welcome to redistribute it under certain conditions; type `show c' for details. The hypothetical commands `show w' and `show c' should show the appropriate parts of the General Public License. Of course, your program's commands might be different; for a GUI interface, you would use an "about box". You should also get your employer (if you work as a programmer) or school, if any, to sign a "copyright disclaimer" for the program, if necessary. For more information on this, and how to apply and follow the GNU GPL, see . The GNU General Public License does not permit incorporating your program into proprietary programs. If your program is a subroutine library, you may consider it more useful to permit linking proprietary applications with the library. If this is what you want to do, use the GNU Lesser General Public License instead of this License. But first, please read . algol68g-2.4.1/Makefile.in0000644000175000001440000014446711771657113012154 00000000000000# Makefile.in generated by automake 1.10.1 from Makefile.am. # @configure_input@ # Copyright (C) 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, # 2003, 2004, 2005, 2006, 2007, 2008 Free Software Foundation, Inc. # This Makefile.in is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, # with or without modifications, as long as this notice is preserved. # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY, to the extent permitted by law; without # even the implied warranty of MERCHANTABILITY or FITNESS FOR A # PARTICULAR PURPOSE. @SET_MAKE@ VPATH = @srcdir@ pkgdatadir = $(datadir)/@PACKAGE@ pkglibdir = $(libdir)/@PACKAGE@ pkgincludedir = $(includedir)/@PACKAGE@ am__cd = CDPATH="$${ZSH_VERSION+.}$(PATH_SEPARATOR)" && cd install_sh_DATA = $(install_sh) -c -m 644 install_sh_PROGRAM = $(install_sh) -c install_sh_SCRIPT = $(install_sh) -c INSTALL_HEADER = $(INSTALL_DATA) transform = $(program_transform_name) NORMAL_INSTALL = : PRE_INSTALL = : POST_INSTALL = : NORMAL_UNINSTALL = : PRE_UNINSTALL = : POST_UNINSTALL = : build_triplet = @build@ host_triplet = @host@ target_triplet = @target@ bin_PROGRAMS = a68g$(EXEEXT) subdir = . DIST_COMMON = README $(am__configure_deps) $(pkginclude_HEADERS) \ $(srcdir)/Makefile.am $(srcdir)/Makefile.in \ $(top_srcdir)/configure $(top_srcdir)/source/a68g-config.h.in \ AUTHORS COPYING ChangeLog INSTALL NEWS compile config.guess \ config.sub depcomp install-sh missing ACLOCAL_M4 = $(top_srcdir)/aclocal.m4 am__aclocal_m4_deps = $(top_srcdir)/configure.ac am__configure_deps = $(am__aclocal_m4_deps) $(CONFIGURE_DEPENDENCIES) \ $(ACLOCAL_M4) am__CONFIG_DISTCLEAN_FILES = config.status config.cache config.log \ configure.lineno config.status.lineno mkinstalldirs = $(install_sh) -d CONFIG_HEADER = $(top_builddir)/source/a68g-config.h CONFIG_CLEAN_FILES = am__installdirs = "$(DESTDIR)$(bindir)" "$(DESTDIR)$(man1dir)" \ "$(DESTDIR)$(docdir)" "$(DESTDIR)$(pkgincludedir)" binPROGRAMS_INSTALL = $(INSTALL_PROGRAM) PROGRAMS = $(bin_PROGRAMS) am__dirstamp = $(am__leading_dot)dirstamp am_a68g_OBJECTS = source/a68g-a68g.$(OBJEXT) \ source/a68g-code.$(OBJEXT) source/a68g-environ.$(OBJEXT) \ source/a68g-genie.$(OBJEXT) source/a68g-gsl.$(OBJEXT) \ source/a68g-inet.$(OBJEXT) source/a68g-monitor.$(OBJEXT) \ source/a68g-mp.$(OBJEXT) source/a68g-plotutils.$(OBJEXT) \ source/a68g-postgresql.$(OBJEXT) source/a68g-pretty.$(OBJEXT) \ source/a68g-syntax.$(OBJEXT) source/a68g-edit.$(OBJEXT) a68g_OBJECTS = $(am_a68g_OBJECTS) a68g_LDADD = $(LDADD) a68g_LINK = $(CCLD) $(a68g_CFLAGS) $(CFLAGS) $(a68g_LDFLAGS) \ $(LDFLAGS) -o $@ DEFAULT_INCLUDES = -I.@am__isrc@ -I$(top_builddir)/source depcomp = $(SHELL) $(top_srcdir)/depcomp am__depfiles_maybe = depfiles COMPILE = $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) \ $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) CCLD = $(CC) LINK = $(CCLD) $(AM_CFLAGS) $(CFLAGS) $(AM_LDFLAGS) $(LDFLAGS) -o $@ SOURCES = $(a68g_SOURCES) DIST_SOURCES = $(a68g_SOURCES) man1dir = $(mandir)/man1 NROFF = nroff MANS = $(man_MANS) am__vpath_adj_setup = srcdirstrip=`echo "$(srcdir)" | sed 's|.|.|g'`; am__vpath_adj = case $$p in \ $(srcdir)/*) f=`echo "$$p" | sed "s|^$$srcdirstrip/||"`;; \ *) f=$$p;; \ esac; am__strip_dir = `echo $$p | sed -e 's|^.*/||'`; docDATA_INSTALL = $(INSTALL_DATA) DATA = $(doc_DATA) pkgincludeHEADERS_INSTALL = $(INSTALL_HEADER) HEADERS = $(pkginclude_HEADERS) ETAGS = etags CTAGS = ctags DISTFILES = $(DIST_COMMON) $(DIST_SOURCES) $(TEXINFOS) $(EXTRA_DIST) distdir = $(PACKAGE)-$(VERSION) top_distdir = $(distdir) am__remove_distdir = \ { test ! -d $(distdir) \ || { find $(distdir) -type d ! -perm -200 -exec chmod u+w {} ';' \ && rm -fr $(distdir); }; } DIST_ARCHIVES = $(distdir).tar.gz GZIP_ENV = --best distuninstallcheck_listfiles = find . -type f -print distcleancheck_listfiles = find . -type f -print ACLOCAL = @ACLOCAL@ AMTAR = @AMTAR@ AUTOCONF = @AUTOCONF@ AUTOHEADER = @AUTOHEADER@ AUTOMAKE = @AUTOMAKE@ AWK = @AWK@ CC = @CC@ CCDEPMODE = @CCDEPMODE@ CFLAGS = @CFLAGS@ CPP = @CPP@ CPPFLAGS = @CPPFLAGS@ CYGPATH_W = @CYGPATH_W@ DEFS = @DEFS@ DEPDIR = @DEPDIR@ ECHO_C = @ECHO_C@ ECHO_N = @ECHO_N@ ECHO_T = @ECHO_T@ EGREP = @EGREP@ EXEEXT = @EXEEXT@ GREP = @GREP@ INSTALL = @INSTALL@ INSTALL_DATA = @INSTALL_DATA@ INSTALL_PROGRAM = @INSTALL_PROGRAM@ INSTALL_SCRIPT = @INSTALL_SCRIPT@ INSTALL_STRIP_PROGRAM = @INSTALL_STRIP_PROGRAM@ LDFLAGS = @LDFLAGS@ LIBOBJS = @LIBOBJS@ LIBS = @LIBS@ LTLIBOBJS = @LTLIBOBJS@ MAKEINFO = @MAKEINFO@ MKDIR_P = @MKDIR_P@ OBJEXT = @OBJEXT@ PACKAGE = @PACKAGE@ PACKAGE_BUGREPORT = @PACKAGE_BUGREPORT@ PACKAGE_NAME = @PACKAGE_NAME@ PACKAGE_STRING = @PACKAGE_STRING@ PACKAGE_TARNAME = @PACKAGE_TARNAME@ PACKAGE_VERSION = @PACKAGE_VERSION@ PATH_SEPARATOR = @PATH_SEPARATOR@ SET_MAKE = @SET_MAKE@ SHELL = @SHELL@ STRIP = @STRIP@ VERSION = @VERSION@ a68g_exists = @a68g_exists@ abs_builddir = @abs_builddir@ abs_srcdir = @abs_srcdir@ abs_top_builddir = @abs_top_builddir@ abs_top_srcdir = @abs_top_srcdir@ ac_ct_CC = @ac_ct_CC@ am__include = @am__include@ am__leading_dot = @am__leading_dot@ am__quote = @am__quote@ am__tar = @am__tar@ am__untar = @am__untar@ bindir = @bindir@ build = @build@ build_alias = @build_alias@ build_cpu = @build_cpu@ build_os = @build_os@ build_vendor = @build_vendor@ builddir = @builddir@ datadir = @datadir@ datarootdir = @datarootdir@ docdir = ${prefix}/doc/@PACKAGE@-@VERSION@ dvidir = @dvidir@ exec_prefix = @exec_prefix@ host = @host@ host_alias = @host_alias@ host_cpu = @host_cpu@ host_os = @host_os@ host_vendor = @host_vendor@ htmldir = @htmldir@ includedir = @includedir@ infodir = @infodir@ install_sh = @install_sh@ libdir = @libdir@ libexecdir = @libexecdir@ localedir = @localedir@ localstatedir = @localstatedir@ mandir = @mandir@ mkdir_p = @mkdir_p@ oldincludedir = @oldincludedir@ pdfdir = @pdfdir@ prefix = @prefix@ program_transform_name = @program_transform_name@ psdir = @psdir@ sbindir = @sbindir@ sharedstatedir = @sharedstatedir@ srcdir = @srcdir@ sysconfdir = @sysconfdir@ target = @target@ target_alias = @target_alias@ target_cpu = @target_cpu@ target_os = @target_os@ target_vendor = @target_vendor@ top_build_prefix = @top_build_prefix@ top_builddir = @top_builddir@ top_srcdir = @top_srcdir@ a68g_SOURCES = source/a68g.c source/code.c source/environ.c source/genie.c source/gsl.c source/inet.c source/monitor.c source/mp.c source/plotutils.c source/postgresql.c source/pretty.c source/syntax.c source/edit.c a68g_CFLAGS = -DBINDIR='"$(bindir)"' -DINCLUDEDIR='"$(includedir)"' TESTS_ENVIRONMENT = ./a68g TESTS = check/check-01.a68 check/check-02.a68 check/check-03.a68 check/check-04.a68 check/check-05.a68 check/check-06.a68 check/check-07.a68 check/check-08.a68 check/check-09.a68 check/check-10.a68 @EXPORT_DYNAMIC_FALSE@a68g_LDFLAGS = @EXPORT_DYNAMIC_TRUE@a68g_LDFLAGS = -Wl,--export-dynamic pkginclude_HEADERS = source/a68g.h source/a68g-config.h man_MANS = doc/a68g.1 doc_DATA = AUTHORS COPYING NEWS README EXTRA_DIST = $(man_MANS) source/a68g-config.win32.h check/check-01.a68 check/check-02.a68 check/check-03.a68 check/check-04.a68 check/check-05.a68 check/check-06.a68 check/check-07.a68 check/check-08.a68 check/check-09.a68 check/check-10.a68 all: all-am .SUFFIXES: .SUFFIXES: .c .o .obj am--refresh: @: $(srcdir)/Makefile.in: $(srcdir)/Makefile.am $(am__configure_deps) @for dep in $?; do \ case '$(am__configure_deps)' in \ *$$dep*) \ echo ' cd $(srcdir) && $(AUTOMAKE) --gnu '; \ cd $(srcdir) && $(AUTOMAKE) --gnu \ && exit 0; \ exit 1;; \ esac; \ done; \ echo ' cd $(top_srcdir) && $(AUTOMAKE) --gnu Makefile'; \ cd $(top_srcdir) && \ $(AUTOMAKE) --gnu Makefile .PRECIOUS: Makefile Makefile: $(srcdir)/Makefile.in $(top_builddir)/config.status @case '$?' in \ *config.status*) \ echo ' $(SHELL) ./config.status'; \ $(SHELL) ./config.status;; \ *) \ echo ' cd $(top_builddir) && $(SHELL) ./config.status $@ $(am__depfiles_maybe)'; \ cd $(top_builddir) && $(SHELL) ./config.status $@ $(am__depfiles_maybe);; \ esac; $(top_builddir)/config.status: $(top_srcdir)/configure $(CONFIG_STATUS_DEPENDENCIES) $(SHELL) ./config.status --recheck $(top_srcdir)/configure: $(am__configure_deps) cd $(srcdir) && $(AUTOCONF) $(ACLOCAL_M4): $(am__aclocal_m4_deps) cd $(srcdir) && $(ACLOCAL) $(ACLOCAL_AMFLAGS) source/a68g-config.h: source/stamp-h1 @if test ! -f $@; then \ rm -f source/stamp-h1; \ $(MAKE) $(AM_MAKEFLAGS) source/stamp-h1; \ else :; fi source/stamp-h1: $(top_srcdir)/source/a68g-config.h.in $(top_builddir)/config.status @rm -f source/stamp-h1 cd $(top_builddir) && $(SHELL) ./config.status source/a68g-config.h $(top_srcdir)/source/a68g-config.h.in: $(am__configure_deps) cd $(top_srcdir) && $(AUTOHEADER) rm -f source/stamp-h1 touch $@ distclean-hdr: -rm -f source/a68g-config.h source/stamp-h1 install-binPROGRAMS: $(bin_PROGRAMS) @$(NORMAL_INSTALL) test -z "$(bindir)" || $(MKDIR_P) "$(DESTDIR)$(bindir)" @list='$(bin_PROGRAMS)'; for p in $$list; do \ p1=`echo $$p|sed 's/$(EXEEXT)$$//'`; \ if test -f $$p \ ; then \ f=`echo "$$p1" | sed 's,^.*/,,;$(transform);s/$$/$(EXEEXT)/'`; \ echo " $(INSTALL_PROGRAM_ENV) $(binPROGRAMS_INSTALL) '$$p' '$(DESTDIR)$(bindir)/$$f'"; \ $(INSTALL_PROGRAM_ENV) $(binPROGRAMS_INSTALL) "$$p" "$(DESTDIR)$(bindir)/$$f" || exit 1; \ else :; fi; \ done uninstall-binPROGRAMS: @$(NORMAL_UNINSTALL) @list='$(bin_PROGRAMS)'; for p in $$list; do \ f=`echo "$$p" | sed 's,^.*/,,;s/$(EXEEXT)$$//;$(transform);s/$$/$(EXEEXT)/'`; \ echo " rm -f '$(DESTDIR)$(bindir)/$$f'"; \ rm -f "$(DESTDIR)$(bindir)/$$f"; \ done clean-binPROGRAMS: -test -z "$(bin_PROGRAMS)" || rm -f $(bin_PROGRAMS) source/$(am__dirstamp): @$(MKDIR_P) source @: > source/$(am__dirstamp) source/$(DEPDIR)/$(am__dirstamp): @$(MKDIR_P) source/$(DEPDIR) @: > source/$(DEPDIR)/$(am__dirstamp) source/a68g-a68g.$(OBJEXT): source/$(am__dirstamp) \ source/$(DEPDIR)/$(am__dirstamp) source/a68g-code.$(OBJEXT): source/$(am__dirstamp) \ source/$(DEPDIR)/$(am__dirstamp) source/a68g-environ.$(OBJEXT): source/$(am__dirstamp) \ source/$(DEPDIR)/$(am__dirstamp) source/a68g-genie.$(OBJEXT): source/$(am__dirstamp) \ source/$(DEPDIR)/$(am__dirstamp) source/a68g-gsl.$(OBJEXT): source/$(am__dirstamp) \ source/$(DEPDIR)/$(am__dirstamp) source/a68g-inet.$(OBJEXT): source/$(am__dirstamp) \ source/$(DEPDIR)/$(am__dirstamp) source/a68g-monitor.$(OBJEXT): source/$(am__dirstamp) \ source/$(DEPDIR)/$(am__dirstamp) source/a68g-mp.$(OBJEXT): source/$(am__dirstamp) \ source/$(DEPDIR)/$(am__dirstamp) source/a68g-plotutils.$(OBJEXT): source/$(am__dirstamp) \ source/$(DEPDIR)/$(am__dirstamp) source/a68g-postgresql.$(OBJEXT): source/$(am__dirstamp) \ source/$(DEPDIR)/$(am__dirstamp) source/a68g-pretty.$(OBJEXT): source/$(am__dirstamp) \ source/$(DEPDIR)/$(am__dirstamp) source/a68g-syntax.$(OBJEXT): source/$(am__dirstamp) \ source/$(DEPDIR)/$(am__dirstamp) source/a68g-edit.$(OBJEXT): source/$(am__dirstamp) \ source/$(DEPDIR)/$(am__dirstamp) a68g$(EXEEXT): $(a68g_OBJECTS) $(a68g_DEPENDENCIES) @rm -f a68g$(EXEEXT) $(a68g_LINK) $(a68g_OBJECTS) $(a68g_LDADD) $(LIBS) mostlyclean-compile: -rm -f *.$(OBJEXT) -rm -f source/a68g-a68g.$(OBJEXT) -rm -f source/a68g-code.$(OBJEXT) -rm -f source/a68g-edit.$(OBJEXT) -rm -f source/a68g-environ.$(OBJEXT) -rm -f source/a68g-genie.$(OBJEXT) -rm -f source/a68g-gsl.$(OBJEXT) -rm -f source/a68g-inet.$(OBJEXT) -rm -f source/a68g-monitor.$(OBJEXT) -rm -f source/a68g-mp.$(OBJEXT) -rm -f source/a68g-plotutils.$(OBJEXT) -rm -f source/a68g-postgresql.$(OBJEXT) -rm -f source/a68g-pretty.$(OBJEXT) -rm -f source/a68g-syntax.$(OBJEXT) distclean-compile: -rm -f *.tab.c @AMDEP_TRUE@@am__include@ @am__quote@source/$(DEPDIR)/a68g-a68g.Po@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@source/$(DEPDIR)/a68g-code.Po@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@source/$(DEPDIR)/a68g-edit.Po@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@source/$(DEPDIR)/a68g-environ.Po@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@source/$(DEPDIR)/a68g-genie.Po@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@source/$(DEPDIR)/a68g-gsl.Po@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@source/$(DEPDIR)/a68g-inet.Po@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@source/$(DEPDIR)/a68g-monitor.Po@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@source/$(DEPDIR)/a68g-mp.Po@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@source/$(DEPDIR)/a68g-plotutils.Po@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@source/$(DEPDIR)/a68g-postgresql.Po@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@source/$(DEPDIR)/a68g-pretty.Po@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@source/$(DEPDIR)/a68g-syntax.Po@am__quote@ .c.o: @am__fastdepCC_TRUE@ depbase=`echo $@ | sed 's|[^/]*$$|$(DEPDIR)/&|;s|\.o$$||'`;\ @am__fastdepCC_TRUE@ $(COMPILE) -MT $@ -MD -MP -MF $$depbase.Tpo -c -o $@ $< &&\ @am__fastdepCC_TRUE@ mv -f $$depbase.Tpo $$depbase.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ source='$<' object='$@' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(COMPILE) -c -o $@ $< .c.obj: @am__fastdepCC_TRUE@ depbase=`echo $@ | sed 's|[^/]*$$|$(DEPDIR)/&|;s|\.obj$$||'`;\ @am__fastdepCC_TRUE@ $(COMPILE) -MT $@ -MD -MP -MF $$depbase.Tpo -c -o $@ `$(CYGPATH_W) '$<'` &&\ @am__fastdepCC_TRUE@ mv -f $$depbase.Tpo $$depbase.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ source='$<' object='$@' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(COMPILE) -c -o $@ `$(CYGPATH_W) '$<'` source/a68g-a68g.o: source/a68g.c @am__fastdepCC_TRUE@ $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT source/a68g-a68g.o -MD -MP -MF source/$(DEPDIR)/a68g-a68g.Tpo -c -o source/a68g-a68g.o `test -f 'source/a68g.c' || echo '$(srcdir)/'`source/a68g.c @am__fastdepCC_TRUE@ mv -f source/$(DEPDIR)/a68g-a68g.Tpo source/$(DEPDIR)/a68g-a68g.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ source='source/a68g.c' object='source/a68g-a68g.o' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o source/a68g-a68g.o `test -f 'source/a68g.c' || echo '$(srcdir)/'`source/a68g.c source/a68g-a68g.obj: source/a68g.c @am__fastdepCC_TRUE@ $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT source/a68g-a68g.obj -MD -MP -MF source/$(DEPDIR)/a68g-a68g.Tpo -c -o source/a68g-a68g.obj `if test -f 'source/a68g.c'; then $(CYGPATH_W) 'source/a68g.c'; else $(CYGPATH_W) '$(srcdir)/source/a68g.c'; fi` @am__fastdepCC_TRUE@ mv -f source/$(DEPDIR)/a68g-a68g.Tpo source/$(DEPDIR)/a68g-a68g.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ source='source/a68g.c' object='source/a68g-a68g.obj' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o source/a68g-a68g.obj `if test -f 'source/a68g.c'; then $(CYGPATH_W) 'source/a68g.c'; else $(CYGPATH_W) '$(srcdir)/source/a68g.c'; fi` source/a68g-code.o: source/code.c @am__fastdepCC_TRUE@ $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT source/a68g-code.o -MD -MP -MF source/$(DEPDIR)/a68g-code.Tpo -c -o source/a68g-code.o `test -f 'source/code.c' || echo '$(srcdir)/'`source/code.c @am__fastdepCC_TRUE@ mv -f source/$(DEPDIR)/a68g-code.Tpo source/$(DEPDIR)/a68g-code.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ source='source/code.c' object='source/a68g-code.o' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o source/a68g-code.o `test -f 'source/code.c' || echo '$(srcdir)/'`source/code.c source/a68g-code.obj: source/code.c @am__fastdepCC_TRUE@ $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT source/a68g-code.obj -MD -MP -MF source/$(DEPDIR)/a68g-code.Tpo -c -o source/a68g-code.obj `if test -f 'source/code.c'; then $(CYGPATH_W) 'source/code.c'; else $(CYGPATH_W) '$(srcdir)/source/code.c'; fi` @am__fastdepCC_TRUE@ mv -f source/$(DEPDIR)/a68g-code.Tpo source/$(DEPDIR)/a68g-code.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ source='source/code.c' object='source/a68g-code.obj' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o source/a68g-code.obj `if test -f 'source/code.c'; then $(CYGPATH_W) 'source/code.c'; else $(CYGPATH_W) '$(srcdir)/source/code.c'; fi` source/a68g-environ.o: source/environ.c @am__fastdepCC_TRUE@ $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT source/a68g-environ.o -MD -MP -MF source/$(DEPDIR)/a68g-environ.Tpo -c -o source/a68g-environ.o `test -f 'source/environ.c' || echo '$(srcdir)/'`source/environ.c @am__fastdepCC_TRUE@ mv -f source/$(DEPDIR)/a68g-environ.Tpo source/$(DEPDIR)/a68g-environ.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ source='source/environ.c' object='source/a68g-environ.o' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o source/a68g-environ.o `test -f 'source/environ.c' || echo '$(srcdir)/'`source/environ.c source/a68g-environ.obj: source/environ.c @am__fastdepCC_TRUE@ $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT source/a68g-environ.obj -MD -MP -MF source/$(DEPDIR)/a68g-environ.Tpo -c -o source/a68g-environ.obj `if test -f 'source/environ.c'; then $(CYGPATH_W) 'source/environ.c'; else $(CYGPATH_W) '$(srcdir)/source/environ.c'; fi` @am__fastdepCC_TRUE@ mv -f source/$(DEPDIR)/a68g-environ.Tpo source/$(DEPDIR)/a68g-environ.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ source='source/environ.c' object='source/a68g-environ.obj' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o source/a68g-environ.obj `if test -f 'source/environ.c'; then $(CYGPATH_W) 'source/environ.c'; else $(CYGPATH_W) '$(srcdir)/source/environ.c'; fi` source/a68g-genie.o: source/genie.c @am__fastdepCC_TRUE@ $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT source/a68g-genie.o -MD -MP -MF source/$(DEPDIR)/a68g-genie.Tpo -c -o source/a68g-genie.o `test -f 'source/genie.c' || echo '$(srcdir)/'`source/genie.c @am__fastdepCC_TRUE@ mv -f source/$(DEPDIR)/a68g-genie.Tpo source/$(DEPDIR)/a68g-genie.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ source='source/genie.c' object='source/a68g-genie.o' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o source/a68g-genie.o `test -f 'source/genie.c' || echo '$(srcdir)/'`source/genie.c source/a68g-genie.obj: source/genie.c @am__fastdepCC_TRUE@ $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT source/a68g-genie.obj -MD -MP -MF source/$(DEPDIR)/a68g-genie.Tpo -c -o source/a68g-genie.obj `if test -f 'source/genie.c'; then $(CYGPATH_W) 'source/genie.c'; else $(CYGPATH_W) '$(srcdir)/source/genie.c'; fi` @am__fastdepCC_TRUE@ mv -f source/$(DEPDIR)/a68g-genie.Tpo source/$(DEPDIR)/a68g-genie.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ source='source/genie.c' object='source/a68g-genie.obj' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o source/a68g-genie.obj `if test -f 'source/genie.c'; then $(CYGPATH_W) 'source/genie.c'; else $(CYGPATH_W) '$(srcdir)/source/genie.c'; fi` source/a68g-gsl.o: source/gsl.c @am__fastdepCC_TRUE@ $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT source/a68g-gsl.o -MD -MP -MF source/$(DEPDIR)/a68g-gsl.Tpo -c -o source/a68g-gsl.o `test -f 'source/gsl.c' || echo '$(srcdir)/'`source/gsl.c @am__fastdepCC_TRUE@ mv -f source/$(DEPDIR)/a68g-gsl.Tpo source/$(DEPDIR)/a68g-gsl.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ source='source/gsl.c' object='source/a68g-gsl.o' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o source/a68g-gsl.o `test -f 'source/gsl.c' || echo '$(srcdir)/'`source/gsl.c source/a68g-gsl.obj: source/gsl.c @am__fastdepCC_TRUE@ $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT source/a68g-gsl.obj -MD -MP -MF source/$(DEPDIR)/a68g-gsl.Tpo -c -o source/a68g-gsl.obj `if test -f 'source/gsl.c'; then $(CYGPATH_W) 'source/gsl.c'; else $(CYGPATH_W) '$(srcdir)/source/gsl.c'; fi` @am__fastdepCC_TRUE@ mv -f source/$(DEPDIR)/a68g-gsl.Tpo source/$(DEPDIR)/a68g-gsl.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ source='source/gsl.c' object='source/a68g-gsl.obj' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o source/a68g-gsl.obj `if test -f 'source/gsl.c'; then $(CYGPATH_W) 'source/gsl.c'; else $(CYGPATH_W) '$(srcdir)/source/gsl.c'; fi` source/a68g-inet.o: source/inet.c @am__fastdepCC_TRUE@ $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT source/a68g-inet.o -MD -MP -MF source/$(DEPDIR)/a68g-inet.Tpo -c -o source/a68g-inet.o `test -f 'source/inet.c' || echo '$(srcdir)/'`source/inet.c @am__fastdepCC_TRUE@ mv -f source/$(DEPDIR)/a68g-inet.Tpo source/$(DEPDIR)/a68g-inet.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ source='source/inet.c' object='source/a68g-inet.o' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o source/a68g-inet.o `test -f 'source/inet.c' || echo '$(srcdir)/'`source/inet.c source/a68g-inet.obj: source/inet.c @am__fastdepCC_TRUE@ $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT source/a68g-inet.obj -MD -MP -MF source/$(DEPDIR)/a68g-inet.Tpo -c -o source/a68g-inet.obj `if test -f 'source/inet.c'; then $(CYGPATH_W) 'source/inet.c'; else $(CYGPATH_W) '$(srcdir)/source/inet.c'; fi` @am__fastdepCC_TRUE@ mv -f source/$(DEPDIR)/a68g-inet.Tpo source/$(DEPDIR)/a68g-inet.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ source='source/inet.c' object='source/a68g-inet.obj' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o source/a68g-inet.obj `if test -f 'source/inet.c'; then $(CYGPATH_W) 'source/inet.c'; else $(CYGPATH_W) '$(srcdir)/source/inet.c'; fi` source/a68g-monitor.o: source/monitor.c @am__fastdepCC_TRUE@ $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT source/a68g-monitor.o -MD -MP -MF source/$(DEPDIR)/a68g-monitor.Tpo -c -o source/a68g-monitor.o `test -f 'source/monitor.c' || echo '$(srcdir)/'`source/monitor.c @am__fastdepCC_TRUE@ mv -f source/$(DEPDIR)/a68g-monitor.Tpo source/$(DEPDIR)/a68g-monitor.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ source='source/monitor.c' object='source/a68g-monitor.o' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o source/a68g-monitor.o `test -f 'source/monitor.c' || echo '$(srcdir)/'`source/monitor.c source/a68g-monitor.obj: source/monitor.c @am__fastdepCC_TRUE@ $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT source/a68g-monitor.obj -MD -MP -MF source/$(DEPDIR)/a68g-monitor.Tpo -c -o source/a68g-monitor.obj `if test -f 'source/monitor.c'; then $(CYGPATH_W) 'source/monitor.c'; else $(CYGPATH_W) '$(srcdir)/source/monitor.c'; fi` @am__fastdepCC_TRUE@ mv -f source/$(DEPDIR)/a68g-monitor.Tpo source/$(DEPDIR)/a68g-monitor.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ source='source/monitor.c' object='source/a68g-monitor.obj' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o source/a68g-monitor.obj `if test -f 'source/monitor.c'; then $(CYGPATH_W) 'source/monitor.c'; else $(CYGPATH_W) '$(srcdir)/source/monitor.c'; fi` source/a68g-mp.o: source/mp.c @am__fastdepCC_TRUE@ $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT source/a68g-mp.o -MD -MP -MF source/$(DEPDIR)/a68g-mp.Tpo -c -o source/a68g-mp.o `test -f 'source/mp.c' || echo '$(srcdir)/'`source/mp.c @am__fastdepCC_TRUE@ mv -f source/$(DEPDIR)/a68g-mp.Tpo source/$(DEPDIR)/a68g-mp.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ source='source/mp.c' object='source/a68g-mp.o' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o source/a68g-mp.o `test -f 'source/mp.c' || echo '$(srcdir)/'`source/mp.c source/a68g-mp.obj: source/mp.c @am__fastdepCC_TRUE@ $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT source/a68g-mp.obj -MD -MP -MF source/$(DEPDIR)/a68g-mp.Tpo -c -o source/a68g-mp.obj `if test -f 'source/mp.c'; then $(CYGPATH_W) 'source/mp.c'; else $(CYGPATH_W) '$(srcdir)/source/mp.c'; fi` @am__fastdepCC_TRUE@ mv -f source/$(DEPDIR)/a68g-mp.Tpo source/$(DEPDIR)/a68g-mp.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ source='source/mp.c' object='source/a68g-mp.obj' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o source/a68g-mp.obj `if test -f 'source/mp.c'; then $(CYGPATH_W) 'source/mp.c'; else $(CYGPATH_W) '$(srcdir)/source/mp.c'; fi` source/a68g-plotutils.o: source/plotutils.c @am__fastdepCC_TRUE@ $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT source/a68g-plotutils.o -MD -MP -MF source/$(DEPDIR)/a68g-plotutils.Tpo -c -o source/a68g-plotutils.o `test -f 'source/plotutils.c' || echo '$(srcdir)/'`source/plotutils.c @am__fastdepCC_TRUE@ mv -f source/$(DEPDIR)/a68g-plotutils.Tpo source/$(DEPDIR)/a68g-plotutils.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ source='source/plotutils.c' object='source/a68g-plotutils.o' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o source/a68g-plotutils.o `test -f 'source/plotutils.c' || echo '$(srcdir)/'`source/plotutils.c source/a68g-plotutils.obj: source/plotutils.c @am__fastdepCC_TRUE@ $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT source/a68g-plotutils.obj -MD -MP -MF source/$(DEPDIR)/a68g-plotutils.Tpo -c -o source/a68g-plotutils.obj `if test -f 'source/plotutils.c'; then $(CYGPATH_W) 'source/plotutils.c'; else $(CYGPATH_W) '$(srcdir)/source/plotutils.c'; fi` @am__fastdepCC_TRUE@ mv -f source/$(DEPDIR)/a68g-plotutils.Tpo source/$(DEPDIR)/a68g-plotutils.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ source='source/plotutils.c' object='source/a68g-plotutils.obj' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o source/a68g-plotutils.obj `if test -f 'source/plotutils.c'; then $(CYGPATH_W) 'source/plotutils.c'; else $(CYGPATH_W) '$(srcdir)/source/plotutils.c'; fi` source/a68g-postgresql.o: source/postgresql.c @am__fastdepCC_TRUE@ $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT source/a68g-postgresql.o -MD -MP -MF source/$(DEPDIR)/a68g-postgresql.Tpo -c -o source/a68g-postgresql.o `test -f 'source/postgresql.c' || echo '$(srcdir)/'`source/postgresql.c @am__fastdepCC_TRUE@ mv -f source/$(DEPDIR)/a68g-postgresql.Tpo source/$(DEPDIR)/a68g-postgresql.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ source='source/postgresql.c' object='source/a68g-postgresql.o' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o source/a68g-postgresql.o `test -f 'source/postgresql.c' || echo '$(srcdir)/'`source/postgresql.c source/a68g-postgresql.obj: source/postgresql.c @am__fastdepCC_TRUE@ $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT source/a68g-postgresql.obj -MD -MP -MF source/$(DEPDIR)/a68g-postgresql.Tpo -c -o source/a68g-postgresql.obj `if test -f 'source/postgresql.c'; then $(CYGPATH_W) 'source/postgresql.c'; else $(CYGPATH_W) '$(srcdir)/source/postgresql.c'; fi` @am__fastdepCC_TRUE@ mv -f source/$(DEPDIR)/a68g-postgresql.Tpo source/$(DEPDIR)/a68g-postgresql.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ source='source/postgresql.c' object='source/a68g-postgresql.obj' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o source/a68g-postgresql.obj `if test -f 'source/postgresql.c'; then $(CYGPATH_W) 'source/postgresql.c'; else $(CYGPATH_W) '$(srcdir)/source/postgresql.c'; fi` source/a68g-pretty.o: source/pretty.c @am__fastdepCC_TRUE@ $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT source/a68g-pretty.o -MD -MP -MF source/$(DEPDIR)/a68g-pretty.Tpo -c -o source/a68g-pretty.o `test -f 'source/pretty.c' || echo '$(srcdir)/'`source/pretty.c @am__fastdepCC_TRUE@ mv -f source/$(DEPDIR)/a68g-pretty.Tpo source/$(DEPDIR)/a68g-pretty.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ source='source/pretty.c' object='source/a68g-pretty.o' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o source/a68g-pretty.o `test -f 'source/pretty.c' || echo '$(srcdir)/'`source/pretty.c source/a68g-pretty.obj: source/pretty.c @am__fastdepCC_TRUE@ $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT source/a68g-pretty.obj -MD -MP -MF source/$(DEPDIR)/a68g-pretty.Tpo -c -o source/a68g-pretty.obj `if test -f 'source/pretty.c'; then $(CYGPATH_W) 'source/pretty.c'; else $(CYGPATH_W) '$(srcdir)/source/pretty.c'; fi` @am__fastdepCC_TRUE@ mv -f source/$(DEPDIR)/a68g-pretty.Tpo source/$(DEPDIR)/a68g-pretty.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ source='source/pretty.c' object='source/a68g-pretty.obj' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o source/a68g-pretty.obj `if test -f 'source/pretty.c'; then $(CYGPATH_W) 'source/pretty.c'; else $(CYGPATH_W) '$(srcdir)/source/pretty.c'; fi` source/a68g-syntax.o: source/syntax.c @am__fastdepCC_TRUE@ $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT source/a68g-syntax.o -MD -MP -MF source/$(DEPDIR)/a68g-syntax.Tpo -c -o source/a68g-syntax.o `test -f 'source/syntax.c' || echo '$(srcdir)/'`source/syntax.c @am__fastdepCC_TRUE@ mv -f source/$(DEPDIR)/a68g-syntax.Tpo source/$(DEPDIR)/a68g-syntax.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ source='source/syntax.c' object='source/a68g-syntax.o' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o source/a68g-syntax.o `test -f 'source/syntax.c' || echo '$(srcdir)/'`source/syntax.c source/a68g-syntax.obj: source/syntax.c @am__fastdepCC_TRUE@ $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT source/a68g-syntax.obj -MD -MP -MF source/$(DEPDIR)/a68g-syntax.Tpo -c -o source/a68g-syntax.obj `if test -f 'source/syntax.c'; then $(CYGPATH_W) 'source/syntax.c'; else $(CYGPATH_W) '$(srcdir)/source/syntax.c'; fi` @am__fastdepCC_TRUE@ mv -f source/$(DEPDIR)/a68g-syntax.Tpo source/$(DEPDIR)/a68g-syntax.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ source='source/syntax.c' object='source/a68g-syntax.obj' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o source/a68g-syntax.obj `if test -f 'source/syntax.c'; then $(CYGPATH_W) 'source/syntax.c'; else $(CYGPATH_W) '$(srcdir)/source/syntax.c'; fi` source/a68g-edit.o: source/edit.c @am__fastdepCC_TRUE@ $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT source/a68g-edit.o -MD -MP -MF source/$(DEPDIR)/a68g-edit.Tpo -c -o source/a68g-edit.o `test -f 'source/edit.c' || echo '$(srcdir)/'`source/edit.c @am__fastdepCC_TRUE@ mv -f source/$(DEPDIR)/a68g-edit.Tpo source/$(DEPDIR)/a68g-edit.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ source='source/edit.c' object='source/a68g-edit.o' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o source/a68g-edit.o `test -f 'source/edit.c' || echo '$(srcdir)/'`source/edit.c source/a68g-edit.obj: source/edit.c @am__fastdepCC_TRUE@ $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT source/a68g-edit.obj -MD -MP -MF source/$(DEPDIR)/a68g-edit.Tpo -c -o source/a68g-edit.obj `if test -f 'source/edit.c'; then $(CYGPATH_W) 'source/edit.c'; else $(CYGPATH_W) '$(srcdir)/source/edit.c'; fi` @am__fastdepCC_TRUE@ mv -f source/$(DEPDIR)/a68g-edit.Tpo source/$(DEPDIR)/a68g-edit.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ source='source/edit.c' object='source/a68g-edit.obj' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o source/a68g-edit.obj `if test -f 'source/edit.c'; then $(CYGPATH_W) 'source/edit.c'; else $(CYGPATH_W) '$(srcdir)/source/edit.c'; fi` install-man1: $(man1_MANS) $(man_MANS) @$(NORMAL_INSTALL) test -z "$(man1dir)" || $(MKDIR_P) "$(DESTDIR)$(man1dir)" @list='$(man1_MANS) $(dist_man1_MANS) $(nodist_man1_MANS)'; \ l2='$(man_MANS) $(dist_man_MANS) $(nodist_man_MANS)'; \ for i in $$l2; do \ case "$$i" in \ *.1*) list="$$list $$i" ;; \ esac; \ done; \ for i in $$list; do \ if test -f $(srcdir)/$$i; then file=$(srcdir)/$$i; \ else file=$$i; fi; \ ext=`echo $$i | sed -e 's/^.*\\.//'`; \ case "$$ext" in \ 1*) ;; \ *) ext='1' ;; \ esac; \ inst=`echo $$i | sed -e 's/\\.[0-9a-z]*$$//'`; \ inst=`echo $$inst | sed -e 's/^.*\///'`; \ inst=`echo $$inst | sed '$(transform)'`.$$ext; \ echo " $(INSTALL_DATA) '$$file' '$(DESTDIR)$(man1dir)/$$inst'"; \ $(INSTALL_DATA) "$$file" "$(DESTDIR)$(man1dir)/$$inst"; \ done uninstall-man1: @$(NORMAL_UNINSTALL) @list='$(man1_MANS) $(dist_man1_MANS) $(nodist_man1_MANS)'; \ l2='$(man_MANS) $(dist_man_MANS) $(nodist_man_MANS)'; \ for i in $$l2; do \ case "$$i" in \ *.1*) list="$$list $$i" ;; \ esac; \ done; \ for i in $$list; do \ ext=`echo $$i | sed -e 's/^.*\\.//'`; \ case "$$ext" in \ 1*) ;; \ *) ext='1' ;; \ esac; \ inst=`echo $$i | sed -e 's/\\.[0-9a-z]*$$//'`; \ inst=`echo $$inst | sed -e 's/^.*\///'`; \ inst=`echo $$inst | sed '$(transform)'`.$$ext; \ echo " rm -f '$(DESTDIR)$(man1dir)/$$inst'"; \ rm -f "$(DESTDIR)$(man1dir)/$$inst"; \ done install-docDATA: $(doc_DATA) @$(NORMAL_INSTALL) test -z "$(docdir)" || $(MKDIR_P) "$(DESTDIR)$(docdir)" @list='$(doc_DATA)'; for p in $$list; do \ if test -f "$$p"; then d=; else d="$(srcdir)/"; fi; \ f=$(am__strip_dir) \ echo " $(docDATA_INSTALL) '$$d$$p' '$(DESTDIR)$(docdir)/$$f'"; \ $(docDATA_INSTALL) "$$d$$p" "$(DESTDIR)$(docdir)/$$f"; \ done uninstall-docDATA: @$(NORMAL_UNINSTALL) @list='$(doc_DATA)'; for p in $$list; do \ f=$(am__strip_dir) \ echo " rm -f '$(DESTDIR)$(docdir)/$$f'"; \ rm -f "$(DESTDIR)$(docdir)/$$f"; \ done install-pkgincludeHEADERS: $(pkginclude_HEADERS) @$(NORMAL_INSTALL) test -z "$(pkgincludedir)" || $(MKDIR_P) "$(DESTDIR)$(pkgincludedir)" @list='$(pkginclude_HEADERS)'; for p in $$list; do \ if test -f "$$p"; then d=; else d="$(srcdir)/"; fi; \ f=$(am__strip_dir) \ echo " $(pkgincludeHEADERS_INSTALL) '$$d$$p' '$(DESTDIR)$(pkgincludedir)/$$f'"; \ $(pkgincludeHEADERS_INSTALL) "$$d$$p" "$(DESTDIR)$(pkgincludedir)/$$f"; \ done uninstall-pkgincludeHEADERS: @$(NORMAL_UNINSTALL) @list='$(pkginclude_HEADERS)'; for p in $$list; do \ f=$(am__strip_dir) \ echo " rm -f '$(DESTDIR)$(pkgincludedir)/$$f'"; \ rm -f "$(DESTDIR)$(pkgincludedir)/$$f"; \ done ID: $(HEADERS) $(SOURCES) $(LISP) $(TAGS_FILES) list='$(SOURCES) $(HEADERS) $(LISP) $(TAGS_FILES)'; \ unique=`for i in $$list; do \ if test -f "$$i"; then echo $$i; else echo $(srcdir)/$$i; fi; \ done | \ $(AWK) '{ files[$$0] = 1; nonemtpy = 1; } \ END { if (nonempty) { for (i in files) print i; }; }'`; \ mkid -fID $$unique tags: TAGS TAGS: $(HEADERS) $(SOURCES) $(TAGS_DEPENDENCIES) \ $(TAGS_FILES) $(LISP) tags=; \ here=`pwd`; \ list='$(SOURCES) $(HEADERS) $(LISP) $(TAGS_FILES)'; \ unique=`for i in $$list; do \ if test -f "$$i"; then echo $$i; else echo $(srcdir)/$$i; fi; \ done | \ $(AWK) '{ files[$$0] = 1; nonempty = 1; } \ END { if (nonempty) { for (i in files) print i; }; }'`; \ if test -z "$(ETAGS_ARGS)$$tags$$unique"; then :; else \ test -n "$$unique" || unique=$$empty_fix; \ $(ETAGS) $(ETAGSFLAGS) $(AM_ETAGSFLAGS) $(ETAGS_ARGS) \ $$tags $$unique; \ fi ctags: CTAGS CTAGS: $(HEADERS) $(SOURCES) $(TAGS_DEPENDENCIES) \ $(TAGS_FILES) $(LISP) tags=; \ list='$(SOURCES) $(HEADERS) $(LISP) $(TAGS_FILES)'; \ unique=`for i in $$list; do \ if test -f "$$i"; then echo $$i; else echo $(srcdir)/$$i; fi; \ done | \ $(AWK) '{ files[$$0] = 1; nonempty = 1; } \ END { if (nonempty) { for (i in files) print i; }; }'`; \ test -z "$(CTAGS_ARGS)$$tags$$unique" \ || $(CTAGS) $(CTAGSFLAGS) $(AM_CTAGSFLAGS) $(CTAGS_ARGS) \ $$tags $$unique GTAGS: here=`$(am__cd) $(top_builddir) && pwd` \ && cd $(top_srcdir) \ && gtags -i $(GTAGS_ARGS) $$here distclean-tags: -rm -f TAGS ID GTAGS GRTAGS GSYMS GPATH tags check-TESTS: $(TESTS) @failed=0; all=0; xfail=0; xpass=0; skip=0; ws='[ ]'; \ srcdir=$(srcdir); export srcdir; \ list=' $(TESTS) '; \ if test -n "$$list"; then \ for tst in $$list; do \ if test -f ./$$tst; then dir=./; \ elif test -f $$tst; then dir=; \ else dir="$(srcdir)/"; fi; \ if $(TESTS_ENVIRONMENT) $${dir}$$tst; then \ all=`expr $$all + 1`; \ case " $(XFAIL_TESTS) " in \ *$$ws$$tst$$ws*) \ xpass=`expr $$xpass + 1`; \ failed=`expr $$failed + 1`; \ echo "XPASS: $$tst"; \ ;; \ *) \ echo "PASS: $$tst"; \ ;; \ esac; \ elif test $$? -ne 77; then \ all=`expr $$all + 1`; \ case " $(XFAIL_TESTS) " in \ *$$ws$$tst$$ws*) \ xfail=`expr $$xfail + 1`; \ echo "XFAIL: $$tst"; \ ;; \ *) \ failed=`expr $$failed + 1`; \ echo "FAIL: $$tst"; \ ;; \ esac; \ else \ skip=`expr $$skip + 1`; \ echo "SKIP: $$tst"; \ fi; \ done; \ if test "$$failed" -eq 0; then \ if test "$$xfail" -eq 0; then \ banner="All $$all tests passed"; \ else \ banner="All $$all tests behaved as expected ($$xfail expected failures)"; \ fi; \ else \ if test "$$xpass" -eq 0; then \ banner="$$failed of $$all tests failed"; \ else \ banner="$$failed of $$all tests did not behave as expected ($$xpass unexpected passes)"; \ fi; \ fi; \ dashes="$$banner"; \ skipped=""; \ if test "$$skip" -ne 0; then \ skipped="($$skip tests were not run)"; \ test `echo "$$skipped" | wc -c` -le `echo "$$banner" | wc -c` || \ dashes="$$skipped"; \ fi; \ report=""; \ if test "$$failed" -ne 0 && test -n "$(PACKAGE_BUGREPORT)"; then \ report="Please report to $(PACKAGE_BUGREPORT)"; \ test `echo "$$report" | wc -c` -le `echo "$$banner" | wc -c` || \ dashes="$$report"; \ fi; \ dashes=`echo "$$dashes" | sed s/./=/g`; \ echo "$$dashes"; \ echo "$$banner"; \ test -z "$$skipped" || echo "$$skipped"; \ test -z "$$report" || echo "$$report"; \ echo "$$dashes"; \ test "$$failed" -eq 0; \ else :; fi distdir: $(DISTFILES) $(am__remove_distdir) test -d $(distdir) || mkdir $(distdir) @srcdirstrip=`echo "$(srcdir)" | sed 's/[].[^$$\\*]/\\\\&/g'`; \ topsrcdirstrip=`echo "$(top_srcdir)" | sed 's/[].[^$$\\*]/\\\\&/g'`; \ list='$(DISTFILES)'; \ dist_files=`for file in $$list; do echo $$file; done | \ sed -e "s|^$$srcdirstrip/||;t" \ -e "s|^$$topsrcdirstrip/|$(top_builddir)/|;t"`; \ case $$dist_files in \ */*) $(MKDIR_P) `echo "$$dist_files" | \ sed '/\//!d;s|^|$(distdir)/|;s,/[^/]*$$,,' | \ sort -u` ;; \ esac; \ for file in $$dist_files; do \ if test -f $$file || test -d $$file; then d=.; else d=$(srcdir); fi; \ if test -d $$d/$$file; then \ dir=`echo "/$$file" | sed -e 's,/[^/]*$$,,'`; \ if test -d $(srcdir)/$$file && test $$d != $(srcdir); then \ cp -pR $(srcdir)/$$file $(distdir)$$dir || exit 1; \ fi; \ cp -pR $$d/$$file $(distdir)$$dir || exit 1; \ else \ test -f $(distdir)/$$file \ || cp -p $$d/$$file $(distdir)/$$file \ || exit 1; \ fi; \ done -find $(distdir) -type d ! -perm -777 -exec chmod a+rwx {} \; -o \ ! -type d ! -perm -444 -links 1 -exec chmod a+r {} \; -o \ ! -type d ! -perm -400 -exec chmod a+r {} \; -o \ ! -type d ! -perm -444 -exec $(install_sh) -c -m a+r {} {} \; \ || chmod -R a+r $(distdir) dist-gzip: distdir tardir=$(distdir) && $(am__tar) | GZIP=$(GZIP_ENV) gzip -c >$(distdir).tar.gz $(am__remove_distdir) dist-bzip2: distdir tardir=$(distdir) && $(am__tar) | bzip2 -9 -c >$(distdir).tar.bz2 $(am__remove_distdir) dist-lzma: distdir tardir=$(distdir) && $(am__tar) | lzma -9 -c >$(distdir).tar.lzma $(am__remove_distdir) dist-tarZ: distdir tardir=$(distdir) && $(am__tar) | compress -c >$(distdir).tar.Z $(am__remove_distdir) dist-shar: distdir shar $(distdir) | GZIP=$(GZIP_ENV) gzip -c >$(distdir).shar.gz $(am__remove_distdir) dist-zip: distdir -rm -f $(distdir).zip zip -rq $(distdir).zip $(distdir) $(am__remove_distdir) dist dist-all: distdir tardir=$(distdir) && $(am__tar) | GZIP=$(GZIP_ENV) gzip -c >$(distdir).tar.gz $(am__remove_distdir) # This target untars the dist file and tries a VPATH configuration. Then # it guarantees that the distribution is self-contained by making another # tarfile. distcheck: dist case '$(DIST_ARCHIVES)' in \ *.tar.gz*) \ GZIP=$(GZIP_ENV) gunzip -c $(distdir).tar.gz | $(am__untar) ;;\ *.tar.bz2*) \ bunzip2 -c $(distdir).tar.bz2 | $(am__untar) ;;\ *.tar.lzma*) \ unlzma -c $(distdir).tar.lzma | $(am__untar) ;;\ *.tar.Z*) \ uncompress -c $(distdir).tar.Z | $(am__untar) ;;\ *.shar.gz*) \ GZIP=$(GZIP_ENV) gunzip -c $(distdir).shar.gz | unshar ;;\ *.zip*) \ unzip $(distdir).zip ;;\ esac chmod -R a-w $(distdir); chmod a+w $(distdir) mkdir $(distdir)/_build mkdir $(distdir)/_inst chmod a-w $(distdir) dc_install_base=`$(am__cd) $(distdir)/_inst && pwd | sed -e 's,^[^:\\/]:[\\/],/,'` \ && dc_destdir="$${TMPDIR-/tmp}/am-dc-$$$$/" \ && cd $(distdir)/_build \ && ../configure --srcdir=.. --prefix="$$dc_install_base" \ $(DISTCHECK_CONFIGURE_FLAGS) \ && $(MAKE) $(AM_MAKEFLAGS) \ && $(MAKE) $(AM_MAKEFLAGS) dvi \ && $(MAKE) $(AM_MAKEFLAGS) check \ && $(MAKE) $(AM_MAKEFLAGS) install \ && $(MAKE) $(AM_MAKEFLAGS) installcheck \ && $(MAKE) $(AM_MAKEFLAGS) uninstall \ && $(MAKE) $(AM_MAKEFLAGS) distuninstallcheck_dir="$$dc_install_base" \ distuninstallcheck \ && chmod -R a-w "$$dc_install_base" \ && ({ \ (cd ../.. && umask 077 && mkdir "$$dc_destdir") \ && $(MAKE) $(AM_MAKEFLAGS) DESTDIR="$$dc_destdir" install \ && $(MAKE) $(AM_MAKEFLAGS) DESTDIR="$$dc_destdir" uninstall \ && $(MAKE) $(AM_MAKEFLAGS) DESTDIR="$$dc_destdir" \ distuninstallcheck_dir="$$dc_destdir" distuninstallcheck; \ } || { rm -rf "$$dc_destdir"; exit 1; }) \ && rm -rf "$$dc_destdir" \ && $(MAKE) $(AM_MAKEFLAGS) dist \ && rm -rf $(DIST_ARCHIVES) \ && $(MAKE) $(AM_MAKEFLAGS) distcleancheck $(am__remove_distdir) @(echo "$(distdir) archives ready for distribution: "; \ list='$(DIST_ARCHIVES)'; for i in $$list; do echo $$i; done) | \ sed -e 1h -e 1s/./=/g -e 1p -e 1x -e '$$p' -e '$$x' distuninstallcheck: @cd $(distuninstallcheck_dir) \ && test `$(distuninstallcheck_listfiles) | wc -l` -le 1 \ || { echo "ERROR: files left after uninstall:" ; \ if test -n "$(DESTDIR)"; then \ echo " (check DESTDIR support)"; \ fi ; \ $(distuninstallcheck_listfiles) ; \ exit 1; } >&2 distcleancheck: distclean @if test '$(srcdir)' = . ; then \ echo "ERROR: distcleancheck can only run from a VPATH build" ; \ exit 1 ; \ fi @test `$(distcleancheck_listfiles) | wc -l` -eq 0 \ || { echo "ERROR: files left in build directory after distclean:" ; \ $(distcleancheck_listfiles) ; \ exit 1; } >&2 check-am: all-am $(MAKE) $(AM_MAKEFLAGS) check-TESTS check: check-am all-am: Makefile $(PROGRAMS) $(MANS) $(DATA) $(HEADERS) installdirs: for dir in "$(DESTDIR)$(bindir)" "$(DESTDIR)$(man1dir)" "$(DESTDIR)$(docdir)" "$(DESTDIR)$(pkgincludedir)"; do \ test -z "$$dir" || $(MKDIR_P) "$$dir"; \ done install: install-am install-exec: install-exec-am install-data: install-data-am uninstall: uninstall-am install-am: all-am @$(MAKE) $(AM_MAKEFLAGS) install-exec-am install-data-am installcheck: installcheck-am install-strip: $(MAKE) $(AM_MAKEFLAGS) INSTALL_PROGRAM="$(INSTALL_STRIP_PROGRAM)" \ install_sh_PROGRAM="$(INSTALL_STRIP_PROGRAM)" INSTALL_STRIP_FLAG=-s \ `test -z '$(STRIP)' || \ echo "INSTALL_PROGRAM_ENV=STRIPPROG='$(STRIP)'"` install mostlyclean-generic: clean-generic: distclean-generic: -test -z "$(CONFIG_CLEAN_FILES)" || rm -f $(CONFIG_CLEAN_FILES) -rm -f source/$(DEPDIR)/$(am__dirstamp) -rm -f source/$(am__dirstamp) maintainer-clean-generic: @echo "This command is intended for maintainers to use" @echo "it deletes files that may require special tools to rebuild." clean: clean-am clean-am: clean-binPROGRAMS clean-generic mostlyclean-am distclean: distclean-am -rm -f $(am__CONFIG_DISTCLEAN_FILES) -rm -rf source/$(DEPDIR) -rm -f Makefile distclean-am: clean-am distclean-compile distclean-generic \ distclean-hdr distclean-tags dvi: dvi-am dvi-am: html: html-am info: info-am info-am: install-data-am: install-docDATA install-man install-pkgincludeHEADERS install-dvi: install-dvi-am install-exec-am: install-binPROGRAMS install-html: install-html-am install-info: install-info-am install-man: install-man1 install-pdf: install-pdf-am install-ps: install-ps-am installcheck-am: maintainer-clean: maintainer-clean-am -rm -f $(am__CONFIG_DISTCLEAN_FILES) -rm -rf $(top_srcdir)/autom4te.cache -rm -rf source/$(DEPDIR) -rm -f Makefile maintainer-clean-am: distclean-am maintainer-clean-generic mostlyclean: mostlyclean-am mostlyclean-am: mostlyclean-compile mostlyclean-generic pdf: pdf-am pdf-am: ps: ps-am ps-am: uninstall-am: uninstall-binPROGRAMS uninstall-docDATA uninstall-man \ uninstall-pkgincludeHEADERS uninstall-man: uninstall-man1 .MAKE: install-am install-strip .PHONY: CTAGS GTAGS all all-am am--refresh check check-TESTS check-am \ clean clean-binPROGRAMS clean-generic ctags dist dist-all \ dist-bzip2 dist-gzip dist-lzma dist-shar dist-tarZ dist-zip \ distcheck distclean distclean-compile distclean-generic \ distclean-hdr distclean-tags distcleancheck distdir \ distuninstallcheck dvi dvi-am html html-am info info-am \ install install-am install-binPROGRAMS install-data \ install-data-am install-docDATA install-dvi install-dvi-am \ install-exec install-exec-am install-html install-html-am \ install-info install-info-am install-man install-man1 \ install-pdf install-pdf-am install-pkgincludeHEADERS \ install-ps install-ps-am install-strip installcheck \ installcheck-am installdirs maintainer-clean \ maintainer-clean-generic mostlyclean mostlyclean-compile \ mostlyclean-generic pdf pdf-am ps ps-am tags uninstall \ uninstall-am uninstall-binPROGRAMS uninstall-docDATA \ uninstall-man uninstall-man1 uninstall-pkgincludeHEADERS # Tell versions [3.59,3.63) of GNU make to not export all variables. # Otherwise a system limit (for SysV at least) may be exceeded. .NOEXPORT: algol68g-2.4.1/Makefile.am0000644000175000001440000000176211771657077012142 00000000000000bin_PROGRAMS =a68g a68g_SOURCES = source/a68g.c source/code.c source/environ.c source/genie.c source/gsl.c source/inet.c source/monitor.c source/mp.c source/plotutils.c source/postgresql.c source/pretty.c source/syntax.c source/edit.c a68g_CFLAGS = -DBINDIR='"$(bindir)"' -DINCLUDEDIR='"$(includedir)"' TESTS_ENVIRONMENT=./a68g TESTS=check/check-01.a68 check/check-02.a68 check/check-03.a68 check/check-04.a68 check/check-05.a68 check/check-06.a68 check/check-07.a68 check/check-08.a68 check/check-09.a68 check/check-10.a68 if EXPORT_DYNAMIC a68g_LDFLAGS = -Wl,--export-dynamic else a68g_LDFLAGS = endif pkginclude_HEADERS = source/a68g.h source/a68g-config.h man_MANS = doc/a68g.1 docdir = ${prefix}/doc/@PACKAGE@-@VERSION@ doc_DATA = AUTHORS COPYING NEWS README EXTRA_DIST = $(man_MANS) source/a68g-config.win32.h check/check-01.a68 check/check-02.a68 check/check-03.a68 check/check-04.a68 check/check-05.a68 check/check-06.a68 check/check-07.a68 check/check-08.a68 check/check-09.a68 check/check-10.a68 algol68g-2.4.1/depcomp0000755000175000001440000004271311551405127011443 00000000000000#! /bin/sh # depcomp - compile a program generating dependencies as side-effects scriptversion=2007-03-29.01 # Copyright (C) 1999, 2000, 2003, 2004, 2005, 2006, 2007 Free Software # Foundation, Inc. # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2, or (at your option) # any later version. # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # You should have received a copy of the GNU General Public License # along with this program; if not, write to the Free Software # Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA # 02110-1301, USA. # As a special exception to the GNU General Public License, if you # distribute this file as part of a program that contains a # configuration script generated by Autoconf, you may include it under # the same distribution terms that you use for the rest of that program. # Originally written by Alexandre Oliva . case $1 in '') echo "$0: No command. Try \`$0 --help' for more information." 1>&2 exit 1; ;; -h | --h*) cat <<\EOF Usage: depcomp [--help] [--version] PROGRAM [ARGS] Run PROGRAMS ARGS to compile a file, generating dependencies as side-effects. Environment variables: depmode Dependency tracking mode. source Source file read by `PROGRAMS ARGS'. object Object file output by `PROGRAMS ARGS'. DEPDIR directory where to store dependencies. depfile Dependency file to output. tmpdepfile Temporary file to use when outputing dependencies. libtool Whether libtool is used (yes/no). Report bugs to . EOF exit $? ;; -v | --v*) echo "depcomp $scriptversion" exit $? ;; esac if test -z "$depmode" || test -z "$source" || test -z "$object"; then echo "depcomp: Variables source, object and depmode must be set" 1>&2 exit 1 fi # Dependencies for sub/bar.o or sub/bar.obj go into sub/.deps/bar.Po. depfile=${depfile-`echo "$object" | sed 's|[^\\/]*$|'${DEPDIR-.deps}'/&|;s|\.\([^.]*\)$|.P\1|;s|Pobj$|Po|'`} tmpdepfile=${tmpdepfile-`echo "$depfile" | sed 's/\.\([^.]*\)$/.T\1/'`} rm -f "$tmpdepfile" # Some modes work just like other modes, but use different flags. We # parameterize here, but still list the modes in the big case below, # to make depend.m4 easier to write. Note that we *cannot* use a case # here, because this file can only contain one case statement. if test "$depmode" = hp; then # HP compiler uses -M and no extra arg. gccflag=-M depmode=gcc fi if test "$depmode" = dashXmstdout; then # This is just like dashmstdout with a different argument. dashmflag=-xM depmode=dashmstdout fi case "$depmode" in gcc3) ## gcc 3 implements dependency tracking that does exactly what ## we want. Yay! Note: for some reason libtool 1.4 doesn't like ## it if -MD -MP comes after the -MF stuff. Hmm. ## Unfortunately, FreeBSD c89 acceptance of flags depends upon ## the command line argument order; so add the flags where they ## appear in depend2.am. Note that the slowdown incurred here ## affects only configure: in makefiles, %FASTDEP% shortcuts this. for arg do case $arg in -c) set fnord "$@" -MT "$object" -MD -MP -MF "$tmpdepfile" "$arg" ;; *) set fnord "$@" "$arg" ;; esac shift # fnord shift # $arg done "$@" stat=$? if test $stat -eq 0; then : else rm -f "$tmpdepfile" exit $stat fi mv "$tmpdepfile" "$depfile" ;; gcc) ## There are various ways to get dependency output from gcc. Here's ## why we pick this rather obscure method: ## - Don't want to use -MD because we'd like the dependencies to end ## up in a subdir. Having to rename by hand is ugly. ## (We might end up doing this anyway to support other compilers.) ## - The DEPENDENCIES_OUTPUT environment variable makes gcc act like ## -MM, not -M (despite what the docs say). ## - Using -M directly means running the compiler twice (even worse ## than renaming). if test -z "$gccflag"; then gccflag=-MD, fi "$@" -Wp,"$gccflag$tmpdepfile" stat=$? if test $stat -eq 0; then : else rm -f "$tmpdepfile" exit $stat fi rm -f "$depfile" echo "$object : \\" > "$depfile" alpha=ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz ## The second -e expression handles DOS-style file names with drive letters. sed -e 's/^[^:]*: / /' \ -e 's/^['$alpha']:\/[^:]*: / /' < "$tmpdepfile" >> "$depfile" ## This next piece of magic avoids the `deleted header file' problem. ## The problem is that when a header file which appears in a .P file ## is deleted, the dependency causes make to die (because there is ## typically no way to rebuild the header). We avoid this by adding ## dummy dependencies for each header file. Too bad gcc doesn't do ## this for us directly. tr ' ' ' ' < "$tmpdepfile" | ## Some versions of gcc put a space before the `:'. On the theory ## that the space means something, we add a space to the output as ## well. ## Some versions of the HPUX 10.20 sed can't process this invocation ## correctly. Breaking it into two sed invocations is a workaround. sed -e 's/^\\$//' -e '/^$/d' -e '/:$/d' | sed -e 's/$/ :/' >> "$depfile" rm -f "$tmpdepfile" ;; hp) # This case exists only to let depend.m4 do its work. It works by # looking at the text of this script. This case will never be run, # since it is checked for above. exit 1 ;; sgi) if test "$libtool" = yes; then "$@" "-Wp,-MDupdate,$tmpdepfile" else "$@" -MDupdate "$tmpdepfile" fi stat=$? if test $stat -eq 0; then : else rm -f "$tmpdepfile" exit $stat fi rm -f "$depfile" if test -f "$tmpdepfile"; then # yes, the sourcefile depend on other files echo "$object : \\" > "$depfile" # Clip off the initial element (the dependent). Don't try to be # clever and replace this with sed code, as IRIX sed won't handle # lines with more than a fixed number of characters (4096 in # IRIX 6.2 sed, 8192 in IRIX 6.5). We also remove comment lines; # the IRIX cc adds comments like `#:fec' to the end of the # dependency line. tr ' ' ' ' < "$tmpdepfile" \ | sed -e 's/^.*\.o://' -e 's/#.*$//' -e '/^$/ d' | \ tr ' ' ' ' >> $depfile echo >> $depfile # The second pass generates a dummy entry for each header file. tr ' ' ' ' < "$tmpdepfile" \ | sed -e 's/^.*\.o://' -e 's/#.*$//' -e '/^$/ d' -e 's/$/:/' \ >> $depfile else # The sourcefile does not contain any dependencies, so just # store a dummy comment line, to avoid errors with the Makefile # "include basename.Plo" scheme. echo "#dummy" > "$depfile" fi rm -f "$tmpdepfile" ;; aix) # The C for AIX Compiler uses -M and outputs the dependencies # in a .u file. In older versions, this file always lives in the # current directory. Also, the AIX compiler puts `$object:' at the # start of each line; $object doesn't have directory information. # Version 6 uses the directory in both cases. dir=`echo "$object" | sed -e 's|/[^/]*$|/|'` test "x$dir" = "x$object" && dir= base=`echo "$object" | sed -e 's|^.*/||' -e 's/\.o$//' -e 's/\.lo$//'` if test "$libtool" = yes; then tmpdepfile1=$dir$base.u tmpdepfile2=$base.u tmpdepfile3=$dir.libs/$base.u "$@" -Wc,-M else tmpdepfile1=$dir$base.u tmpdepfile2=$dir$base.u tmpdepfile3=$dir$base.u "$@" -M fi stat=$? if test $stat -eq 0; then : else rm -f "$tmpdepfile1" "$tmpdepfile2" "$tmpdepfile3" exit $stat fi for tmpdepfile in "$tmpdepfile1" "$tmpdepfile2" "$tmpdepfile3" do test -f "$tmpdepfile" && break done if test -f "$tmpdepfile"; then # Each line is of the form `foo.o: dependent.h'. # Do two passes, one to just change these to # `$object: dependent.h' and one to simply `dependent.h:'. sed -e "s,^.*\.[a-z]*:,$object:," < "$tmpdepfile" > "$depfile" # That's a tab and a space in the []. sed -e 's,^.*\.[a-z]*:[ ]*,,' -e 's,$,:,' < "$tmpdepfile" >> "$depfile" else # The sourcefile does not contain any dependencies, so just # store a dummy comment line, to avoid errors with the Makefile # "include basename.Plo" scheme. echo "#dummy" > "$depfile" fi rm -f "$tmpdepfile" ;; icc) # Intel's C compiler understands `-MD -MF file'. However on # icc -MD -MF foo.d -c -o sub/foo.o sub/foo.c # ICC 7.0 will fill foo.d with something like # foo.o: sub/foo.c # foo.o: sub/foo.h # which is wrong. We want: # sub/foo.o: sub/foo.c # sub/foo.o: sub/foo.h # sub/foo.c: # sub/foo.h: # ICC 7.1 will output # foo.o: sub/foo.c sub/foo.h # and will wrap long lines using \ : # foo.o: sub/foo.c ... \ # sub/foo.h ... \ # ... "$@" -MD -MF "$tmpdepfile" stat=$? if test $stat -eq 0; then : else rm -f "$tmpdepfile" exit $stat fi rm -f "$depfile" # Each line is of the form `foo.o: dependent.h', # or `foo.o: dep1.h dep2.h \', or ` dep3.h dep4.h \'. # Do two passes, one to just change these to # `$object: dependent.h' and one to simply `dependent.h:'. sed "s,^[^:]*:,$object :," < "$tmpdepfile" > "$depfile" # Some versions of the HPUX 10.20 sed can't process this invocation # correctly. Breaking it into two sed invocations is a workaround. sed 's,^[^:]*: \(.*\)$,\1,;s/^\\$//;/^$/d;/:$/d' < "$tmpdepfile" | sed -e 's/$/ :/' >> "$depfile" rm -f "$tmpdepfile" ;; hp2) # The "hp" stanza above does not work with aCC (C++) and HP's ia64 # compilers, which have integrated preprocessors. The correct option # to use with these is +Maked; it writes dependencies to a file named # 'foo.d', which lands next to the object file, wherever that # happens to be. # Much of this is similar to the tru64 case; see comments there. dir=`echo "$object" | sed -e 's|/[^/]*$|/|'` test "x$dir" = "x$object" && dir= base=`echo "$object" | sed -e 's|^.*/||' -e 's/\.o$//' -e 's/\.lo$//'` if test "$libtool" = yes; then tmpdepfile1=$dir$base.d tmpdepfile2=$dir.libs/$base.d "$@" -Wc,+Maked else tmpdepfile1=$dir$base.d tmpdepfile2=$dir$base.d "$@" +Maked fi stat=$? if test $stat -eq 0; then : else rm -f "$tmpdepfile1" "$tmpdepfile2" exit $stat fi for tmpdepfile in "$tmpdepfile1" "$tmpdepfile2" do test -f "$tmpdepfile" && break done if test -f "$tmpdepfile"; then sed -e "s,^.*\.[a-z]*:,$object:," "$tmpdepfile" > "$depfile" # Add `dependent.h:' lines. sed -ne '2,${; s/^ *//; s/ \\*$//; s/$/:/; p;}' "$tmpdepfile" >> "$depfile" else echo "#dummy" > "$depfile" fi rm -f "$tmpdepfile" "$tmpdepfile2" ;; tru64) # The Tru64 compiler uses -MD to generate dependencies as a side # effect. `cc -MD -o foo.o ...' puts the dependencies into `foo.o.d'. # At least on Alpha/Redhat 6.1, Compaq CCC V6.2-504 seems to put # dependencies in `foo.d' instead, so we check for that too. # Subdirectories are respected. dir=`echo "$object" | sed -e 's|/[^/]*$|/|'` test "x$dir" = "x$object" && dir= base=`echo "$object" | sed -e 's|^.*/||' -e 's/\.o$//' -e 's/\.lo$//'` if test "$libtool" = yes; then # With Tru64 cc, shared objects can also be used to make a # static library. This mechanism is used in libtool 1.4 series to # handle both shared and static libraries in a single compilation. # With libtool 1.4, dependencies were output in $dir.libs/$base.lo.d. # # With libtool 1.5 this exception was removed, and libtool now # generates 2 separate objects for the 2 libraries. These two # compilations output dependencies in $dir.libs/$base.o.d and # in $dir$base.o.d. We have to check for both files, because # one of the two compilations can be disabled. We should prefer # $dir$base.o.d over $dir.libs/$base.o.d because the latter is # automatically cleaned when .libs/ is deleted, while ignoring # the former would cause a distcleancheck panic. tmpdepfile1=$dir.libs/$base.lo.d # libtool 1.4 tmpdepfile2=$dir$base.o.d # libtool 1.5 tmpdepfile3=$dir.libs/$base.o.d # libtool 1.5 tmpdepfile4=$dir.libs/$base.d # Compaq CCC V6.2-504 "$@" -Wc,-MD else tmpdepfile1=$dir$base.o.d tmpdepfile2=$dir$base.d tmpdepfile3=$dir$base.d tmpdepfile4=$dir$base.d "$@" -MD fi stat=$? if test $stat -eq 0; then : else rm -f "$tmpdepfile1" "$tmpdepfile2" "$tmpdepfile3" "$tmpdepfile4" exit $stat fi for tmpdepfile in "$tmpdepfile1" "$tmpdepfile2" "$tmpdepfile3" "$tmpdepfile4" do test -f "$tmpdepfile" && break done if test -f "$tmpdepfile"; then sed -e "s,^.*\.[a-z]*:,$object:," < "$tmpdepfile" > "$depfile" # That's a tab and a space in the []. sed -e 's,^.*\.[a-z]*:[ ]*,,' -e 's,$,:,' < "$tmpdepfile" >> "$depfile" else echo "#dummy" > "$depfile" fi rm -f "$tmpdepfile" ;; #nosideeffect) # This comment above is used by automake to tell side-effect # dependency tracking mechanisms from slower ones. dashmstdout) # Important note: in order to support this mode, a compiler *must* # always write the preprocessed file to stdout, regardless of -o. "$@" || exit $? # Remove the call to Libtool. if test "$libtool" = yes; then while test $1 != '--mode=compile'; do shift done shift fi # Remove `-o $object'. IFS=" " for arg do case $arg in -o) shift ;; $object) shift ;; *) set fnord "$@" "$arg" shift # fnord shift # $arg ;; esac done test -z "$dashmflag" && dashmflag=-M # Require at least two characters before searching for `:' # in the target name. This is to cope with DOS-style filenames: # a dependency such as `c:/foo/bar' could be seen as target `c' otherwise. "$@" $dashmflag | sed 's:^[ ]*[^: ][^:][^:]*\:[ ]*:'"$object"'\: :' > "$tmpdepfile" rm -f "$depfile" cat < "$tmpdepfile" > "$depfile" tr ' ' ' ' < "$tmpdepfile" | \ ## Some versions of the HPUX 10.20 sed can't process this invocation ## correctly. Breaking it into two sed invocations is a workaround. sed -e 's/^\\$//' -e '/^$/d' -e '/:$/d' | sed -e 's/$/ :/' >> "$depfile" rm -f "$tmpdepfile" ;; dashXmstdout) # This case only exists to satisfy depend.m4. It is never actually # run, as this mode is specially recognized in the preamble. exit 1 ;; makedepend) "$@" || exit $? # Remove any Libtool call if test "$libtool" = yes; then while test $1 != '--mode=compile'; do shift done shift fi # X makedepend shift cleared=no for arg in "$@"; do case $cleared in no) set ""; shift cleared=yes ;; esac case "$arg" in -D*|-I*) set fnord "$@" "$arg"; shift ;; # Strip any option that makedepend may not understand. Remove # the object too, otherwise makedepend will parse it as a source file. -*|$object) ;; *) set fnord "$@" "$arg"; shift ;; esac done obj_suffix="`echo $object | sed 's/^.*\././'`" touch "$tmpdepfile" ${MAKEDEPEND-makedepend} -o"$obj_suffix" -f"$tmpdepfile" "$@" rm -f "$depfile" cat < "$tmpdepfile" > "$depfile" sed '1,2d' "$tmpdepfile" | tr ' ' ' ' | \ ## Some versions of the HPUX 10.20 sed can't process this invocation ## correctly. Breaking it into two sed invocations is a workaround. sed -e 's/^\\$//' -e '/^$/d' -e '/:$/d' | sed -e 's/$/ :/' >> "$depfile" rm -f "$tmpdepfile" "$tmpdepfile".bak ;; cpp) # Important note: in order to support this mode, a compiler *must* # always write the preprocessed file to stdout. "$@" || exit $? # Remove the call to Libtool. if test "$libtool" = yes; then while test $1 != '--mode=compile'; do shift done shift fi # Remove `-o $object'. IFS=" " for arg do case $arg in -o) shift ;; $object) shift ;; *) set fnord "$@" "$arg" shift # fnord shift # $arg ;; esac done "$@" -E | sed -n -e '/^# [0-9][0-9]* "\([^"]*\)".*/ s:: \1 \\:p' \ -e '/^#line [0-9][0-9]* "\([^"]*\)".*/ s:: \1 \\:p' | sed '$ s: \\$::' > "$tmpdepfile" rm -f "$depfile" echo "$object : \\" > "$depfile" cat < "$tmpdepfile" >> "$depfile" sed < "$tmpdepfile" '/^$/d;s/^ //;s/ \\$//;s/$/ :/' >> "$depfile" rm -f "$tmpdepfile" ;; msvisualcpp) # Important note: in order to support this mode, a compiler *must* # always write the preprocessed file to stdout, regardless of -o, # because we must use -o when running libtool. "$@" || exit $? IFS=" " for arg do case "$arg" in "-Gm"|"/Gm"|"-Gi"|"/Gi"|"-ZI"|"/ZI") set fnord "$@" shift shift ;; *) set fnord "$@" "$arg" shift shift ;; esac done "$@" -E | sed -n '/^#line [0-9][0-9]* "\([^"]*\)"/ s::echo "`cygpath -u \\"\1\\"`":p' | sort | uniq > "$tmpdepfile" rm -f "$depfile" echo "$object : \\" > "$depfile" . "$tmpdepfile" | sed 's% %\\ %g' | sed -n '/^\(.*\)$/ s:: \1 \\:p' >> "$depfile" echo " " >> "$depfile" . "$tmpdepfile" | sed 's% %\\ %g' | sed -n '/^\(.*\)$/ s::\1\::p' >> "$depfile" rm -f "$tmpdepfile" ;; none) exec "$@" ;; *) echo "Unknown depmode $depmode" 1>&2 exit 1 ;; esac exit 0 # Local Variables: # mode: shell-script # sh-indentation: 2 # eval: (add-hook 'write-file-hooks 'time-stamp) # time-stamp-start: "scriptversion=" # time-stamp-format: "%:y-%02m-%02d.%02H" # time-stamp-end: "$" # End: algol68g-2.4.1/doc/0000777000175000001440000000000011771660256010722 500000000000000algol68g-2.4.1/doc/a68g.10000644000175000001440000001561611771657235011501 00000000000000.Dd June 24, 2012 .Dt A68G 1 PRM .Os LINUX . .Sh NAME a68g \- Algol 68 Genie, an Algol 68 compiler-interpreter . .Sh SYNOPSIS a68g .Op Fl -apropos | -help | -info Ar [string] .Op Fl -assertions | Fl -no-assertions .Op Fl -backtrace | Fl -no-backtrace .Op Fl -brackets .Op Fl -check | Fl -no-run .Op Fl -compile | Fl -no-compile .Op Fl -clock .Op Fl -debug | Fl -monitor .Op Fl -echo Ar string .Op Fl -execute Ar unit | -x Ar unit .Op Fl -exit | Fl - .Op Fl -extensive .Op Fl f | Fl -file Ar string .Op Fl -frame Ar number .Op Fl -handles Ar number .Op Fl -heap Ar number .Op Fl -listing .Op Fl -moids .Op Fl O | Fl O0 | Fl O1 | Fl O2 | Fl O3 .Op Fl -object | Fl -no-object .Op Fl -overhead Ar number .Op Fl -optimise | Fl -no-optimise .Op Fl -pedantic .Op Fl -portcheck | -no-portcheck .Op Fl -pragmats | Fl -no-pragmats .Op Fl -precision Ar number .Op Fl -prelude-listing .Op Fl -pretty-print .Op Fl -print Ar unit | -p Ar unit .Op Fl -quiet .Op Fl -quote-stropping .Op Fl -reductions .Op Fl -rerun .Op Fl -run .Op Fl -script Ar string .Op Fl -source | Fl -no-source .Op Fl -stack Ar number .Op Fl -statistics .Op Fl -strict .Op Fl -terminal .Op Fl -time-limit Ar number .Op Fl -trace | Fl -no-trace .Op Fl -tree | Fl -no-tree .Op Fl -unused .Op Fl -upper-stropping .Op Fl -verbose .Op Fl -version .Op Fl -warnings | Fl -no-warnings .Op Fl -xref | Fl -no-xref .Ar filename . .Sh DESCRIPTION Algol 68 Genie (Algol68G) is an Algol 68 compiler-interpreter. It can be used for executing Algol 68 programs or scripts. Algol 68 is a rather lean orthogonal general-purpose language that is a beautiful means for denoting algorithms. Algol 68 was designed as a general-purpose programming language by IFIP Working Group 2.1 (Algorithmic Languages and Calculi) that has continuing responsibility for Algol 60 and Algol 68. .Pp Algol 68 Genie and its documentation can be obtained from .Pp http://jmvdveer.home.xs4all.nl/ . .Sh OPTIONS Options are passed to a68g either from the file .a68g.rc in the working directory, the environment variable A68G_OPTIONS, the command-line or from pragmats. .Pp Option precedence is as follows: pragmat options supersede command-line options, command-line options supersede options in environment variable A68G_OPTIONS, A68G_OPTIONS supersedes options in .a68g.rc. .Pp Listing options, tracing options and -pragmat, -nopragmat, take their effect when they are encountered in a left-to-right pass of the program text, and can thus be used, for example, to generate a cross reference for a particular part of the program. .Pp Where numeric arguments are required, suffices k, M or G are allowed for multiplication with 2 ** 10, 2 ** 20 or 2 ** 30 respectively. .Bl -tag -width Ds . .It Fl -apropos | -help | -info Ar [string] Print info on options if string is omitted, or print info on string otherwise. . .It Fl -assertions | Fl -no-assertions Control elaboration of assertions. . .It Fl -backtrace | Fl -no-backtrace Control whether a stack backtrace is done in case a runtime-error occurs. . .It Fl -brackets Consider [ .. ] and { .. } as being equivalent to ( .. ). Traditional Algol 68 syntax allows ( .. ) to replace [ .. ] in bounds and slices. . .It Fl -check | Fl -no-run Check syntax only, the interpreter does not start. . .It Fl -clock Report execution time excluding time needed for compilation. . .It Fl -compile | -no-compile Switch compilation of units on or off. Compilation omits many of the runtime checks offered by the interpreter proper. The program is not executed and a shell script is generated combining source code and its shared library. This shell script can be used as a pseudo-executable. . .It Fl -debug | Fl -monitor Start in the monitor. Invoke the monitor in case a runtime-error occurs; the program will pause in the monitor on the line that contains the error. . .It Fl -echo Ar string Echo string to standout. . .It Fl -execute Ar unit | Fl -x Ar unit Execute the Algol 68 unit. In this way one-liners can be executed from the command line. . .It Fl -exit | - Ignore further options. . .It Fl -extensive Generate an extensive listing. . .It Fl f | -file Ar string Accept string as filename in case it conflicts with shell syntax. . .It Fl -frame Ar number Set the frame stack size to .Ar number bytes. . .It Fl -handles Ar number Set the handle space size to .Ar number bytes. . .It Fl -heap Ar number Set the heap size to .Ar number bytes. . .It Fl -listing Generate a concise listing. . .It Fl -moids Generate an overview of modes in the listing file. . .It Fl -object | Fl -no-object Control the listing of C code in the listing file. . .It Fl -optimise | -no-optimise Switch compilation of units on or off. Compilation omits many of the runtime checks offered by the interpreter proper. This option is equivalent to -O2. . .It Fl O | O0 | O1 | O2 | O3 Switch compilation of units on and pass the option to the back-end C compiler to set the optimiser level. . .It Fl -overhead Ar number Set overhead for stack checking. . .It Fl -pedantic Equivalent to --warnings --portcheck . .It Fl -portcheck | Fl -no-portcheck Enable or disable portability warning messages. . .It Fl -pragmats | Fl -no-pragmats Control elaboration of pragmats. . .It Fl -precision Ar number Set the precision for LONG LONG modes to .Ar number significant digits. . .It Fl -prelude-listing Generate a listing of preludes. . .It Fl -pretty-print Pretty-print the source file. . .It Fl -print Ar unit | Fl -p Ar unit Print the value yielded by the Algol 68 unit. In this way one-liners can be executed from the command line. . .It Fl -quiet Suppress all warning messages. . .It Fl -quote-stropping Use quote stropping. . .It Fl -reductions Print reductions made by the parser. . .It Fl -rerun Use compiled code of a previous run. . .It Fl -run Override the --no-run option. . .It Fl -script Ar string Takes string as source file name and skips further option processing so these can be handled by the script. . .It Fl -source | Fl -no-source Control the listing of source lines in the listing file. . .It Fl -stack Ar number Set the stack size to .Ar number bytes. . .It Fl -statistics Generate statistics in the listing file. . .It Fl -strict Ignores extensions to Algol 68 syntax. . .It Fl -time-limit Ar number Interrupt the interpreter after .Ar number seconds, generating a time limit exceeded error. . .It Fl -trace | Fl -no-trace Control tracing of the running program. . .It Fl -tree | Fl -no-tree Control listing of the syntax tree in the listing file. . .It Fl -unused Generate an overview of unused tags in the listing file. . .It Fl -upper-stropping Use upper stropping, which is the default stropping regime. . .It Fl -verbose Use verbose mode. . .It Fl -version Print the version of the running image of a68g. . .It Fl -warnings | Fl -no-warnings Enable warning messages or suppress suppressible warning messages. . .It Fl -xref | Fl -no-xref Control generation of a cross-reference in the listing file. . .El . .Sh AUTHOR Author of Algol 68 Genie is Marcel van der Veer . algol68g-2.4.1/missing0000755000175000001440000002557711551405127011476 00000000000000#! /bin/sh # Common stub for a few missing GNU programs while installing. scriptversion=2006-05-10.23 # Copyright (C) 1996, 1997, 1999, 2000, 2002, 2003, 2004, 2005, 2006 # Free Software Foundation, Inc. # Originally by Fran,cois Pinard , 1996. # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2, or (at your option) # any later version. # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # You should have received a copy of the GNU General Public License # along with this program; if not, write to the Free Software # Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA # 02110-1301, USA. # As a special exception to the GNU General Public License, if you # distribute this file as part of a program that contains a # configuration script generated by Autoconf, you may include it under # the same distribution terms that you use for the rest of that program. if test $# -eq 0; then echo 1>&2 "Try \`$0 --help' for more information" exit 1 fi run=: sed_output='s/.* --output[ =]\([^ ]*\).*/\1/p' sed_minuso='s/.* -o \([^ ]*\).*/\1/p' # In the cases where this matters, `missing' is being run in the # srcdir already. if test -f configure.ac; then configure_ac=configure.ac else configure_ac=configure.in fi msg="missing on your system" case $1 in --run) # Try to run requested program, and just exit if it succeeds. run= shift "$@" && exit 0 # Exit code 63 means version mismatch. This often happens # when the user try to use an ancient version of a tool on # a file that requires a minimum version. In this case we # we should proceed has if the program had been absent, or # if --run hadn't been passed. if test $? = 63; then run=: msg="probably too old" fi ;; -h|--h|--he|--hel|--help) echo "\ $0 [OPTION]... PROGRAM [ARGUMENT]... Handle \`PROGRAM [ARGUMENT]...' for when PROGRAM is missing, or return an error status if there is no known handling for PROGRAM. Options: -h, --help display this help and exit -v, --version output version information and exit --run try to run the given command, and emulate it if it fails Supported PROGRAM values: aclocal touch file \`aclocal.m4' autoconf touch file \`configure' autoheader touch file \`config.h.in' autom4te touch the output file, or create a stub one automake touch all \`Makefile.in' files bison create \`y.tab.[ch]', if possible, from existing .[ch] flex create \`lex.yy.c', if possible, from existing .c help2man touch the output file lex create \`lex.yy.c', if possible, from existing .c makeinfo touch the output file tar try tar, gnutar, gtar, then tar without non-portable flags yacc create \`y.tab.[ch]', if possible, from existing .[ch] Send bug reports to ." exit $? ;; -v|--v|--ve|--ver|--vers|--versi|--versio|--version) echo "missing $scriptversion (GNU Automake)" exit $? ;; -*) echo 1>&2 "$0: Unknown \`$1' option" echo 1>&2 "Try \`$0 --help' for more information" exit 1 ;; esac # Now exit if we have it, but it failed. Also exit now if we # don't have it and --version was passed (most likely to detect # the program). case $1 in lex|yacc) # Not GNU programs, they don't have --version. ;; tar) if test -n "$run"; then echo 1>&2 "ERROR: \`tar' requires --run" exit 1 elif test "x$2" = "x--version" || test "x$2" = "x--help"; then exit 1 fi ;; *) if test -z "$run" && ($1 --version) > /dev/null 2>&1; then # We have it, but it failed. exit 1 elif test "x$2" = "x--version" || test "x$2" = "x--help"; then # Could not run --version or --help. This is probably someone # running `$TOOL --version' or `$TOOL --help' to check whether # $TOOL exists and not knowing $TOOL uses missing. exit 1 fi ;; esac # If it does not exist, or fails to run (possibly an outdated version), # try to emulate it. case $1 in aclocal*) echo 1>&2 "\ WARNING: \`$1' is $msg. You should only need it if you modified \`acinclude.m4' or \`${configure_ac}'. You might want to install the \`Automake' and \`Perl' packages. Grab them from any GNU archive site." touch aclocal.m4 ;; autoconf) echo 1>&2 "\ WARNING: \`$1' is $msg. You should only need it if you modified \`${configure_ac}'. You might want to install the \`Autoconf' and \`GNU m4' packages. Grab them from any GNU archive site." touch configure ;; autoheader) echo 1>&2 "\ WARNING: \`$1' is $msg. You should only need it if you modified \`acconfig.h' or \`${configure_ac}'. You might want to install the \`Autoconf' and \`GNU m4' packages. Grab them from any GNU archive site." files=`sed -n 's/^[ ]*A[CM]_CONFIG_HEADER(\([^)]*\)).*/\1/p' ${configure_ac}` test -z "$files" && files="config.h" touch_files= for f in $files; do case $f in *:*) touch_files="$touch_files "`echo "$f" | sed -e 's/^[^:]*://' -e 's/:.*//'`;; *) touch_files="$touch_files $f.in";; esac done touch $touch_files ;; automake*) echo 1>&2 "\ WARNING: \`$1' is $msg. You should only need it if you modified \`Makefile.am', \`acinclude.m4' or \`${configure_ac}'. You might want to install the \`Automake' and \`Perl' packages. Grab them from any GNU archive site." find . -type f -name Makefile.am -print | sed 's/\.am$/.in/' | while read f; do touch "$f"; done ;; autom4te) echo 1>&2 "\ WARNING: \`$1' is needed, but is $msg. You might have modified some files without having the proper tools for further handling them. You can get \`$1' as part of \`Autoconf' from any GNU archive site." file=`echo "$*" | sed -n "$sed_output"` test -z "$file" && file=`echo "$*" | sed -n "$sed_minuso"` if test -f "$file"; then touch $file else test -z "$file" || exec >$file echo "#! /bin/sh" echo "# Created by GNU Automake missing as a replacement of" echo "# $ $@" echo "exit 0" chmod +x $file exit 1 fi ;; bison|yacc) echo 1>&2 "\ WARNING: \`$1' $msg. You should only need it if you modified a \`.y' file. You may need the \`Bison' package in order for those modifications to take effect. You can get \`Bison' from any GNU archive site." rm -f y.tab.c y.tab.h if test $# -ne 1; then eval LASTARG="\${$#}" case $LASTARG in *.y) SRCFILE=`echo "$LASTARG" | sed 's/y$/c/'` if test -f "$SRCFILE"; then cp "$SRCFILE" y.tab.c fi SRCFILE=`echo "$LASTARG" | sed 's/y$/h/'` if test -f "$SRCFILE"; then cp "$SRCFILE" y.tab.h fi ;; esac fi if test ! -f y.tab.h; then echo >y.tab.h fi if test ! -f y.tab.c; then echo 'main() { return 0; }' >y.tab.c fi ;; lex|flex) echo 1>&2 "\ WARNING: \`$1' is $msg. You should only need it if you modified a \`.l' file. You may need the \`Flex' package in order for those modifications to take effect. You can get \`Flex' from any GNU archive site." rm -f lex.yy.c if test $# -ne 1; then eval LASTARG="\${$#}" case $LASTARG in *.l) SRCFILE=`echo "$LASTARG" | sed 's/l$/c/'` if test -f "$SRCFILE"; then cp "$SRCFILE" lex.yy.c fi ;; esac fi if test ! -f lex.yy.c; then echo 'main() { return 0; }' >lex.yy.c fi ;; help2man) echo 1>&2 "\ WARNING: \`$1' is $msg. You should only need it if you modified a dependency of a manual page. You may need the \`Help2man' package in order for those modifications to take effect. You can get \`Help2man' from any GNU archive site." file=`echo "$*" | sed -n "$sed_output"` test -z "$file" && file=`echo "$*" | sed -n "$sed_minuso"` if test -f "$file"; then touch $file else test -z "$file" || exec >$file echo ".ab help2man is required to generate this page" exit 1 fi ;; makeinfo) echo 1>&2 "\ WARNING: \`$1' is $msg. You should only need it if you modified a \`.texi' or \`.texinfo' file, or any other file indirectly affecting the aspect of the manual. The spurious call might also be the consequence of using a buggy \`make' (AIX, DU, IRIX). You might want to install the \`Texinfo' package or the \`GNU make' package. Grab either from any GNU archive site." # The file to touch is that specified with -o ... file=`echo "$*" | sed -n "$sed_output"` test -z "$file" && file=`echo "$*" | sed -n "$sed_minuso"` if test -z "$file"; then # ... or it is the one specified with @setfilename ... infile=`echo "$*" | sed 's/.* \([^ ]*\) *$/\1/'` file=`sed -n ' /^@setfilename/{ s/.* \([^ ]*\) *$/\1/ p q }' $infile` # ... or it is derived from the source name (dir/f.texi becomes f.info) test -z "$file" && file=`echo "$infile" | sed 's,.*/,,;s,.[^.]*$,,'`.info fi # If the file does not exist, the user really needs makeinfo; # let's fail without touching anything. test -f $file || exit 1 touch $file ;; tar) shift # We have already tried tar in the generic part. # Look for gnutar/gtar before invocation to avoid ugly error # messages. if (gnutar --version > /dev/null 2>&1); then gnutar "$@" && exit 0 fi if (gtar --version > /dev/null 2>&1); then gtar "$@" && exit 0 fi firstarg="$1" if shift; then case $firstarg in *o*) firstarg=`echo "$firstarg" | sed s/o//` tar "$firstarg" "$@" && exit 0 ;; esac case $firstarg in *h*) firstarg=`echo "$firstarg" | sed s/h//` tar "$firstarg" "$@" && exit 0 ;; esac fi echo 1>&2 "\ WARNING: I can't seem to be able to run \`tar' with the given arguments. You may want to install GNU tar or Free paxutils, or check the command line arguments." exit 1 ;; *) echo 1>&2 "\ WARNING: \`$1' is needed, and is $msg. You might have modified some files without having the proper tools for further handling them. Check the \`README' file, it often tells you about the needed prerequisites for installing this package. You may also peek at any GNU archive site, in case some other package would contain this missing \`$1' program." exit 1 ;; esac exit 0 # Local variables: # eval: (add-hook 'write-file-hooks 'time-stamp) # time-stamp-start: "scriptversion=" # time-stamp-format: "%:y-%02m-%02d.%02H" # time-stamp-end: "$" # End: algol68g-2.4.1/aclocal.m40000644000175000001440000010130511771657104011727 00000000000000# generated automatically by aclocal 1.10.1 -*- Autoconf -*- # Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, # 2005, 2006, 2007, 2008 Free Software Foundation, Inc. # This file is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, # with or without modifications, as long as this notice is preserved. # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY, to the extent permitted by law; without # even the implied warranty of MERCHANTABILITY or FITNESS FOR A # PARTICULAR PURPOSE. m4_ifndef([AC_AUTOCONF_VERSION], [m4_copy([m4_PACKAGE_VERSION], [AC_AUTOCONF_VERSION])])dnl m4_if(AC_AUTOCONF_VERSION, [2.63],, [m4_warning([this file was generated for autoconf 2.63. You have another version of autoconf. It may work, but is not guaranteed to. If you have problems, you may need to regenerate the build system entirely. To do so, use the procedure documented by the package, typically `autoreconf'.])]) # Copyright (C) 2002, 2003, 2005, 2006, 2007 Free Software Foundation, Inc. # # This file is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, # with or without modifications, as long as this notice is preserved. # AM_AUTOMAKE_VERSION(VERSION) # ---------------------------- # Automake X.Y traces this macro to ensure aclocal.m4 has been # generated from the m4 files accompanying Automake X.Y. # (This private macro should not be called outside this file.) AC_DEFUN([AM_AUTOMAKE_VERSION], [am__api_version='1.10' dnl Some users find AM_AUTOMAKE_VERSION and mistake it for a way to dnl require some minimum version. Point them to the right macro. m4_if([$1], [1.10.1], [], [AC_FATAL([Do not call $0, use AM_INIT_AUTOMAKE([$1]).])])dnl ]) # _AM_AUTOCONF_VERSION(VERSION) # ----------------------------- # aclocal traces this macro to find the Autoconf version. # This is a private macro too. Using m4_define simplifies # the logic in aclocal, which can simply ignore this definition. m4_define([_AM_AUTOCONF_VERSION], []) # AM_SET_CURRENT_AUTOMAKE_VERSION # ------------------------------- # Call AM_AUTOMAKE_VERSION and AM_AUTOMAKE_VERSION so they can be traced. # This function is AC_REQUIREd by AC_INIT_AUTOMAKE. AC_DEFUN([AM_SET_CURRENT_AUTOMAKE_VERSION], [AM_AUTOMAKE_VERSION([1.10.1])dnl m4_ifndef([AC_AUTOCONF_VERSION], [m4_copy([m4_PACKAGE_VERSION], [AC_AUTOCONF_VERSION])])dnl _AM_AUTOCONF_VERSION(AC_AUTOCONF_VERSION)]) # AM_AUX_DIR_EXPAND -*- Autoconf -*- # Copyright (C) 2001, 2003, 2005 Free Software Foundation, Inc. # # This file is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, # with or without modifications, as long as this notice is preserved. # For projects using AC_CONFIG_AUX_DIR([foo]), Autoconf sets # $ac_aux_dir to `$srcdir/foo'. In other projects, it is set to # `$srcdir', `$srcdir/..', or `$srcdir/../..'. # # Of course, Automake must honor this variable whenever it calls a # tool from the auxiliary directory. The problem is that $srcdir (and # therefore $ac_aux_dir as well) can be either absolute or relative, # depending on how configure is run. This is pretty annoying, since # it makes $ac_aux_dir quite unusable in subdirectories: in the top # source directory, any form will work fine, but in subdirectories a # relative path needs to be adjusted first. # # $ac_aux_dir/missing # fails when called from a subdirectory if $ac_aux_dir is relative # $top_srcdir/$ac_aux_dir/missing # fails if $ac_aux_dir is absolute, # fails when called from a subdirectory in a VPATH build with # a relative $ac_aux_dir # # The reason of the latter failure is that $top_srcdir and $ac_aux_dir # are both prefixed by $srcdir. In an in-source build this is usually # harmless because $srcdir is `.', but things will broke when you # start a VPATH build or use an absolute $srcdir. # # So we could use something similar to $top_srcdir/$ac_aux_dir/missing, # iff we strip the leading $srcdir from $ac_aux_dir. That would be: # am_aux_dir='\$(top_srcdir)/'`expr "$ac_aux_dir" : "$srcdir//*\(.*\)"` # and then we would define $MISSING as # MISSING="\${SHELL} $am_aux_dir/missing" # This will work as long as MISSING is not called from configure, because # unfortunately $(top_srcdir) has no meaning in configure. # However there are other variables, like CC, which are often used in # configure, and could therefore not use this "fixed" $ac_aux_dir. # # Another solution, used here, is to always expand $ac_aux_dir to an # absolute PATH. The drawback is that using absolute paths prevent a # configured tree to be moved without reconfiguration. AC_DEFUN([AM_AUX_DIR_EXPAND], [dnl Rely on autoconf to set up CDPATH properly. AC_PREREQ([2.50])dnl # expand $ac_aux_dir to an absolute path am_aux_dir=`cd $ac_aux_dir && pwd` ]) # AM_CONDITIONAL -*- Autoconf -*- # Copyright (C) 1997, 2000, 2001, 2003, 2004, 2005, 2006 # Free Software Foundation, Inc. # # This file is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, # with or without modifications, as long as this notice is preserved. # serial 8 # AM_CONDITIONAL(NAME, SHELL-CONDITION) # ------------------------------------- # Define a conditional. AC_DEFUN([AM_CONDITIONAL], [AC_PREREQ(2.52)dnl ifelse([$1], [TRUE], [AC_FATAL([$0: invalid condition: $1])], [$1], [FALSE], [AC_FATAL([$0: invalid condition: $1])])dnl AC_SUBST([$1_TRUE])dnl AC_SUBST([$1_FALSE])dnl _AM_SUBST_NOTMAKE([$1_TRUE])dnl _AM_SUBST_NOTMAKE([$1_FALSE])dnl if $2; then $1_TRUE= $1_FALSE='#' else $1_TRUE='#' $1_FALSE= fi AC_CONFIG_COMMANDS_PRE( [if test -z "${$1_TRUE}" && test -z "${$1_FALSE}"; then AC_MSG_ERROR([[conditional "$1" was never defined. Usually this means the macro was only invoked conditionally.]]) fi])]) # Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006 # Free Software Foundation, Inc. # # This file is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, # with or without modifications, as long as this notice is preserved. # serial 9 # There are a few dirty hacks below to avoid letting `AC_PROG_CC' be # written in clear, in which case automake, when reading aclocal.m4, # will think it sees a *use*, and therefore will trigger all it's # C support machinery. Also note that it means that autoscan, seeing # CC etc. in the Makefile, will ask for an AC_PROG_CC use... # _AM_DEPENDENCIES(NAME) # ---------------------- # See how the compiler implements dependency checking. # NAME is "CC", "CXX", "GCJ", or "OBJC". # We try a few techniques and use that to set a single cache variable. # # We don't AC_REQUIRE the corresponding AC_PROG_CC since the latter was # modified to invoke _AM_DEPENDENCIES(CC); we would have a circular # dependency, and given that the user is not expected to run this macro, # just rely on AC_PROG_CC. AC_DEFUN([_AM_DEPENDENCIES], [AC_REQUIRE([AM_SET_DEPDIR])dnl AC_REQUIRE([AM_OUTPUT_DEPENDENCY_COMMANDS])dnl AC_REQUIRE([AM_MAKE_INCLUDE])dnl AC_REQUIRE([AM_DEP_TRACK])dnl ifelse([$1], CC, [depcc="$CC" am_compiler_list=], [$1], CXX, [depcc="$CXX" am_compiler_list=], [$1], OBJC, [depcc="$OBJC" am_compiler_list='gcc3 gcc'], [$1], UPC, [depcc="$UPC" am_compiler_list=], [$1], GCJ, [depcc="$GCJ" am_compiler_list='gcc3 gcc'], [depcc="$$1" am_compiler_list=]) AC_CACHE_CHECK([dependency style of $depcc], [am_cv_$1_dependencies_compiler_type], [if test -z "$AMDEP_TRUE" && test -f "$am_depcomp"; then # We make a subdir and do the tests there. Otherwise we can end up # making bogus files that we don't know about and never remove. For # instance it was reported that on HP-UX the gcc test will end up # making a dummy file named `D' -- because `-MD' means `put the output # in D'. mkdir conftest.dir # Copy depcomp to subdir because otherwise we won't find it if we're # using a relative directory. cp "$am_depcomp" conftest.dir cd conftest.dir # We will build objects and dependencies in a subdirectory because # it helps to detect inapplicable dependency modes. For instance # both Tru64's cc and ICC support -MD to output dependencies as a # side effect of compilation, but ICC will put the dependencies in # the current directory while Tru64 will put them in the object # directory. mkdir sub am_cv_$1_dependencies_compiler_type=none if test "$am_compiler_list" = ""; then am_compiler_list=`sed -n ['s/^#*\([a-zA-Z0-9]*\))$/\1/p'] < ./depcomp` fi for depmode in $am_compiler_list; do # Setup a source with many dependencies, because some compilers # like to wrap large dependency lists on column 80 (with \), and # we should not choose a depcomp mode which is confused by this. # # We need to recreate these files for each test, as the compiler may # overwrite some of them when testing with obscure command lines. # This happens at least with the AIX C compiler. : > sub/conftest.c for i in 1 2 3 4 5 6; do echo '#include "conftst'$i'.h"' >> sub/conftest.c # Using `: > sub/conftst$i.h' creates only sub/conftst1.h with # Solaris 8's {/usr,}/bin/sh. touch sub/conftst$i.h done echo "${am__include} ${am__quote}sub/conftest.Po${am__quote}" > confmf case $depmode in nosideeffect) # after this tag, mechanisms are not by side-effect, so they'll # only be used when explicitly requested if test "x$enable_dependency_tracking" = xyes; then continue else break fi ;; none) break ;; esac # We check with `-c' and `-o' for the sake of the "dashmstdout" # mode. It turns out that the SunPro C++ compiler does not properly # handle `-M -o', and we need to detect this. if depmode=$depmode \ source=sub/conftest.c object=sub/conftest.${OBJEXT-o} \ depfile=sub/conftest.Po tmpdepfile=sub/conftest.TPo \ $SHELL ./depcomp $depcc -c -o sub/conftest.${OBJEXT-o} sub/conftest.c \ >/dev/null 2>conftest.err && grep sub/conftst1.h sub/conftest.Po > /dev/null 2>&1 && grep sub/conftst6.h sub/conftest.Po > /dev/null 2>&1 && grep sub/conftest.${OBJEXT-o} sub/conftest.Po > /dev/null 2>&1 && ${MAKE-make} -s -f confmf > /dev/null 2>&1; then # icc doesn't choke on unknown options, it will just issue warnings # or remarks (even with -Werror). So we grep stderr for any message # that says an option was ignored or not supported. # When given -MP, icc 7.0 and 7.1 complain thusly: # icc: Command line warning: ignoring option '-M'; no argument required # The diagnosis changed in icc 8.0: # icc: Command line remark: option '-MP' not supported if (grep 'ignoring option' conftest.err || grep 'not supported' conftest.err) >/dev/null 2>&1; then :; else am_cv_$1_dependencies_compiler_type=$depmode break fi fi done cd .. rm -rf conftest.dir else am_cv_$1_dependencies_compiler_type=none fi ]) AC_SUBST([$1DEPMODE], [depmode=$am_cv_$1_dependencies_compiler_type]) AM_CONDITIONAL([am__fastdep$1], [ test "x$enable_dependency_tracking" != xno \ && test "$am_cv_$1_dependencies_compiler_type" = gcc3]) ]) # AM_SET_DEPDIR # ------------- # Choose a directory name for dependency files. # This macro is AC_REQUIREd in _AM_DEPENDENCIES AC_DEFUN([AM_SET_DEPDIR], [AC_REQUIRE([AM_SET_LEADING_DOT])dnl AC_SUBST([DEPDIR], ["${am__leading_dot}deps"])dnl ]) # AM_DEP_TRACK # ------------ AC_DEFUN([AM_DEP_TRACK], [AC_ARG_ENABLE(dependency-tracking, [ --disable-dependency-tracking speeds up one-time build --enable-dependency-tracking do not reject slow dependency extractors]) if test "x$enable_dependency_tracking" != xno; then am_depcomp="$ac_aux_dir/depcomp" AMDEPBACKSLASH='\' fi AM_CONDITIONAL([AMDEP], [test "x$enable_dependency_tracking" != xno]) AC_SUBST([AMDEPBACKSLASH])dnl _AM_SUBST_NOTMAKE([AMDEPBACKSLASH])dnl ]) # Generate code to set up dependency tracking. -*- Autoconf -*- # Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005 # Free Software Foundation, Inc. # # This file is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, # with or without modifications, as long as this notice is preserved. #serial 3 # _AM_OUTPUT_DEPENDENCY_COMMANDS # ------------------------------ AC_DEFUN([_AM_OUTPUT_DEPENDENCY_COMMANDS], [for mf in $CONFIG_FILES; do # Strip MF so we end up with the name of the file. mf=`echo "$mf" | sed -e 's/:.*$//'` # Check whether this is an Automake generated Makefile or not. # We used to match only the files named `Makefile.in', but # some people rename them; so instead we look at the file content. # Grep'ing the first line is not enough: some people post-process # each Makefile.in and add a new line on top of each file to say so. # Grep'ing the whole file is not good either: AIX grep has a line # limit of 2048, but all sed's we know have understand at least 4000. if sed -n 's,^#.*generated by automake.*,X,p' "$mf" | grep X >/dev/null 2>&1; then dirpart=`AS_DIRNAME("$mf")` else continue fi # Extract the definition of DEPDIR, am__include, and am__quote # from the Makefile without running `make'. DEPDIR=`sed -n 's/^DEPDIR = //p' < "$mf"` test -z "$DEPDIR" && continue am__include=`sed -n 's/^am__include = //p' < "$mf"` test -z "am__include" && continue am__quote=`sed -n 's/^am__quote = //p' < "$mf"` # When using ansi2knr, U may be empty or an underscore; expand it U=`sed -n 's/^U = //p' < "$mf"` # Find all dependency output files, they are included files with # $(DEPDIR) in their names. We invoke sed twice because it is the # simplest approach to changing $(DEPDIR) to its actual value in the # expansion. for file in `sed -n " s/^$am__include $am__quote\(.*(DEPDIR).*\)$am__quote"'$/\1/p' <"$mf" | \ sed -e 's/\$(DEPDIR)/'"$DEPDIR"'/g' -e 's/\$U/'"$U"'/g'`; do # Make sure the directory exists. test -f "$dirpart/$file" && continue fdir=`AS_DIRNAME(["$file"])` AS_MKDIR_P([$dirpart/$fdir]) # echo "creating $dirpart/$file" echo '# dummy' > "$dirpart/$file" done done ])# _AM_OUTPUT_DEPENDENCY_COMMANDS # AM_OUTPUT_DEPENDENCY_COMMANDS # ----------------------------- # This macro should only be invoked once -- use via AC_REQUIRE. # # This code is only required when automatic dependency tracking # is enabled. FIXME. This creates each `.P' file that we will # need in order to bootstrap the dependency handling code. AC_DEFUN([AM_OUTPUT_DEPENDENCY_COMMANDS], [AC_CONFIG_COMMANDS([depfiles], [test x"$AMDEP_TRUE" != x"" || _AM_OUTPUT_DEPENDENCY_COMMANDS], [AMDEP_TRUE="$AMDEP_TRUE" ac_aux_dir="$ac_aux_dir"]) ]) # Do all the work for Automake. -*- Autoconf -*- # Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, # 2005, 2006, 2008 Free Software Foundation, Inc. # # This file is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, # with or without modifications, as long as this notice is preserved. # serial 13 # This macro actually does too much. Some checks are only needed if # your package does certain things. But this isn't really a big deal. # AM_INIT_AUTOMAKE(PACKAGE, VERSION, [NO-DEFINE]) # AM_INIT_AUTOMAKE([OPTIONS]) # ----------------------------------------------- # The call with PACKAGE and VERSION arguments is the old style # call (pre autoconf-2.50), which is being phased out. PACKAGE # and VERSION should now be passed to AC_INIT and removed from # the call to AM_INIT_AUTOMAKE. # We support both call styles for the transition. After # the next Automake release, Autoconf can make the AC_INIT # arguments mandatory, and then we can depend on a new Autoconf # release and drop the old call support. AC_DEFUN([AM_INIT_AUTOMAKE], [AC_PREREQ([2.60])dnl dnl Autoconf wants to disallow AM_ names. We explicitly allow dnl the ones we care about. m4_pattern_allow([^AM_[A-Z]+FLAGS$])dnl AC_REQUIRE([AM_SET_CURRENT_AUTOMAKE_VERSION])dnl AC_REQUIRE([AC_PROG_INSTALL])dnl if test "`cd $srcdir && pwd`" != "`pwd`"; then # Use -I$(srcdir) only when $(srcdir) != ., so that make's output # is not polluted with repeated "-I." AC_SUBST([am__isrc], [' -I$(srcdir)'])_AM_SUBST_NOTMAKE([am__isrc])dnl # test to see if srcdir already configured if test -f $srcdir/config.status; then AC_MSG_ERROR([source directory already configured; run "make distclean" there first]) fi fi # test whether we have cygpath if test -z "$CYGPATH_W"; then if (cygpath --version) >/dev/null 2>/dev/null; then CYGPATH_W='cygpath -w' else CYGPATH_W=echo fi fi AC_SUBST([CYGPATH_W]) # Define the identity of the package. dnl Distinguish between old-style and new-style calls. m4_ifval([$2], [m4_ifval([$3], [_AM_SET_OPTION([no-define])])dnl AC_SUBST([PACKAGE], [$1])dnl AC_SUBST([VERSION], [$2])], [_AM_SET_OPTIONS([$1])dnl dnl Diagnose old-style AC_INIT with new-style AM_AUTOMAKE_INIT. m4_if(m4_ifdef([AC_PACKAGE_NAME], 1)m4_ifdef([AC_PACKAGE_VERSION], 1), 11,, [m4_fatal([AC_INIT should be called with package and version arguments])])dnl AC_SUBST([PACKAGE], ['AC_PACKAGE_TARNAME'])dnl AC_SUBST([VERSION], ['AC_PACKAGE_VERSION'])])dnl _AM_IF_OPTION([no-define],, [AC_DEFINE_UNQUOTED(PACKAGE, "$PACKAGE", [Name of package]) AC_DEFINE_UNQUOTED(VERSION, "$VERSION", [Version number of package])])dnl # Some tools Automake needs. AC_REQUIRE([AM_SANITY_CHECK])dnl AC_REQUIRE([AC_ARG_PROGRAM])dnl AM_MISSING_PROG(ACLOCAL, aclocal-${am__api_version}) AM_MISSING_PROG(AUTOCONF, autoconf) AM_MISSING_PROG(AUTOMAKE, automake-${am__api_version}) AM_MISSING_PROG(AUTOHEADER, autoheader) AM_MISSING_PROG(MAKEINFO, makeinfo) AM_PROG_INSTALL_SH AM_PROG_INSTALL_STRIP AC_REQUIRE([AM_PROG_MKDIR_P])dnl # We need awk for the "check" target. The system "awk" is bad on # some platforms. AC_REQUIRE([AC_PROG_AWK])dnl AC_REQUIRE([AC_PROG_MAKE_SET])dnl AC_REQUIRE([AM_SET_LEADING_DOT])dnl _AM_IF_OPTION([tar-ustar], [_AM_PROG_TAR([ustar])], [_AM_IF_OPTION([tar-pax], [_AM_PROG_TAR([pax])], [_AM_PROG_TAR([v7])])]) _AM_IF_OPTION([no-dependencies],, [AC_PROVIDE_IFELSE([AC_PROG_CC], [_AM_DEPENDENCIES(CC)], [define([AC_PROG_CC], defn([AC_PROG_CC])[_AM_DEPENDENCIES(CC)])])dnl AC_PROVIDE_IFELSE([AC_PROG_CXX], [_AM_DEPENDENCIES(CXX)], [define([AC_PROG_CXX], defn([AC_PROG_CXX])[_AM_DEPENDENCIES(CXX)])])dnl AC_PROVIDE_IFELSE([AC_PROG_OBJC], [_AM_DEPENDENCIES(OBJC)], [define([AC_PROG_OBJC], defn([AC_PROG_OBJC])[_AM_DEPENDENCIES(OBJC)])])dnl ]) ]) # When config.status generates a header, we must update the stamp-h file. # This file resides in the same directory as the config header # that is generated. The stamp files are numbered to have different names. # Autoconf calls _AC_AM_CONFIG_HEADER_HOOK (when defined) in the # loop where config.status creates the headers, so we can generate # our stamp files there. AC_DEFUN([_AC_AM_CONFIG_HEADER_HOOK], [# Compute $1's index in $config_headers. _am_arg=$1 _am_stamp_count=1 for _am_header in $config_headers :; do case $_am_header in $_am_arg | $_am_arg:* ) break ;; * ) _am_stamp_count=`expr $_am_stamp_count + 1` ;; esac done echo "timestamp for $_am_arg" >`AS_DIRNAME(["$_am_arg"])`/stamp-h[]$_am_stamp_count]) # Copyright (C) 2001, 2003, 2005 Free Software Foundation, Inc. # # This file is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, # with or without modifications, as long as this notice is preserved. # AM_PROG_INSTALL_SH # ------------------ # Define $install_sh. AC_DEFUN([AM_PROG_INSTALL_SH], [AC_REQUIRE([AM_AUX_DIR_EXPAND])dnl install_sh=${install_sh-"\$(SHELL) $am_aux_dir/install-sh"} AC_SUBST(install_sh)]) # Copyright (C) 2003, 2005 Free Software Foundation, Inc. # # This file is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, # with or without modifications, as long as this notice is preserved. # serial 2 # Check whether the underlying file-system supports filenames # with a leading dot. For instance MS-DOS doesn't. AC_DEFUN([AM_SET_LEADING_DOT], [rm -rf .tst 2>/dev/null mkdir .tst 2>/dev/null if test -d .tst; then am__leading_dot=. else am__leading_dot=_ fi rmdir .tst 2>/dev/null AC_SUBST([am__leading_dot])]) # Check to see how 'make' treats includes. -*- Autoconf -*- # Copyright (C) 2001, 2002, 2003, 2005 Free Software Foundation, Inc. # # This file is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, # with or without modifications, as long as this notice is preserved. # serial 3 # AM_MAKE_INCLUDE() # ----------------- # Check to see how make treats includes. AC_DEFUN([AM_MAKE_INCLUDE], [am_make=${MAKE-make} cat > confinc << 'END' am__doit: @echo done .PHONY: am__doit END # If we don't find an include directive, just comment out the code. AC_MSG_CHECKING([for style of include used by $am_make]) am__include="#" am__quote= _am_result=none # First try GNU make style include. echo "include confinc" > confmf # We grep out `Entering directory' and `Leaving directory' # messages which can occur if `w' ends up in MAKEFLAGS. # In particular we don't look at `^make:' because GNU make might # be invoked under some other name (usually "gmake"), in which # case it prints its new name instead of `make'. if test "`$am_make -s -f confmf 2> /dev/null | grep -v 'ing directory'`" = "done"; then am__include=include am__quote= _am_result=GNU fi # Now try BSD make style include. if test "$am__include" = "#"; then echo '.include "confinc"' > confmf if test "`$am_make -s -f confmf 2> /dev/null`" = "done"; then am__include=.include am__quote="\"" _am_result=BSD fi fi AC_SUBST([am__include]) AC_SUBST([am__quote]) AC_MSG_RESULT([$_am_result]) rm -f confinc confmf ]) # Copyright (C) 1999, 2000, 2001, 2003, 2004, 2005 # Free Software Foundation, Inc. # # This file is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, # with or without modifications, as long as this notice is preserved. # serial 5 # AM_PROG_CC_C_O # -------------- # Like AC_PROG_CC_C_O, but changed for automake. AC_DEFUN([AM_PROG_CC_C_O], [AC_REQUIRE([AC_PROG_CC_C_O])dnl AC_REQUIRE([AM_AUX_DIR_EXPAND])dnl AC_REQUIRE_AUX_FILE([compile])dnl # FIXME: we rely on the cache variable name because # there is no other way. set dummy $CC ac_cc=`echo $[2] | sed ['s/[^a-zA-Z0-9_]/_/g;s/^[0-9]/_/']` if eval "test \"`echo '$ac_cv_prog_cc_'${ac_cc}_c_o`\" != yes"; then # Losing compiler, so override with the script. # FIXME: It is wrong to rewrite CC. # But if we don't then we get into trouble of one sort or another. # A longer-term fix would be to have automake use am__CC in this case, # and then we could set am__CC="\$(top_srcdir)/compile \$(CC)" CC="$am_aux_dir/compile $CC" fi dnl Make sure AC_PROG_CC is never called again, or it will override our dnl setting of CC. m4_define([AC_PROG_CC], [m4_fatal([AC_PROG_CC cannot be called after AM_PROG_CC_C_O])]) ]) # Fake the existence of programs that GNU maintainers use. -*- Autoconf -*- # Copyright (C) 1997, 1999, 2000, 2001, 2003, 2004, 2005 # Free Software Foundation, Inc. # # This file is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, # with or without modifications, as long as this notice is preserved. # serial 5 # AM_MISSING_PROG(NAME, PROGRAM) # ------------------------------ AC_DEFUN([AM_MISSING_PROG], [AC_REQUIRE([AM_MISSING_HAS_RUN]) $1=${$1-"${am_missing_run}$2"} AC_SUBST($1)]) # AM_MISSING_HAS_RUN # ------------------ # Define MISSING if not defined so far and test if it supports --run. # If it does, set am_missing_run to use it, otherwise, to nothing. AC_DEFUN([AM_MISSING_HAS_RUN], [AC_REQUIRE([AM_AUX_DIR_EXPAND])dnl AC_REQUIRE_AUX_FILE([missing])dnl test x"${MISSING+set}" = xset || MISSING="\${SHELL} $am_aux_dir/missing" # Use eval to expand $SHELL if eval "$MISSING --run true"; then am_missing_run="$MISSING --run " else am_missing_run= AC_MSG_WARN([`missing' script is too old or missing]) fi ]) # Copyright (C) 2003, 2004, 2005, 2006 Free Software Foundation, Inc. # # This file is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, # with or without modifications, as long as this notice is preserved. # AM_PROG_MKDIR_P # --------------- # Check for `mkdir -p'. AC_DEFUN([AM_PROG_MKDIR_P], [AC_PREREQ([2.60])dnl AC_REQUIRE([AC_PROG_MKDIR_P])dnl dnl Automake 1.8 to 1.9.6 used to define mkdir_p. We now use MKDIR_P, dnl while keeping a definition of mkdir_p for backward compatibility. dnl @MKDIR_P@ is magic: AC_OUTPUT adjusts its value for each Makefile. dnl However we cannot define mkdir_p as $(MKDIR_P) for the sake of dnl Makefile.ins that do not define MKDIR_P, so we do our own dnl adjustment using top_builddir (which is defined more often than dnl MKDIR_P). AC_SUBST([mkdir_p], ["$MKDIR_P"])dnl case $mkdir_p in [[\\/$]]* | ?:[[\\/]]*) ;; */*) mkdir_p="\$(top_builddir)/$mkdir_p" ;; esac ]) # Helper functions for option handling. -*- Autoconf -*- # Copyright (C) 2001, 2002, 2003, 2005 Free Software Foundation, Inc. # # This file is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, # with or without modifications, as long as this notice is preserved. # serial 3 # _AM_MANGLE_OPTION(NAME) # ----------------------- AC_DEFUN([_AM_MANGLE_OPTION], [[_AM_OPTION_]m4_bpatsubst($1, [[^a-zA-Z0-9_]], [_])]) # _AM_SET_OPTION(NAME) # ------------------------------ # Set option NAME. Presently that only means defining a flag for this option. AC_DEFUN([_AM_SET_OPTION], [m4_define(_AM_MANGLE_OPTION([$1]), 1)]) # _AM_SET_OPTIONS(OPTIONS) # ---------------------------------- # OPTIONS is a space-separated list of Automake options. AC_DEFUN([_AM_SET_OPTIONS], [AC_FOREACH([_AM_Option], [$1], [_AM_SET_OPTION(_AM_Option)])]) # _AM_IF_OPTION(OPTION, IF-SET, [IF-NOT-SET]) # ------------------------------------------- # Execute IF-SET if OPTION is set, IF-NOT-SET otherwise. AC_DEFUN([_AM_IF_OPTION], [m4_ifset(_AM_MANGLE_OPTION([$1]), [$2], [$3])]) # Check to make sure that the build environment is sane. -*- Autoconf -*- # Copyright (C) 1996, 1997, 2000, 2001, 2003, 2005 # Free Software Foundation, Inc. # # This file is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, # with or without modifications, as long as this notice is preserved. # serial 4 # AM_SANITY_CHECK # --------------- AC_DEFUN([AM_SANITY_CHECK], [AC_MSG_CHECKING([whether build environment is sane]) # Just in case sleep 1 echo timestamp > conftest.file # Do `set' in a subshell so we don't clobber the current shell's # arguments. Must try -L first in case configure is actually a # symlink; some systems play weird games with the mod time of symlinks # (eg FreeBSD returns the mod time of the symlink's containing # directory). if ( set X `ls -Lt $srcdir/configure conftest.file 2> /dev/null` if test "$[*]" = "X"; then # -L didn't work. set X `ls -t $srcdir/configure conftest.file` fi rm -f conftest.file if test "$[*]" != "X $srcdir/configure conftest.file" \ && test "$[*]" != "X conftest.file $srcdir/configure"; then # If neither matched, then we have a broken ls. This can happen # if, for instance, CONFIG_SHELL is bash and it inherits a # broken ls alias from the environment. This has actually # happened. Such a system could not be considered "sane". AC_MSG_ERROR([ls -t appears to fail. Make sure there is not a broken alias in your environment]) fi test "$[2]" = conftest.file ) then # Ok. : else AC_MSG_ERROR([newly created file is older than distributed files! Check your system clock]) fi AC_MSG_RESULT(yes)]) # Copyright (C) 2001, 2003, 2005 Free Software Foundation, Inc. # # This file is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, # with or without modifications, as long as this notice is preserved. # AM_PROG_INSTALL_STRIP # --------------------- # One issue with vendor `install' (even GNU) is that you can't # specify the program used to strip binaries. This is especially # annoying in cross-compiling environments, where the build's strip # is unlikely to handle the host's binaries. # Fortunately install-sh will honor a STRIPPROG variable, so we # always use install-sh in `make install-strip', and initialize # STRIPPROG with the value of the STRIP variable (set by the user). AC_DEFUN([AM_PROG_INSTALL_STRIP], [AC_REQUIRE([AM_PROG_INSTALL_SH])dnl # Installed binaries are usually stripped using `strip' when the user # run `make install-strip'. However `strip' might not be the right # tool to use in cross-compilation environments, therefore Automake # will honor the `STRIP' environment variable to overrule this program. dnl Don't test for $cross_compiling = yes, because it might be `maybe'. if test "$cross_compiling" != no; then AC_CHECK_TOOL([STRIP], [strip], :) fi INSTALL_STRIP_PROGRAM="\$(install_sh) -c -s" AC_SUBST([INSTALL_STRIP_PROGRAM])]) # Copyright (C) 2006 Free Software Foundation, Inc. # # This file is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, # with or without modifications, as long as this notice is preserved. # _AM_SUBST_NOTMAKE(VARIABLE) # --------------------------- # Prevent Automake from outputting VARIABLE = @VARIABLE@ in Makefile.in. # This macro is traced by Automake. AC_DEFUN([_AM_SUBST_NOTMAKE]) # Check how to create a tarball. -*- Autoconf -*- # Copyright (C) 2004, 2005 Free Software Foundation, Inc. # # This file is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, # with or without modifications, as long as this notice is preserved. # serial 2 # _AM_PROG_TAR(FORMAT) # -------------------- # Check how to create a tarball in format FORMAT. # FORMAT should be one of `v7', `ustar', or `pax'. # # Substitute a variable $(am__tar) that is a command # writing to stdout a FORMAT-tarball containing the directory # $tardir. # tardir=directory && $(am__tar) > result.tar # # Substitute a variable $(am__untar) that extract such # a tarball read from stdin. # $(am__untar) < result.tar AC_DEFUN([_AM_PROG_TAR], [# Always define AMTAR for backward compatibility. AM_MISSING_PROG([AMTAR], [tar]) m4_if([$1], [v7], [am__tar='${AMTAR} chof - "$$tardir"'; am__untar='${AMTAR} xf -'], [m4_case([$1], [ustar],, [pax],, [m4_fatal([Unknown tar format])]) AC_MSG_CHECKING([how to create a $1 tar archive]) # Loop over all known methods to create a tar archive until one works. _am_tools='gnutar m4_if([$1], [ustar], [plaintar]) pax cpio none' _am_tools=${am_cv_prog_tar_$1-$_am_tools} # Do not fold the above two line into one, because Tru64 sh and # Solaris sh will not grok spaces in the rhs of `-'. for _am_tool in $_am_tools do case $_am_tool in gnutar) for _am_tar in tar gnutar gtar; do AM_RUN_LOG([$_am_tar --version]) && break done am__tar="$_am_tar --format=m4_if([$1], [pax], [posix], [$1]) -chf - "'"$$tardir"' am__tar_="$_am_tar --format=m4_if([$1], [pax], [posix], [$1]) -chf - "'"$tardir"' am__untar="$_am_tar -xf -" ;; plaintar) # Must skip GNU tar: if it does not support --format= it doesn't create # ustar tarball either. (tar --version) >/dev/null 2>&1 && continue am__tar='tar chf - "$$tardir"' am__tar_='tar chf - "$tardir"' am__untar='tar xf -' ;; pax) am__tar='pax -L -x $1 -w "$$tardir"' am__tar_='pax -L -x $1 -w "$tardir"' am__untar='pax -r' ;; cpio) am__tar='find "$$tardir" -print | cpio -o -H $1 -L' am__tar_='find "$tardir" -print | cpio -o -H $1 -L' am__untar='cpio -i -H $1 -d' ;; none) am__tar=false am__tar_=false am__untar=false ;; esac # If the value was cached, stop now. We just wanted to have am__tar # and am__untar set. test -n "${am_cv_prog_tar_$1}" && break # tar/untar a dummy directory, and stop if the command works rm -rf conftest.dir mkdir conftest.dir echo GrepMe > conftest.dir/file AM_RUN_LOG([tardir=conftest.dir && eval $am__tar_ >conftest.tar]) rm -rf conftest.dir if test -s conftest.tar; then AM_RUN_LOG([$am__untar /dev/null 2>&1 && break fi done rm -rf conftest.dir AC_CACHE_VAL([am_cv_prog_tar_$1], [am_cv_prog_tar_$1=$_am_tool]) AC_MSG_RESULT([$am_cv_prog_tar_$1])]) AC_SUBST([am__tar]) AC_SUBST([am__untar]) ]) # _AM_PROG_TAR algol68g-2.4.1/config.guess0000644000175000001440000012673111755213203012404 00000000000000#! /bin/sh # Attempt to guess a canonical system name. # Copyright (C) 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, # 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, # 2011 Free Software Foundation, Inc. timestamp='2011-06-03' # This file is free software; you can redistribute it and/or modify it # under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, but # WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU # General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; if not, write to the Free Software # Foundation, Inc., 51 Franklin Street - Fifth Floor, Boston, MA # 02110-1301, USA. # # As a special exception to the GNU General Public License, if you # distribute this file as part of a program that contains a # configuration script generated by Autoconf, you may include it under # the same distribution terms that you use for the rest of that program. # Originally written by Per Bothner. Please send patches (context # diff format) to and include a ChangeLog # entry. # # This script attempts to guess a canonical system name similar to # config.sub. If it succeeds, it prints the system name on stdout, and # exits with 0. Otherwise, it exits with 1. # # You can get the latest version of this script from: # http://git.savannah.gnu.org/gitweb/?p=config.git;a=blob_plain;f=config.guess;hb=HEAD me=`echo "$0" | sed -e 's,.*/,,'` usage="\ Usage: $0 [OPTION] Output the configuration name of the system \`$me' is run on. Operation modes: -h, --help print this help, then exit -t, --time-stamp print date of last modification, then exit -v, --version print version number, then exit Report bugs and patches to ." version="\ GNU config.guess ($timestamp) Originally written by Per Bothner. Copyright (C) 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc. This is free software; see the source for copying conditions. There is NO warranty; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE." help=" Try \`$me --help' for more information." # Parse command line while test $# -gt 0 ; do case $1 in --time-stamp | --time* | -t ) echo "$timestamp" ; exit ;; --version | -v ) echo "$version" ; exit ;; --help | --h* | -h ) echo "$usage"; exit ;; -- ) # Stop option processing shift; break ;; - ) # Use stdin as input. break ;; -* ) echo "$me: invalid option $1$help" >&2 exit 1 ;; * ) break ;; esac done if test $# != 0; then echo "$me: too many arguments$help" >&2 exit 1 fi trap 'exit 1' 1 2 15 # CC_FOR_BUILD -- compiler used by this script. Note that the use of a # compiler to aid in system detection is discouraged as it requires # temporary files to be created and, as you can see below, it is a # headache to deal with in a portable fashion. # Historically, `CC_FOR_BUILD' used to be named `HOST_CC'. We still # use `HOST_CC' if defined, but it is deprecated. # Portable tmp directory creation inspired by the Autoconf team. set_cc_for_build=' trap "exitcode=\$?; (rm -f \$tmpfiles 2>/dev/null; rmdir \$tmp 2>/dev/null) && exit \$exitcode" 0 ; trap "rm -f \$tmpfiles 2>/dev/null; rmdir \$tmp 2>/dev/null; exit 1" 1 2 13 15 ; : ${TMPDIR=/tmp} ; { tmp=`(umask 077 && mktemp -d "$TMPDIR/cgXXXXXX") 2>/dev/null` && test -n "$tmp" && test -d "$tmp" ; } || { test -n "$RANDOM" && tmp=$TMPDIR/cg$$-$RANDOM && (umask 077 && mkdir $tmp) ; } || { tmp=$TMPDIR/cg-$$ && (umask 077 && mkdir $tmp) && echo "Warning: creating insecure temp directory" >&2 ; } || { echo "$me: cannot create a temporary directory in $TMPDIR" >&2 ; exit 1 ; } ; dummy=$tmp/dummy ; tmpfiles="$dummy.c $dummy.o $dummy.rel $dummy" ; case $CC_FOR_BUILD,$HOST_CC,$CC in ,,) echo "int x;" > $dummy.c ; for c in cc gcc c89 c99 ; do if ($c -c -o $dummy.o $dummy.c) >/dev/null 2>&1 ; then CC_FOR_BUILD="$c"; break ; fi ; done ; if test x"$CC_FOR_BUILD" = x ; then CC_FOR_BUILD=no_compiler_found ; fi ;; ,,*) CC_FOR_BUILD=$CC ;; ,*,*) CC_FOR_BUILD=$HOST_CC ;; esac ; set_cc_for_build= ;' # This is needed to find uname on a Pyramid OSx when run in the BSD universe. # (ghazi@noc.rutgers.edu 1994-08-24) if (test -f /.attbin/uname) >/dev/null 2>&1 ; then PATH=$PATH:/.attbin ; export PATH fi UNAME_MACHINE=`(uname -m) 2>/dev/null` || UNAME_MACHINE=unknown UNAME_RELEASE=`(uname -r) 2>/dev/null` || UNAME_RELEASE=unknown UNAME_SYSTEM=`(uname -s) 2>/dev/null` || UNAME_SYSTEM=unknown UNAME_VERSION=`(uname -v) 2>/dev/null` || UNAME_VERSION=unknown # Note: order is significant - the case branches are not exclusive. case "${UNAME_MACHINE}:${UNAME_SYSTEM}:${UNAME_RELEASE}:${UNAME_VERSION}" in *:NetBSD:*:*) # NetBSD (nbsd) targets should (where applicable) match one or # more of the tupples: *-*-netbsdelf*, *-*-netbsdaout*, # *-*-netbsdecoff* and *-*-netbsd*. For targets that recently # switched to ELF, *-*-netbsd* would select the old # object file format. This provides both forward # compatibility and a consistent mechanism for selecting the # object file format. # # Note: NetBSD doesn't particularly care about the vendor # portion of the name. We always set it to "unknown". sysctl="sysctl -n hw.machine_arch" UNAME_MACHINE_ARCH=`(/sbin/$sysctl 2>/dev/null || \ /usr/sbin/$sysctl 2>/dev/null || echo unknown)` case "${UNAME_MACHINE_ARCH}" in armeb) machine=armeb-unknown ;; arm*) machine=arm-unknown ;; sh3el) machine=shl-unknown ;; sh3eb) machine=sh-unknown ;; sh5el) machine=sh5le-unknown ;; *) machine=${UNAME_MACHINE_ARCH}-unknown ;; esac # The Operating System including object format, if it has switched # to ELF recently, or will in the future. case "${UNAME_MACHINE_ARCH}" in arm*|i386|m68k|ns32k|sh3*|sparc|vax) eval $set_cc_for_build if echo __ELF__ | $CC_FOR_BUILD -E - 2>/dev/null \ | grep -q __ELF__ then # Once all utilities can be ECOFF (netbsdecoff) or a.out (netbsdaout). # Return netbsd for either. FIX? os=netbsd else os=netbsdelf fi ;; *) os=netbsd ;; esac # The OS release # Debian GNU/NetBSD machines have a different userland, and # thus, need a distinct triplet. However, they do not need # kernel version information, so it can be replaced with a # suitable tag, in the style of linux-gnu. case "${UNAME_VERSION}" in Debian*) release='-gnu' ;; *) release=`echo ${UNAME_RELEASE}|sed -e 's/[-_].*/\./'` ;; esac # Since CPU_TYPE-MANUFACTURER-KERNEL-OPERATING_SYSTEM: # contains redundant information, the shorter form: # CPU_TYPE-MANUFACTURER-OPERATING_SYSTEM is used. echo "${machine}-${os}${release}" exit ;; *:OpenBSD:*:*) UNAME_MACHINE_ARCH=`arch | sed 's/OpenBSD.//'` echo ${UNAME_MACHINE_ARCH}-unknown-openbsd${UNAME_RELEASE} exit ;; *:ekkoBSD:*:*) echo ${UNAME_MACHINE}-unknown-ekkobsd${UNAME_RELEASE} exit ;; *:SolidBSD:*:*) echo ${UNAME_MACHINE}-unknown-solidbsd${UNAME_RELEASE} exit ;; macppc:MirBSD:*:*) echo powerpc-unknown-mirbsd${UNAME_RELEASE} exit ;; *:MirBSD:*:*) echo ${UNAME_MACHINE}-unknown-mirbsd${UNAME_RELEASE} exit ;; alpha:OSF1:*:*) case $UNAME_RELEASE in *4.0) UNAME_RELEASE=`/usr/sbin/sizer -v | awk '{print $3}'` ;; *5.*) UNAME_RELEASE=`/usr/sbin/sizer -v | awk '{print $4}'` ;; esac # According to Compaq, /usr/sbin/psrinfo has been available on # OSF/1 and Tru64 systems produced since 1995. I hope that # covers most systems running today. This code pipes the CPU # types through head -n 1, so we only detect the type of CPU 0. ALPHA_CPU_TYPE=`/usr/sbin/psrinfo -v | sed -n -e 's/^ The alpha \(.*\) processor.*$/\1/p' | head -n 1` case "$ALPHA_CPU_TYPE" in "EV4 (21064)") UNAME_MACHINE="alpha" ;; "EV4.5 (21064)") UNAME_MACHINE="alpha" ;; "LCA4 (21066/21068)") UNAME_MACHINE="alpha" ;; "EV5 (21164)") UNAME_MACHINE="alphaev5" ;; "EV5.6 (21164A)") UNAME_MACHINE="alphaev56" ;; "EV5.6 (21164PC)") UNAME_MACHINE="alphapca56" ;; "EV5.7 (21164PC)") UNAME_MACHINE="alphapca57" ;; "EV6 (21264)") UNAME_MACHINE="alphaev6" ;; "EV6.7 (21264A)") UNAME_MACHINE="alphaev67" ;; "EV6.8CB (21264C)") UNAME_MACHINE="alphaev68" ;; "EV6.8AL (21264B)") UNAME_MACHINE="alphaev68" ;; "EV6.8CX (21264D)") UNAME_MACHINE="alphaev68" ;; "EV6.9A (21264/EV69A)") UNAME_MACHINE="alphaev69" ;; "EV7 (21364)") UNAME_MACHINE="alphaev7" ;; "EV7.9 (21364A)") UNAME_MACHINE="alphaev79" ;; esac # A Pn.n version is a patched version. # A Vn.n version is a released version. # A Tn.n version is a released field test version. # A Xn.n version is an unreleased experimental baselevel. # 1.2 uses "1.2" for uname -r. echo ${UNAME_MACHINE}-dec-osf`echo ${UNAME_RELEASE} | sed -e 's/^[PVTX]//' | tr 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' 'abcdefghijklmnopqrstuvwxyz'` # Reset EXIT trap before exiting to avoid spurious non-zero exit code. exitcode=$? trap '' 0 exit $exitcode ;; Alpha\ *:Windows_NT*:*) # How do we know it's Interix rather than the generic POSIX subsystem? # Should we change UNAME_MACHINE based on the output of uname instead # of the specific Alpha model? echo alpha-pc-interix exit ;; 21064:Windows_NT:50:3) echo alpha-dec-winnt3.5 exit ;; Amiga*:UNIX_System_V:4.0:*) echo m68k-unknown-sysv4 exit ;; *:[Aa]miga[Oo][Ss]:*:*) echo ${UNAME_MACHINE}-unknown-amigaos exit ;; *:[Mm]orph[Oo][Ss]:*:*) echo ${UNAME_MACHINE}-unknown-morphos exit ;; *:OS/390:*:*) echo i370-ibm-openedition exit ;; *:z/VM:*:*) echo s390-ibm-zvmoe exit ;; *:OS400:*:*) echo powerpc-ibm-os400 exit ;; arm:RISC*:1.[012]*:*|arm:riscix:1.[012]*:*) echo arm-acorn-riscix${UNAME_RELEASE} exit ;; arm:riscos:*:*|arm:RISCOS:*:*) echo arm-unknown-riscos exit ;; SR2?01:HI-UX/MPP:*:* | SR8000:HI-UX/MPP:*:*) echo hppa1.1-hitachi-hiuxmpp exit ;; Pyramid*:OSx*:*:* | MIS*:OSx*:*:* | MIS*:SMP_DC-OSx*:*:*) # akee@wpdis03.wpafb.af.mil (Earle F. Ake) contributed MIS and NILE. if test "`(/bin/universe) 2>/dev/null`" = att ; then echo pyramid-pyramid-sysv3 else echo pyramid-pyramid-bsd fi exit ;; NILE*:*:*:dcosx) echo pyramid-pyramid-svr4 exit ;; DRS?6000:unix:4.0:6*) echo sparc-icl-nx6 exit ;; DRS?6000:UNIX_SV:4.2*:7* | DRS?6000:isis:4.2*:7*) case `/usr/bin/uname -p` in sparc) echo sparc-icl-nx7; exit ;; esac ;; s390x:SunOS:*:*) echo ${UNAME_MACHINE}-ibm-solaris2`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'` exit ;; sun4H:SunOS:5.*:*) echo sparc-hal-solaris2`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'` exit ;; sun4*:SunOS:5.*:* | tadpole*:SunOS:5.*:*) echo sparc-sun-solaris2`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'` exit ;; i86pc:AuroraUX:5.*:* | i86xen:AuroraUX:5.*:*) echo i386-pc-auroraux${UNAME_RELEASE} exit ;; i86pc:SunOS:5.*:* | i86xen:SunOS:5.*:*) eval $set_cc_for_build SUN_ARCH="i386" # If there is a compiler, see if it is configured for 64-bit objects. # Note that the Sun cc does not turn __LP64__ into 1 like gcc does. # This test works for both compilers. if [ "$CC_FOR_BUILD" != 'no_compiler_found' ]; then if (echo '#ifdef __amd64'; echo IS_64BIT_ARCH; echo '#endif') | \ (CCOPTS= $CC_FOR_BUILD -E - 2>/dev/null) | \ grep IS_64BIT_ARCH >/dev/null then SUN_ARCH="x86_64" fi fi echo ${SUN_ARCH}-pc-solaris2`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'` exit ;; sun4*:SunOS:6*:*) # According to config.sub, this is the proper way to canonicalize # SunOS6. Hard to guess exactly what SunOS6 will be like, but # it's likely to be more like Solaris than SunOS4. echo sparc-sun-solaris3`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'` exit ;; sun4*:SunOS:*:*) case "`/usr/bin/arch -k`" in Series*|S4*) UNAME_RELEASE=`uname -v` ;; esac # Japanese Language versions have a version number like `4.1.3-JL'. echo sparc-sun-sunos`echo ${UNAME_RELEASE}|sed -e 's/-/_/'` exit ;; sun3*:SunOS:*:*) echo m68k-sun-sunos${UNAME_RELEASE} exit ;; sun*:*:4.2BSD:*) UNAME_RELEASE=`(sed 1q /etc/motd | awk '{print substr($5,1,3)}') 2>/dev/null` test "x${UNAME_RELEASE}" = "x" && UNAME_RELEASE=3 case "`/bin/arch`" in sun3) echo m68k-sun-sunos${UNAME_RELEASE} ;; sun4) echo sparc-sun-sunos${UNAME_RELEASE} ;; esac exit ;; aushp:SunOS:*:*) echo sparc-auspex-sunos${UNAME_RELEASE} exit ;; # The situation for MiNT is a little confusing. The machine name # can be virtually everything (everything which is not # "atarist" or "atariste" at least should have a processor # > m68000). The system name ranges from "MiNT" over "FreeMiNT" # to the lowercase version "mint" (or "freemint"). Finally # the system name "TOS" denotes a system which is actually not # MiNT. But MiNT is downward compatible to TOS, so this should # be no problem. atarist[e]:*MiNT:*:* | atarist[e]:*mint:*:* | atarist[e]:*TOS:*:*) echo m68k-atari-mint${UNAME_RELEASE} exit ;; atari*:*MiNT:*:* | atari*:*mint:*:* | atarist[e]:*TOS:*:*) echo m68k-atari-mint${UNAME_RELEASE} exit ;; *falcon*:*MiNT:*:* | *falcon*:*mint:*:* | *falcon*:*TOS:*:*) echo m68k-atari-mint${UNAME_RELEASE} exit ;; milan*:*MiNT:*:* | milan*:*mint:*:* | *milan*:*TOS:*:*) echo m68k-milan-mint${UNAME_RELEASE} exit ;; hades*:*MiNT:*:* | hades*:*mint:*:* | *hades*:*TOS:*:*) echo m68k-hades-mint${UNAME_RELEASE} exit ;; *:*MiNT:*:* | *:*mint:*:* | *:*TOS:*:*) echo m68k-unknown-mint${UNAME_RELEASE} exit ;; m68k:machten:*:*) echo m68k-apple-machten${UNAME_RELEASE} exit ;; powerpc:machten:*:*) echo powerpc-apple-machten${UNAME_RELEASE} exit ;; RISC*:Mach:*:*) echo mips-dec-mach_bsd4.3 exit ;; RISC*:ULTRIX:*:*) echo mips-dec-ultrix${UNAME_RELEASE} exit ;; VAX*:ULTRIX*:*:*) echo vax-dec-ultrix${UNAME_RELEASE} exit ;; 2020:CLIX:*:* | 2430:CLIX:*:*) echo clipper-intergraph-clix${UNAME_RELEASE} exit ;; mips:*:*:UMIPS | mips:*:*:RISCos) eval $set_cc_for_build sed 's/^ //' << EOF >$dummy.c #ifdef __cplusplus #include /* for printf() prototype */ int main (int argc, char *argv[]) { #else int main (argc, argv) int argc; char *argv[]; { #endif #if defined (host_mips) && defined (MIPSEB) #if defined (SYSTYPE_SYSV) printf ("mips-mips-riscos%ssysv\n", argv[1]); exit (0); #endif #if defined (SYSTYPE_SVR4) printf ("mips-mips-riscos%ssvr4\n", argv[1]); exit (0); #endif #if defined (SYSTYPE_BSD43) || defined(SYSTYPE_BSD) printf ("mips-mips-riscos%sbsd\n", argv[1]); exit (0); #endif #endif exit (-1); } EOF $CC_FOR_BUILD -o $dummy $dummy.c && dummyarg=`echo "${UNAME_RELEASE}" | sed -n 's/\([0-9]*\).*/\1/p'` && SYSTEM_NAME=`$dummy $dummyarg` && { echo "$SYSTEM_NAME"; exit; } echo mips-mips-riscos${UNAME_RELEASE} exit ;; Motorola:PowerMAX_OS:*:*) echo powerpc-motorola-powermax exit ;; Motorola:*:4.3:PL8-*) echo powerpc-harris-powermax exit ;; Night_Hawk:*:*:PowerMAX_OS | Synergy:PowerMAX_OS:*:*) echo powerpc-harris-powermax exit ;; Night_Hawk:Power_UNIX:*:*) echo powerpc-harris-powerunix exit ;; m88k:CX/UX:7*:*) echo m88k-harris-cxux7 exit ;; m88k:*:4*:R4*) echo m88k-motorola-sysv4 exit ;; m88k:*:3*:R3*) echo m88k-motorola-sysv3 exit ;; AViiON:dgux:*:*) # DG/UX returns AViiON for all architectures UNAME_PROCESSOR=`/usr/bin/uname -p` if [ $UNAME_PROCESSOR = mc88100 ] || [ $UNAME_PROCESSOR = mc88110 ] then if [ ${TARGET_BINARY_INTERFACE}x = m88kdguxelfx ] || \ [ ${TARGET_BINARY_INTERFACE}x = x ] then echo m88k-dg-dgux${UNAME_RELEASE} else echo m88k-dg-dguxbcs${UNAME_RELEASE} fi else echo i586-dg-dgux${UNAME_RELEASE} fi exit ;; M88*:DolphinOS:*:*) # DolphinOS (SVR3) echo m88k-dolphin-sysv3 exit ;; M88*:*:R3*:*) # Delta 88k system running SVR3 echo m88k-motorola-sysv3 exit ;; XD88*:*:*:*) # Tektronix XD88 system running UTekV (SVR3) echo m88k-tektronix-sysv3 exit ;; Tek43[0-9][0-9]:UTek:*:*) # Tektronix 4300 system running UTek (BSD) echo m68k-tektronix-bsd exit ;; *:IRIX*:*:*) echo mips-sgi-irix`echo ${UNAME_RELEASE}|sed -e 's/-/_/g'` exit ;; ????????:AIX?:[12].1:2) # AIX 2.2.1 or AIX 2.1.1 is RT/PC AIX. echo romp-ibm-aix # uname -m gives an 8 hex-code CPU id exit ;; # Note that: echo "'`uname -s`'" gives 'AIX ' i*86:AIX:*:*) echo i386-ibm-aix exit ;; ia64:AIX:*:*) if [ -x /usr/bin/oslevel ] ; then IBM_REV=`/usr/bin/oslevel` else IBM_REV=${UNAME_VERSION}.${UNAME_RELEASE} fi echo ${UNAME_MACHINE}-ibm-aix${IBM_REV} exit ;; *:AIX:2:3) if grep bos325 /usr/include/stdio.h >/dev/null 2>&1; then eval $set_cc_for_build sed 's/^ //' << EOF >$dummy.c #include main() { if (!__power_pc()) exit(1); puts("powerpc-ibm-aix3.2.5"); exit(0); } EOF if $CC_FOR_BUILD -o $dummy $dummy.c && SYSTEM_NAME=`$dummy` then echo "$SYSTEM_NAME" else echo rs6000-ibm-aix3.2.5 fi elif grep bos324 /usr/include/stdio.h >/dev/null 2>&1; then echo rs6000-ibm-aix3.2.4 else echo rs6000-ibm-aix3.2 fi exit ;; *:AIX:*:[4567]) IBM_CPU_ID=`/usr/sbin/lsdev -C -c processor -S available | sed 1q | awk '{ print $1 }'` if /usr/sbin/lsattr -El ${IBM_CPU_ID} | grep ' POWER' >/dev/null 2>&1; then IBM_ARCH=rs6000 else IBM_ARCH=powerpc fi if [ -x /usr/bin/oslevel ] ; then IBM_REV=`/usr/bin/oslevel` else IBM_REV=${UNAME_VERSION}.${UNAME_RELEASE} fi echo ${IBM_ARCH}-ibm-aix${IBM_REV} exit ;; *:AIX:*:*) echo rs6000-ibm-aix exit ;; ibmrt:4.4BSD:*|romp-ibm:BSD:*) echo romp-ibm-bsd4.4 exit ;; ibmrt:*BSD:*|romp-ibm:BSD:*) # covers RT/PC BSD and echo romp-ibm-bsd${UNAME_RELEASE} # 4.3 with uname added to exit ;; # report: romp-ibm BSD 4.3 *:BOSX:*:*) echo rs6000-bull-bosx exit ;; DPX/2?00:B.O.S.:*:*) echo m68k-bull-sysv3 exit ;; 9000/[34]??:4.3bsd:1.*:*) echo m68k-hp-bsd exit ;; hp300:4.4BSD:*:* | 9000/[34]??:4.3bsd:2.*:*) echo m68k-hp-bsd4.4 exit ;; 9000/[34678]??:HP-UX:*:*) HPUX_REV=`echo ${UNAME_RELEASE}|sed -e 's/[^.]*.[0B]*//'` case "${UNAME_MACHINE}" in 9000/31? ) HP_ARCH=m68000 ;; 9000/[34]?? ) HP_ARCH=m68k ;; 9000/[678][0-9][0-9]) if [ -x /usr/bin/getconf ]; then sc_cpu_version=`/usr/bin/getconf SC_CPU_VERSION 2>/dev/null` sc_kernel_bits=`/usr/bin/getconf SC_KERNEL_BITS 2>/dev/null` case "${sc_cpu_version}" in 523) HP_ARCH="hppa1.0" ;; # CPU_PA_RISC1_0 528) HP_ARCH="hppa1.1" ;; # CPU_PA_RISC1_1 532) # CPU_PA_RISC2_0 case "${sc_kernel_bits}" in 32) HP_ARCH="hppa2.0n" ;; 64) HP_ARCH="hppa2.0w" ;; '') HP_ARCH="hppa2.0" ;; # HP-UX 10.20 esac ;; esac fi if [ "${HP_ARCH}" = "" ]; then eval $set_cc_for_build sed 's/^ //' << EOF >$dummy.c #define _HPUX_SOURCE #include #include int main () { #if defined(_SC_KERNEL_BITS) long bits = sysconf(_SC_KERNEL_BITS); #endif long cpu = sysconf (_SC_CPU_VERSION); switch (cpu) { case CPU_PA_RISC1_0: puts ("hppa1.0"); break; case CPU_PA_RISC1_1: puts ("hppa1.1"); break; case CPU_PA_RISC2_0: #if defined(_SC_KERNEL_BITS) switch (bits) { case 64: puts ("hppa2.0w"); break; case 32: puts ("hppa2.0n"); break; default: puts ("hppa2.0"); break; } break; #else /* !defined(_SC_KERNEL_BITS) */ puts ("hppa2.0"); break; #endif default: puts ("hppa1.0"); break; } exit (0); } EOF (CCOPTS= $CC_FOR_BUILD -o $dummy $dummy.c 2>/dev/null) && HP_ARCH=`$dummy` test -z "$HP_ARCH" && HP_ARCH=hppa fi ;; esac if [ ${HP_ARCH} = "hppa2.0w" ] then eval $set_cc_for_build # hppa2.0w-hp-hpux* has a 64-bit kernel and a compiler generating # 32-bit code. hppa64-hp-hpux* has the same kernel and a compiler # generating 64-bit code. GNU and HP use different nomenclature: # # $ CC_FOR_BUILD=cc ./config.guess # => hppa2.0w-hp-hpux11.23 # $ CC_FOR_BUILD="cc +DA2.0w" ./config.guess # => hppa64-hp-hpux11.23 if echo __LP64__ | (CCOPTS= $CC_FOR_BUILD -E - 2>/dev/null) | grep -q __LP64__ then HP_ARCH="hppa2.0w" else HP_ARCH="hppa64" fi fi echo ${HP_ARCH}-hp-hpux${HPUX_REV} exit ;; ia64:HP-UX:*:*) HPUX_REV=`echo ${UNAME_RELEASE}|sed -e 's/[^.]*.[0B]*//'` echo ia64-hp-hpux${HPUX_REV} exit ;; 3050*:HI-UX:*:*) eval $set_cc_for_build sed 's/^ //' << EOF >$dummy.c #include int main () { long cpu = sysconf (_SC_CPU_VERSION); /* The order matters, because CPU_IS_HP_MC68K erroneously returns true for CPU_PA_RISC1_0. CPU_IS_PA_RISC returns correct results, however. */ if (CPU_IS_PA_RISC (cpu)) { switch (cpu) { case CPU_PA_RISC1_0: puts ("hppa1.0-hitachi-hiuxwe2"); break; case CPU_PA_RISC1_1: puts ("hppa1.1-hitachi-hiuxwe2"); break; case CPU_PA_RISC2_0: puts ("hppa2.0-hitachi-hiuxwe2"); break; default: puts ("hppa-hitachi-hiuxwe2"); break; } } else if (CPU_IS_HP_MC68K (cpu)) puts ("m68k-hitachi-hiuxwe2"); else puts ("unknown-hitachi-hiuxwe2"); exit (0); } EOF $CC_FOR_BUILD -o $dummy $dummy.c && SYSTEM_NAME=`$dummy` && { echo "$SYSTEM_NAME"; exit; } echo unknown-hitachi-hiuxwe2 exit ;; 9000/7??:4.3bsd:*:* | 9000/8?[79]:4.3bsd:*:* ) echo hppa1.1-hp-bsd exit ;; 9000/8??:4.3bsd:*:*) echo hppa1.0-hp-bsd exit ;; *9??*:MPE/iX:*:* | *3000*:MPE/iX:*:*) echo hppa1.0-hp-mpeix exit ;; hp7??:OSF1:*:* | hp8?[79]:OSF1:*:* ) echo hppa1.1-hp-osf exit ;; hp8??:OSF1:*:*) echo hppa1.0-hp-osf exit ;; i*86:OSF1:*:*) if [ -x /usr/sbin/sysversion ] ; then echo ${UNAME_MACHINE}-unknown-osf1mk else echo ${UNAME_MACHINE}-unknown-osf1 fi exit ;; parisc*:Lites*:*:*) echo hppa1.1-hp-lites exit ;; C1*:ConvexOS:*:* | convex:ConvexOS:C1*:*) echo c1-convex-bsd exit ;; C2*:ConvexOS:*:* | convex:ConvexOS:C2*:*) if getsysinfo -f scalar_acc then echo c32-convex-bsd else echo c2-convex-bsd fi exit ;; C34*:ConvexOS:*:* | convex:ConvexOS:C34*:*) echo c34-convex-bsd exit ;; C38*:ConvexOS:*:* | convex:ConvexOS:C38*:*) echo c38-convex-bsd exit ;; C4*:ConvexOS:*:* | convex:ConvexOS:C4*:*) echo c4-convex-bsd exit ;; CRAY*Y-MP:*:*:*) echo ymp-cray-unicos${UNAME_RELEASE} | sed -e 's/\.[^.]*$/.X/' exit ;; CRAY*[A-Z]90:*:*:*) echo ${UNAME_MACHINE}-cray-unicos${UNAME_RELEASE} \ | sed -e 's/CRAY.*\([A-Z]90\)/\1/' \ -e y/ABCDEFGHIJKLMNOPQRSTUVWXYZ/abcdefghijklmnopqrstuvwxyz/ \ -e 's/\.[^.]*$/.X/' exit ;; CRAY*TS:*:*:*) echo t90-cray-unicos${UNAME_RELEASE} | sed -e 's/\.[^.]*$/.X/' exit ;; CRAY*T3E:*:*:*) echo alphaev5-cray-unicosmk${UNAME_RELEASE} | sed -e 's/\.[^.]*$/.X/' exit ;; CRAY*SV1:*:*:*) echo sv1-cray-unicos${UNAME_RELEASE} | sed -e 's/\.[^.]*$/.X/' exit ;; *:UNICOS/mp:*:*) echo craynv-cray-unicosmp${UNAME_RELEASE} | sed -e 's/\.[^.]*$/.X/' exit ;; F30[01]:UNIX_System_V:*:* | F700:UNIX_System_V:*:*) FUJITSU_PROC=`uname -m | tr 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' 'abcdefghijklmnopqrstuvwxyz'` FUJITSU_SYS=`uname -p | tr 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' 'abcdefghijklmnopqrstuvwxyz' | sed -e 's/\///'` FUJITSU_REL=`echo ${UNAME_RELEASE} | sed -e 's/ /_/'` echo "${FUJITSU_PROC}-fujitsu-${FUJITSU_SYS}${FUJITSU_REL}" exit ;; 5000:UNIX_System_V:4.*:*) FUJITSU_SYS=`uname -p | tr 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' 'abcdefghijklmnopqrstuvwxyz' | sed -e 's/\///'` FUJITSU_REL=`echo ${UNAME_RELEASE} | tr 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' 'abcdefghijklmnopqrstuvwxyz' | sed -e 's/ /_/'` echo "sparc-fujitsu-${FUJITSU_SYS}${FUJITSU_REL}" exit ;; i*86:BSD/386:*:* | i*86:BSD/OS:*:* | *:Ascend\ Embedded/OS:*:*) echo ${UNAME_MACHINE}-pc-bsdi${UNAME_RELEASE} exit ;; sparc*:BSD/OS:*:*) echo sparc-unknown-bsdi${UNAME_RELEASE} exit ;; *:BSD/OS:*:*) echo ${UNAME_MACHINE}-unknown-bsdi${UNAME_RELEASE} exit ;; *:FreeBSD:*:*) case ${UNAME_MACHINE} in pc98) echo i386-unknown-freebsd`echo ${UNAME_RELEASE}|sed -e 's/[-(].*//'` ;; amd64) echo x86_64-unknown-freebsd`echo ${UNAME_RELEASE}|sed -e 's/[-(].*//'` ;; *) echo ${UNAME_MACHINE}-unknown-freebsd`echo ${UNAME_RELEASE}|sed -e 's/[-(].*//'` ;; esac exit ;; i*:CYGWIN*:*) echo ${UNAME_MACHINE}-pc-cygwin exit ;; *:MINGW*:*) echo ${UNAME_MACHINE}-pc-mingw32 exit ;; i*:windows32*:*) # uname -m includes "-pc" on this system. echo ${UNAME_MACHINE}-mingw32 exit ;; i*:PW*:*) echo ${UNAME_MACHINE}-pc-pw32 exit ;; *:Interix*:*) case ${UNAME_MACHINE} in x86) echo i586-pc-interix${UNAME_RELEASE} exit ;; authenticamd | genuineintel | EM64T) echo x86_64-unknown-interix${UNAME_RELEASE} exit ;; IA64) echo ia64-unknown-interix${UNAME_RELEASE} exit ;; esac ;; [345]86:Windows_95:* | [345]86:Windows_98:* | [345]86:Windows_NT:*) echo i${UNAME_MACHINE}-pc-mks exit ;; 8664:Windows_NT:*) echo x86_64-pc-mks exit ;; i*:Windows_NT*:* | Pentium*:Windows_NT*:*) # How do we know it's Interix rather than the generic POSIX subsystem? # It also conflicts with pre-2.0 versions of AT&T UWIN. Should we # UNAME_MACHINE based on the output of uname instead of i386? echo i586-pc-interix exit ;; i*:UWIN*:*) echo ${UNAME_MACHINE}-pc-uwin exit ;; amd64:CYGWIN*:*:* | x86_64:CYGWIN*:*:*) echo x86_64-unknown-cygwin exit ;; p*:CYGWIN*:*) echo powerpcle-unknown-cygwin exit ;; prep*:SunOS:5.*:*) echo powerpcle-unknown-solaris2`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'` exit ;; *:GNU:*:*) # the GNU system echo `echo ${UNAME_MACHINE}|sed -e 's,[-/].*$,,'`-unknown-gnu`echo ${UNAME_RELEASE}|sed -e 's,/.*$,,'` exit ;; *:GNU/*:*:*) # other systems with GNU libc and userland echo ${UNAME_MACHINE}-unknown-`echo ${UNAME_SYSTEM} | sed 's,^[^/]*/,,' | tr '[A-Z]' '[a-z]'``echo ${UNAME_RELEASE}|sed -e 's/[-(].*//'`-gnu exit ;; i*86:Minix:*:*) echo ${UNAME_MACHINE}-pc-minix exit ;; alpha:Linux:*:*) case `sed -n '/^cpu model/s/^.*: \(.*\)/\1/p' < /proc/cpuinfo` in EV5) UNAME_MACHINE=alphaev5 ;; EV56) UNAME_MACHINE=alphaev56 ;; PCA56) UNAME_MACHINE=alphapca56 ;; PCA57) UNAME_MACHINE=alphapca56 ;; EV6) UNAME_MACHINE=alphaev6 ;; EV67) UNAME_MACHINE=alphaev67 ;; EV68*) UNAME_MACHINE=alphaev68 ;; esac objdump --private-headers /bin/sh | grep -q ld.so.1 if test "$?" = 0 ; then LIBC="libc1" ; else LIBC="" ; fi echo ${UNAME_MACHINE}-unknown-linux-gnu${LIBC} exit ;; arm*:Linux:*:*) eval $set_cc_for_build if echo __ARM_EABI__ | $CC_FOR_BUILD -E - 2>/dev/null \ | grep -q __ARM_EABI__ then echo ${UNAME_MACHINE}-unknown-linux-gnu else if echo __ARM_PCS_VFP | $CC_FOR_BUILD -E - 2>/dev/null \ | grep -q __ARM_PCS_VFP then echo ${UNAME_MACHINE}-unknown-linux-gnueabi else echo ${UNAME_MACHINE}-unknown-linux-gnueabihf fi fi exit ;; avr32*:Linux:*:*) echo ${UNAME_MACHINE}-unknown-linux-gnu exit ;; cris:Linux:*:*) echo cris-axis-linux-gnu exit ;; crisv32:Linux:*:*) echo crisv32-axis-linux-gnu exit ;; frv:Linux:*:*) echo frv-unknown-linux-gnu exit ;; i*86:Linux:*:*) LIBC=gnu eval $set_cc_for_build sed 's/^ //' << EOF >$dummy.c #ifdef __dietlibc__ LIBC=dietlibc #endif EOF eval `$CC_FOR_BUILD -E $dummy.c 2>/dev/null | grep '^LIBC'` echo "${UNAME_MACHINE}-pc-linux-${LIBC}" exit ;; ia64:Linux:*:*) echo ${UNAME_MACHINE}-unknown-linux-gnu exit ;; m32r*:Linux:*:*) echo ${UNAME_MACHINE}-unknown-linux-gnu exit ;; m68*:Linux:*:*) echo ${UNAME_MACHINE}-unknown-linux-gnu exit ;; mips:Linux:*:* | mips64:Linux:*:*) eval $set_cc_for_build sed 's/^ //' << EOF >$dummy.c #undef CPU #undef ${UNAME_MACHINE} #undef ${UNAME_MACHINE}el #if defined(__MIPSEL__) || defined(__MIPSEL) || defined(_MIPSEL) || defined(MIPSEL) CPU=${UNAME_MACHINE}el #else #if defined(__MIPSEB__) || defined(__MIPSEB) || defined(_MIPSEB) || defined(MIPSEB) CPU=${UNAME_MACHINE} #else CPU= #endif #endif EOF eval `$CC_FOR_BUILD -E $dummy.c 2>/dev/null | grep '^CPU'` test x"${CPU}" != x && { echo "${CPU}-unknown-linux-gnu"; exit; } ;; or32:Linux:*:*) echo or32-unknown-linux-gnu exit ;; padre:Linux:*:*) echo sparc-unknown-linux-gnu exit ;; parisc64:Linux:*:* | hppa64:Linux:*:*) echo hppa64-unknown-linux-gnu exit ;; parisc:Linux:*:* | hppa:Linux:*:*) # Look for CPU level case `grep '^cpu[^a-z]*:' /proc/cpuinfo 2>/dev/null | cut -d' ' -f2` in PA7*) echo hppa1.1-unknown-linux-gnu ;; PA8*) echo hppa2.0-unknown-linux-gnu ;; *) echo hppa-unknown-linux-gnu ;; esac exit ;; ppc64:Linux:*:*) echo powerpc64-unknown-linux-gnu exit ;; ppc:Linux:*:*) echo powerpc-unknown-linux-gnu exit ;; s390:Linux:*:* | s390x:Linux:*:*) echo ${UNAME_MACHINE}-ibm-linux exit ;; sh64*:Linux:*:*) echo ${UNAME_MACHINE}-unknown-linux-gnu exit ;; sh*:Linux:*:*) echo ${UNAME_MACHINE}-unknown-linux-gnu exit ;; sparc:Linux:*:* | sparc64:Linux:*:*) echo ${UNAME_MACHINE}-unknown-linux-gnu exit ;; tile*:Linux:*:*) echo ${UNAME_MACHINE}-unknown-linux-gnu exit ;; vax:Linux:*:*) echo ${UNAME_MACHINE}-dec-linux-gnu exit ;; x86_64:Linux:*:*) echo x86_64-unknown-linux-gnu exit ;; xtensa*:Linux:*:*) echo ${UNAME_MACHINE}-unknown-linux-gnu exit ;; i*86:DYNIX/ptx:4*:*) # ptx 4.0 does uname -s correctly, with DYNIX/ptx in there. # earlier versions are messed up and put the nodename in both # sysname and nodename. echo i386-sequent-sysv4 exit ;; i*86:UNIX_SV:4.2MP:2.*) # Unixware is an offshoot of SVR4, but it has its own version # number series starting with 2... # I am not positive that other SVR4 systems won't match this, # I just have to hope. -- rms. # Use sysv4.2uw... so that sysv4* matches it. echo ${UNAME_MACHINE}-pc-sysv4.2uw${UNAME_VERSION} exit ;; i*86:OS/2:*:*) # If we were able to find `uname', then EMX Unix compatibility # is probably installed. echo ${UNAME_MACHINE}-pc-os2-emx exit ;; i*86:XTS-300:*:STOP) echo ${UNAME_MACHINE}-unknown-stop exit ;; i*86:atheos:*:*) echo ${UNAME_MACHINE}-unknown-atheos exit ;; i*86:syllable:*:*) echo ${UNAME_MACHINE}-pc-syllable exit ;; i*86:LynxOS:2.*:* | i*86:LynxOS:3.[01]*:* | i*86:LynxOS:4.[02]*:*) echo i386-unknown-lynxos${UNAME_RELEASE} exit ;; i*86:*DOS:*:*) echo ${UNAME_MACHINE}-pc-msdosdjgpp exit ;; i*86:*:4.*:* | i*86:SYSTEM_V:4.*:*) UNAME_REL=`echo ${UNAME_RELEASE} | sed 's/\/MP$//'` if grep Novell /usr/include/link.h >/dev/null 2>/dev/null; then echo ${UNAME_MACHINE}-univel-sysv${UNAME_REL} else echo ${UNAME_MACHINE}-pc-sysv${UNAME_REL} fi exit ;; i*86:*:5:[678]*) # UnixWare 7.x, OpenUNIX and OpenServer 6. case `/bin/uname -X | grep "^Machine"` in *486*) UNAME_MACHINE=i486 ;; *Pentium) UNAME_MACHINE=i586 ;; *Pent*|*Celeron) UNAME_MACHINE=i686 ;; esac echo ${UNAME_MACHINE}-unknown-sysv${UNAME_RELEASE}${UNAME_SYSTEM}${UNAME_VERSION} exit ;; i*86:*:3.2:*) if test -f /usr/options/cb.name; then UNAME_REL=`sed -n 's/.*Version //p' /dev/null >/dev/null ; then UNAME_REL=`(/bin/uname -X|grep Release|sed -e 's/.*= //')` (/bin/uname -X|grep i80486 >/dev/null) && UNAME_MACHINE=i486 (/bin/uname -X|grep '^Machine.*Pentium' >/dev/null) \ && UNAME_MACHINE=i586 (/bin/uname -X|grep '^Machine.*Pent *II' >/dev/null) \ && UNAME_MACHINE=i686 (/bin/uname -X|grep '^Machine.*Pentium Pro' >/dev/null) \ && UNAME_MACHINE=i686 echo ${UNAME_MACHINE}-pc-sco$UNAME_REL else echo ${UNAME_MACHINE}-pc-sysv32 fi exit ;; pc:*:*:*) # Left here for compatibility: # uname -m prints for DJGPP always 'pc', but it prints nothing about # the processor, so we play safe by assuming i586. # Note: whatever this is, it MUST be the same as what config.sub # prints for the "djgpp" host, or else GDB configury will decide that # this is a cross-build. echo i586-pc-msdosdjgpp exit ;; Intel:Mach:3*:*) echo i386-pc-mach3 exit ;; paragon:*:*:*) echo i860-intel-osf1 exit ;; i860:*:4.*:*) # i860-SVR4 if grep Stardent /usr/include/sys/uadmin.h >/dev/null 2>&1 ; then echo i860-stardent-sysv${UNAME_RELEASE} # Stardent Vistra i860-SVR4 else # Add other i860-SVR4 vendors below as they are discovered. echo i860-unknown-sysv${UNAME_RELEASE} # Unknown i860-SVR4 fi exit ;; mini*:CTIX:SYS*5:*) # "miniframe" echo m68010-convergent-sysv exit ;; mc68k:UNIX:SYSTEM5:3.51m) echo m68k-convergent-sysv exit ;; M680?0:D-NIX:5.3:*) echo m68k-diab-dnix exit ;; M68*:*:R3V[5678]*:*) test -r /sysV68 && { echo 'm68k-motorola-sysv'; exit; } ;; 3[345]??:*:4.0:3.0 | 3[34]??A:*:4.0:3.0 | 3[34]??,*:*:4.0:3.0 | 3[34]??/*:*:4.0:3.0 | 4400:*:4.0:3.0 | 4850:*:4.0:3.0 | SKA40:*:4.0:3.0 | SDS2:*:4.0:3.0 | SHG2:*:4.0:3.0 | S7501*:*:4.0:3.0) OS_REL='' test -r /etc/.relid \ && OS_REL=.`sed -n 's/[^ ]* [^ ]* \([0-9][0-9]\).*/\1/p' < /etc/.relid` /bin/uname -p 2>/dev/null | grep 86 >/dev/null \ && { echo i486-ncr-sysv4.3${OS_REL}; exit; } /bin/uname -p 2>/dev/null | /bin/grep entium >/dev/null \ && { echo i586-ncr-sysv4.3${OS_REL}; exit; } ;; 3[34]??:*:4.0:* | 3[34]??,*:*:4.0:*) /bin/uname -p 2>/dev/null | grep 86 >/dev/null \ && { echo i486-ncr-sysv4; exit; } ;; NCR*:*:4.2:* | MPRAS*:*:4.2:*) OS_REL='.3' test -r /etc/.relid \ && OS_REL=.`sed -n 's/[^ ]* [^ ]* \([0-9][0-9]\).*/\1/p' < /etc/.relid` /bin/uname -p 2>/dev/null | grep 86 >/dev/null \ && { echo i486-ncr-sysv4.3${OS_REL}; exit; } /bin/uname -p 2>/dev/null | /bin/grep entium >/dev/null \ && { echo i586-ncr-sysv4.3${OS_REL}; exit; } /bin/uname -p 2>/dev/null | /bin/grep pteron >/dev/null \ && { echo i586-ncr-sysv4.3${OS_REL}; exit; } ;; m68*:LynxOS:2.*:* | m68*:LynxOS:3.0*:*) echo m68k-unknown-lynxos${UNAME_RELEASE} exit ;; mc68030:UNIX_System_V:4.*:*) echo m68k-atari-sysv4 exit ;; TSUNAMI:LynxOS:2.*:*) echo sparc-unknown-lynxos${UNAME_RELEASE} exit ;; rs6000:LynxOS:2.*:*) echo rs6000-unknown-lynxos${UNAME_RELEASE} exit ;; PowerPC:LynxOS:2.*:* | PowerPC:LynxOS:3.[01]*:* | PowerPC:LynxOS:4.[02]*:*) echo powerpc-unknown-lynxos${UNAME_RELEASE} exit ;; SM[BE]S:UNIX_SV:*:*) echo mips-dde-sysv${UNAME_RELEASE} exit ;; RM*:ReliantUNIX-*:*:*) echo mips-sni-sysv4 exit ;; RM*:SINIX-*:*:*) echo mips-sni-sysv4 exit ;; *:SINIX-*:*:*) if uname -p 2>/dev/null >/dev/null ; then UNAME_MACHINE=`(uname -p) 2>/dev/null` echo ${UNAME_MACHINE}-sni-sysv4 else echo ns32k-sni-sysv fi exit ;; PENTIUM:*:4.0*:*) # Unisys `ClearPath HMP IX 4000' SVR4/MP effort # says echo i586-unisys-sysv4 exit ;; *:UNIX_System_V:4*:FTX*) # From Gerald Hewes . # How about differentiating between stratus architectures? -djm echo hppa1.1-stratus-sysv4 exit ;; *:*:*:FTX*) # From seanf@swdc.stratus.com. echo i860-stratus-sysv4 exit ;; i*86:VOS:*:*) # From Paul.Green@stratus.com. echo ${UNAME_MACHINE}-stratus-vos exit ;; *:VOS:*:*) # From Paul.Green@stratus.com. echo hppa1.1-stratus-vos exit ;; mc68*:A/UX:*:*) echo m68k-apple-aux${UNAME_RELEASE} exit ;; news*:NEWS-OS:6*:*) echo mips-sony-newsos6 exit ;; R[34]000:*System_V*:*:* | R4000:UNIX_SYSV:*:* | R*000:UNIX_SV:*:*) if [ -d /usr/nec ]; then echo mips-nec-sysv${UNAME_RELEASE} else echo mips-unknown-sysv${UNAME_RELEASE} fi exit ;; BeBox:BeOS:*:*) # BeOS running on hardware made by Be, PPC only. echo powerpc-be-beos exit ;; BeMac:BeOS:*:*) # BeOS running on Mac or Mac clone, PPC only. echo powerpc-apple-beos exit ;; BePC:BeOS:*:*) # BeOS running on Intel PC compatible. echo i586-pc-beos exit ;; BePC:Haiku:*:*) # Haiku running on Intel PC compatible. echo i586-pc-haiku exit ;; SX-4:SUPER-UX:*:*) echo sx4-nec-superux${UNAME_RELEASE} exit ;; SX-5:SUPER-UX:*:*) echo sx5-nec-superux${UNAME_RELEASE} exit ;; SX-6:SUPER-UX:*:*) echo sx6-nec-superux${UNAME_RELEASE} exit ;; SX-7:SUPER-UX:*:*) echo sx7-nec-superux${UNAME_RELEASE} exit ;; SX-8:SUPER-UX:*:*) echo sx8-nec-superux${UNAME_RELEASE} exit ;; SX-8R:SUPER-UX:*:*) echo sx8r-nec-superux${UNAME_RELEASE} exit ;; Power*:Rhapsody:*:*) echo powerpc-apple-rhapsody${UNAME_RELEASE} exit ;; *:Rhapsody:*:*) echo ${UNAME_MACHINE}-apple-rhapsody${UNAME_RELEASE} exit ;; *:Darwin:*:*) UNAME_PROCESSOR=`uname -p` || UNAME_PROCESSOR=unknown case $UNAME_PROCESSOR in i386) eval $set_cc_for_build if [ "$CC_FOR_BUILD" != 'no_compiler_found' ]; then if (echo '#ifdef __LP64__'; echo IS_64BIT_ARCH; echo '#endif') | \ (CCOPTS= $CC_FOR_BUILD -E - 2>/dev/null) | \ grep IS_64BIT_ARCH >/dev/null then UNAME_PROCESSOR="x86_64" fi fi ;; unknown) UNAME_PROCESSOR=powerpc ;; esac echo ${UNAME_PROCESSOR}-apple-darwin${UNAME_RELEASE} exit ;; *:procnto*:*:* | *:QNX:[0123456789]*:*) UNAME_PROCESSOR=`uname -p` if test "$UNAME_PROCESSOR" = "x86"; then UNAME_PROCESSOR=i386 UNAME_MACHINE=pc fi echo ${UNAME_PROCESSOR}-${UNAME_MACHINE}-nto-qnx${UNAME_RELEASE} exit ;; *:QNX:*:4*) echo i386-pc-qnx exit ;; NEO-?:NONSTOP_KERNEL:*:*) echo neo-tandem-nsk${UNAME_RELEASE} exit ;; NSE-?:NONSTOP_KERNEL:*:*) echo nse-tandem-nsk${UNAME_RELEASE} exit ;; NSR-?:NONSTOP_KERNEL:*:*) echo nsr-tandem-nsk${UNAME_RELEASE} exit ;; *:NonStop-UX:*:*) echo mips-compaq-nonstopux exit ;; BS2000:POSIX*:*:*) echo bs2000-siemens-sysv exit ;; DS/*:UNIX_System_V:*:*) echo ${UNAME_MACHINE}-${UNAME_SYSTEM}-${UNAME_RELEASE} exit ;; *:Plan9:*:*) # "uname -m" is not consistent, so use $cputype instead. 386 # is converted to i386 for consistency with other x86 # operating systems. if test "$cputype" = "386"; then UNAME_MACHINE=i386 else UNAME_MACHINE="$cputype" fi echo ${UNAME_MACHINE}-unknown-plan9 exit ;; *:TOPS-10:*:*) echo pdp10-unknown-tops10 exit ;; *:TENEX:*:*) echo pdp10-unknown-tenex exit ;; KS10:TOPS-20:*:* | KL10:TOPS-20:*:* | TYPE4:TOPS-20:*:*) echo pdp10-dec-tops20 exit ;; XKL-1:TOPS-20:*:* | TYPE5:TOPS-20:*:*) echo pdp10-xkl-tops20 exit ;; *:TOPS-20:*:*) echo pdp10-unknown-tops20 exit ;; *:ITS:*:*) echo pdp10-unknown-its exit ;; SEI:*:*:SEIUX) echo mips-sei-seiux${UNAME_RELEASE} exit ;; *:DragonFly:*:*) echo ${UNAME_MACHINE}-unknown-dragonfly`echo ${UNAME_RELEASE}|sed -e 's/[-(].*//'` exit ;; *:*VMS:*:*) UNAME_MACHINE=`(uname -p) 2>/dev/null` case "${UNAME_MACHINE}" in A*) echo alpha-dec-vms ; exit ;; I*) echo ia64-dec-vms ; exit ;; V*) echo vax-dec-vms ; exit ;; esac ;; *:XENIX:*:SysV) echo i386-pc-xenix exit ;; i*86:skyos:*:*) echo ${UNAME_MACHINE}-pc-skyos`echo ${UNAME_RELEASE}` | sed -e 's/ .*$//' exit ;; i*86:rdos:*:*) echo ${UNAME_MACHINE}-pc-rdos exit ;; i*86:AROS:*:*) echo ${UNAME_MACHINE}-pc-aros exit ;; esac #echo '(No uname command or uname output not recognized.)' 1>&2 #echo "${UNAME_MACHINE}:${UNAME_SYSTEM}:${UNAME_RELEASE}:${UNAME_VERSION}" 1>&2 eval $set_cc_for_build cat >$dummy.c < # include #endif main () { #if defined (sony) #if defined (MIPSEB) /* BFD wants "bsd" instead of "newsos". Perhaps BFD should be changed, I don't know.... */ printf ("mips-sony-bsd\n"); exit (0); #else #include printf ("m68k-sony-newsos%s\n", #ifdef NEWSOS4 "4" #else "" #endif ); exit (0); #endif #endif #if defined (__arm) && defined (__acorn) && defined (__unix) printf ("arm-acorn-riscix\n"); exit (0); #endif #if defined (hp300) && !defined (hpux) printf ("m68k-hp-bsd\n"); exit (0); #endif #if defined (NeXT) #if !defined (__ARCHITECTURE__) #define __ARCHITECTURE__ "m68k" #endif int version; version=`(hostinfo | sed -n 's/.*NeXT Mach \([0-9]*\).*/\1/p') 2>/dev/null`; if (version < 4) printf ("%s-next-nextstep%d\n", __ARCHITECTURE__, version); else printf ("%s-next-openstep%d\n", __ARCHITECTURE__, version); exit (0); #endif #if defined (MULTIMAX) || defined (n16) #if defined (UMAXV) printf ("ns32k-encore-sysv\n"); exit (0); #else #if defined (CMU) printf ("ns32k-encore-mach\n"); exit (0); #else printf ("ns32k-encore-bsd\n"); exit (0); #endif #endif #endif #if defined (__386BSD__) printf ("i386-pc-bsd\n"); exit (0); #endif #if defined (sequent) #if defined (i386) printf ("i386-sequent-dynix\n"); exit (0); #endif #if defined (ns32000) printf ("ns32k-sequent-dynix\n"); exit (0); #endif #endif #if defined (_SEQUENT_) struct utsname un; uname(&un); if (strncmp(un.version, "V2", 2) == 0) { printf ("i386-sequent-ptx2\n"); exit (0); } if (strncmp(un.version, "V1", 2) == 0) { /* XXX is V1 correct? */ printf ("i386-sequent-ptx1\n"); exit (0); } printf ("i386-sequent-ptx\n"); exit (0); #endif #if defined (vax) # if !defined (ultrix) # include # if defined (BSD) # if BSD == 43 printf ("vax-dec-bsd4.3\n"); exit (0); # else # if BSD == 199006 printf ("vax-dec-bsd4.3reno\n"); exit (0); # else printf ("vax-dec-bsd\n"); exit (0); # endif # endif # else printf ("vax-dec-bsd\n"); exit (0); # endif # else printf ("vax-dec-ultrix\n"); exit (0); # endif #endif #if defined (alliant) && defined (i860) printf ("i860-alliant-bsd\n"); exit (0); #endif exit (1); } EOF $CC_FOR_BUILD -o $dummy $dummy.c 2>/dev/null && SYSTEM_NAME=`$dummy` && { echo "$SYSTEM_NAME"; exit; } # Apollos put the system type in the environment. test -d /usr/apollo && { echo ${ISP}-apollo-${SYSTYPE}; exit; } # Convex versions that predate uname can use getsysinfo(1) if [ -x /usr/convex/getsysinfo ] then case `getsysinfo -f cpu_type` in c1*) echo c1-convex-bsd exit ;; c2*) if getsysinfo -f scalar_acc then echo c32-convex-bsd else echo c2-convex-bsd fi exit ;; c34*) echo c34-convex-bsd exit ;; c38*) echo c38-convex-bsd exit ;; c4*) echo c4-convex-bsd exit ;; esac fi cat >&2 < in order to provide the needed information to handle your system. config.guess timestamp = $timestamp uname -m = `(uname -m) 2>/dev/null || echo unknown` uname -r = `(uname -r) 2>/dev/null || echo unknown` uname -s = `(uname -s) 2>/dev/null || echo unknown` uname -v = `(uname -v) 2>/dev/null || echo unknown` /usr/bin/uname -p = `(/usr/bin/uname -p) 2>/dev/null` /bin/uname -X = `(/bin/uname -X) 2>/dev/null` hostinfo = `(hostinfo) 2>/dev/null` /bin/universe = `(/bin/universe) 2>/dev/null` /usr/bin/arch -k = `(/usr/bin/arch -k) 2>/dev/null` /bin/arch = `(/bin/arch) 2>/dev/null` /usr/bin/oslevel = `(/usr/bin/oslevel) 2>/dev/null` /usr/convex/getsysinfo = `(/usr/convex/getsysinfo) 2>/dev/null` UNAME_MACHINE = ${UNAME_MACHINE} UNAME_RELEASE = ${UNAME_RELEASE} UNAME_SYSTEM = ${UNAME_SYSTEM} UNAME_VERSION = ${UNAME_VERSION} EOF exit 1 # Local variables: # eval: (add-hook 'write-file-hooks 'time-stamp) # time-stamp-start: "timestamp='" # time-stamp-format: "%:y-%02m-%02d" # time-stamp-end: "'" # End: algol68g-2.4.1/ChangeLog0000644000175000001440000000003411766475162011644 00000000000000Please refer to file "NEWS".