cafeobj-1.6.0/0000755000000000000000000000000013611232033011720 5ustar rootwheelcafeobj-1.6.0/dev-sbcl.lisp0000644000000000000000000000033613437136615014331 0ustar rootwheel(load "sysdef.asd") (load "cl-ppcre/cl-ppcre.asd") (push :chaos-debug *features*) (asdf:oos 'asdf:load-op :cl-ppcre) (asdf:oos 'asdf:load-op 'chaosx) (in-package :chaos) (set-cafeobj-libpath "/usr/local/share/cafeobj-1.5")cafeobj-1.6.0/sysdef.cl0000755000000000000000000002276313373141170013560 0ustar rootwheel;;; -*- Mode: LISP; Syntax: Common-lisp; Base: 10; Lowercase: T; -*- ;;; ;;; defsystem for Allegro CL (version 5.0 or higher) ;;; ;;; Copyright (c) 2000-2018, Toshimi Sawada. All rights reserved. ;;; ;;; Redistribution and use in source and binary forms, with or without ;;; modification, are permitted provided that the following conditions ;;; are met: ;;; ;;; * Redistributions of source code must retain the above copyright ;;; notice, this list of conditions and the following disclaimer. ;;; ;;; * Redistributions in binary form must reproduce the above ;;; copyright notice, this list of conditions and the following ;;; disclaimer in the documentation and/or other materials ;;; provided with the distribution. ;;; ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ;;; ;;; (in-package :common-lisp-user) (eval-when (eval load) (push :bigpink *features*) (push :cltl2 *features*) (require :asdf) #+(and :allegro :MSWINDOWS) (defun make-module-path-string (rel-path) (concatenate 'string (namestring (current-directory)) rel-path)) ) (excl:defsystem :cl-ppcre (:default-pathname #+:mswindows #.(make-module-path-string "cl-ppcre/") #-:mswindows "cl-ppcre/" :default-package :cl-ppcre) (:definitions "specials" (:serial "util" "errors" "charset" "charmap" "chartest" #-:use-acl-regexp2-engine "lexer" #-:use-acl-regexp2-engine "parser" #-:use-acl-regexp2-engine "regex-class" #-:use-acl-regexp2-engine "regex-class-util" #-:use-acl-regexp2-engine "convert" #-:use-acl-regexp2-engine "optimize" #-:use-acl-regexp2-engine "closures" #-:use-acl-regexp2-engine "repetition-closures" #-:use-acl-regexp2-engine "scanner" "api"))) (excl:defsystem :comlib (:default-pathname #+:mswindows #.(make-module-path-string "comlib/") #-:mswindows "comlib/" :default-package "CHAOS") (:definitions "globals" "macros" "message" "error" (:serial "print-utils" "misc" "string" "list" "dag" "fsys" "tree-display" "lex" "reader" "let-over-lambda" )) ) (excl:defsystem :chaos (:default-pathname #+:mswindows #.(make-module-path-string "chaos/") #-:mswindows "chaos/" :default-package "CHAOS") (:definitions :comlib (:module-group :primitives (:serial "primitives/bterm" "primitives/defterm" "primitives/bobject" "primitives/bflags" "primitives/absntax" "primitives/script" "primitives/op-theory" "primitives/bmodexp" "primitives/bmodule2" "primitives/bview2" "primitives/parse-modexp" "primitives/normodexp" "primitives/bsort" "primitives/boperator" "primitives/baxioms" "primitives/bmacro" "primitives/gen-eval" "primitives/meta" "primitives/gen-print" "primitives/context" "primitives/term-utils" "primitives/find" "primitives/print-object")) (:serial (:module-group :term-parser (:serial "term-parser/parse-macro" "term-parser/parse-engine" "term-parser/parse-top")) (:module-group :e-match (:serial "e-match/match-utils" "e-match/match-system" "e-match/match-state" "e-match/match-e" "e-match/match-idem" "e-match/match-z" "e-match/match-a" "e-match/match-c" "e-match/match-az" "e-match/match-cz" "e-match/match-ac" "e-match/match-acz" "e-match/match" "e-match/match2")) (:module-group :construct (:serial "construct/sort" "construct/operator" "construct/variable" "construct/match-method" "construct/axiom" "construct/gen-rule" "construct/rwl" "construct/beh" "construct/module" "construct/trs")) (:module-group :decafe (:serial "decafe/mutils" "decafe/modmorph" "decafe/mrmap" "decafe/meval" "decafe/view" "decafe/mimport")) (:module-group :cafein (:serial "cafein/rengine" "cafein/cbred" "cafein/reducer")) (:module-group :tools (:parallel "tools/regcheck" "tools/regularize" "tools/describe" "tools/sort-tree" "tools/module-tree" "tools/show" "tools/set" "tools/op-check" "tools/compat" "tools/help" "tools/inspect" "tools/sensible" ;; "psupport" )) (:module-group :eval (:parallel "eval/eval-mod" "eval/eval-ast" "eval/eval-ast2" "eval/chaos-top")) (:module-group :boot (:serial "boot/preproc" "boot/prelude" "boot/builtins")) (:module-group :tram (:serial "tram/tram")) (:module-group :psup (:serial "psup/psup")) ))) (excl:defsystem :chaosx (:default-pathname #+:mswindows #.(make-module-path-string "") #-:mswindows "./" :default-package "CHAOS") (:definitions "chaos-package" "version" (:definitions :cl-ppcre :chaos (:serial (:module-group :thstuff (:serial "thstuff/parse-apply" "thstuff/basics" "thstuff/eval-match" "thstuff/eval-apply" "thstuff/cexec" "thstuff/case" "thstuff/proof-struct" "thstuff/apply-tactic" "thstuff/citp" "thstuff/bterm-inspector")) (:module-group :bigpink (:definitions "BigPink/codes/types" "BigPink/codes/glob" "BigPink/codes/proof-sys" (:serial "BigPink/codes/syntax" "BigPink/codes/index" "BigPink/codes/butils" "BigPink/codes/unify" "BigPink/codes/clause" "BigPink/codes/formula" "BigPink/codes/modconv" "BigPink/codes/weight" "BigPink/codes/lrpo" "BigPink/codes/resolve" "BigPink/codes/paramod" "BigPink/codes/demod" "BigPink/codes/infer" "BigPink/codes/sigmatch" "BigPink/codes/refine" "BigPink/codes/commands" "BigPink/codes/inv"))) (:module-group :cafeobj (:definitions "cafeobj/cafeobjvar" (:serial "cafeobj/creader" "cafeobj/oldoc" "cafeobj/define" "cafeobj/trans-com" "cafeobj/trans-decl" ;; "cafeobj/command-proc" "cafeobj/command-top" "cafeobj/commands" "cafeobj/declarations" "cafeobj/cafeobj-top"))) "acl-init" )))) ;;; EOF cafeobj-1.6.0/init0000644000000000000000000000263213373141170012617 0ustar rootwheel-- -- Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. -- -- Redistribution and use in source and binary forms, with or without -- modification, are permitted provided that the following conditions -- are met: -- -- * Redistributions of source code must retain the above copyright -- notice, this list of conditions and the following disclaimer. -- -- * Redistributions in binary form must reproduce the above -- copyright notice, this list of conditions and the following -- disclaimer in the documentation and/or other materials -- provided with the distribution. -- -- THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED -- OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -- WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE -- ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY -- DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE -- GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -- INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, -- WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING -- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS -- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -- set libpath /usr/local/cafeobj-1.4/lib set libpath + /usr/local/cafeobj-1.4/prelude in std cafeobj-1.6.0/dev.cl0000644000000000000000000000011213421746574013033 0ustar rootwheel(in-package :chaos) (set-cafeobj-libpath "/usr/local/share/cafeobj-1.5") cafeobj-1.6.0/install-sh0000755000000000000000000003325513373141170013742 0ustar rootwheel#!/bin/sh # install - install a program, script, or datafile scriptversion=2011-11-20.07; # UTC # This originates from X11R5 (mit/util/scripts/install.sh), which was # later released in X11R6 (xc/config/util/install.sh) with the # following copyright and license. # # Copyright (C) 1994 X Consortium # # Permission is hereby granted, free of charge, to any person obtaining a copy # of this software and associated documentation files (the "Software"), to # deal in the Software without restriction, including without limitation the # rights to use, copy, modify, merge, publish, distribute, sublicense, and/or # sell copies of the Software, and to permit persons to whom the Software is # furnished to do so, subject to the following conditions: # # The above copyright notice and this permission notice shall be included in # all copies or substantial portions of the Software. # # THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR # IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, # FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE # X CONSORTIUM BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN # AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNEC- # TION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. # # Except as contained in this notice, the name of the X Consortium shall not # be used in advertising or otherwise to promote the sale, use or other deal- # ings in this Software without prior written authorization from the X Consor- # tium. # # # FSF changes to this file are in the public domain. # # Calling this script install-sh is preferred over install.sh, to prevent # 'make' implicit rules from creating a file called install from it # when there is no Makefile. # # This script is compatible with the BSD install script, but was written # from scratch. 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 # Protect names problematic for 'test' and other utilities. case $dst_arg in -* | [=\(\)!]) dst_arg=./$dst_arg;; esac 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 # Protect names problematic for 'test' and other utilities. case $dst_arg in -* | [=\(\)!]) dst_arg=./$dst_arg;; esac done fi if test $# -eq 0; then if test -z "$dir_arg"; then echo "$0: no input file specified." >&2 exit 1 fi # It's OK to call 'install-sh -d' without argument. # This can happen when creating conditional directories. exit 0 fi if test -z "$dir_arg"; then do_exit='(exit $ret); exit $ret' trap "ret=129; $do_exit" 1 trap "ret=130; $do_exit" 2 trap "ret=141; $do_exit" 13 trap "ret=143; $do_exit" 15 # Set umask so as not to create temps with too-generous modes. # However, 'strip' requires both read and write access to temps. case $mode in # Optimize common cases. *644) cp_umask=133;; *755) cp_umask=22;; *[0-7]) if test -z "$stripcmd"; then u_plus_rw= else u_plus_rw='% 200' fi cp_umask=`expr '(' 777 - $mode % 1000 ')' $u_plus_rw`;; *) if test -z "$stripcmd"; then u_plus_rw= else u_plus_rw=,u+rw fi cp_umask=$mode$u_plus_rw;; esac fi for src do # Protect names problematic for 'test' and other utilities. case $src in -* | [=\(\)!]) src=./$src;; esac if test -n "$dir_arg"; then dst=$src dstdir=$dst test -d "$dstdir" dstdir_status=$? else # Waiting for this to be detected by the "$cpprog $src $dsttmp" command # might cause directories to be created, which would be especially bad # if $src (and thus $dsttmp) contains '*'. if test ! -f "$src" && test ! -d "$src"; then echo "$0: $src does not exist." >&2 exit 1 fi if test -z "$dst_arg"; then echo "$0: no destination specified." >&2 exit 1 fi dst=$dst_arg # If destination is a directory, append the input filename; 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-writable 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 X"$d" = X && continue prefix=$prefix$d if test -d "$prefix"; then prefixes= else if $posix_mkdir; then (umask=$mkdir_umask && $doit_exec $mkdirprog $mkdir_mode -p -- "$dstdir") && break # Don't fail if two instances are running concurrently. test -d "$prefix" || exit 1 else case $prefix in *\'*) qprefix=`echo "$prefix" | sed "s/'/'\\\\\\\\''/g"`;; *) qprefix=$prefix;; esac prefixes="$prefixes '$qprefix'" fi fi prefix=$prefix/ done if test -n "$prefixes"; then # Don't fail if two instances are running concurrently. (umask $mkdir_umask && eval "\$doit_exec \$mkdirprog $prefixes") || test -d "$dstdir" || exit 1 obsolete_mkdir_used=true fi fi fi if test -n "$dir_arg"; then { test -z "$chowncmd" || $doit $chowncmd "$dst"; } && { test -z "$chgrpcmd" || $doit $chgrpcmd "$dst"; } && { test "$obsolete_mkdir_used$chowncmd$chgrpcmd" = false || test -z "$chmodcmd" || $doit $chmodcmd $mode "$dst"; } || exit 1 else # Make a couple of temp file names in the proper directory. dsttmp=$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-time-zone: "UTC" # time-stamp-end: "; # UTC" # End: cafeobj-1.6.0/configure.ac0000644000000000000000000002263713611175647014241 0ustar rootwheeldnl configure.ac for Chaos(CafeOBJ) dnl apply autoconf to this file for producing a configure script. dnl dnl Copyright (c) 2000-2018, Toshimi Sawada. All rights reserved. dnl Copyright (c) 2014-2018, Norbert Preining. All rights reserved. dnl dnl Redistribution and use in source and binary forms, with or without dnl modification, are permitted provided that the following conditions dnl are met: dnl dnl * Redistributions of source code must retain the above copyright dnl notice, this list of conditions and the following disclaimer. dnl dnl * Redistributions in binary form must reproduce the above dnl copyright notice, this list of conditions and the following dnl disclaimer in the documentation and/or other materials dnl provided with the distribution. dnl dnl THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED dnl OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED dnl WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE dnl ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY dnl DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL dnl DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE dnl GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS dnl INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, dnl WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING dnl NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS dnl SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. dnl AC_INIT([CafeOBJ],[1.6], [], [cafeobj], [http://www.cafeobj.org/]) AC_CONFIG_SRCDIR([make-cafeobj.lisp.in]) AC_PREREQ(2.6) VMINOR=.0 VMEMO=PigNose0.99 PATCHLEVEL= AC_SUBST(VMINOR) AC_SUBST(VMEMO) AC_SUBST(PATCHLEVEL) AC_ARG_PROGRAM AC_PROG_INSTALL dnl allow for specifying different names for cmd line interpreter dnl dnl disable currently not supported interpreter dnl but make them available on request! AC_ARG_WITH(sbcl, [AS_HELP_STRING([--with-sbcl=], [specify the SBCL interpreter @<:@default: sbcl@:>@])], sbcl_interp=$withval,sbcl_interp=sbcl) sbcl_dump=cafeobj.sbcl AC_ARG_WITH(acl, [AS_HELP_STRING([--with-acl=], [specify the ACL interpreter @<:@default: alisp@:>@])], acl_interp=$withval,acl_interp=alisp) acl_dump=cafeobj.acl dnl this is the dump file name generated for ACL standalone acl_standalone_dump=CafeOBJ AC_ARG_WITH(clisp, [AS_HELP_STRING([--with-clisp=], [specify the CLISP interpreter @<:@default: clisp@:>@])], clisp_interp=$withval,clisp_interp=clisp) clisp_dump=cafeobj.mem dnl AC_ARG_WITH(ccl32, dnl [AS_HELP_STRING([--with-ccl32=], dnl [specify the CCL(32) interpreter @<:@default: ccl@:>@])], dnl ccl32_interp=$withval,ccl32_interp=ccl) ccl32_interp=ccl ccl32_dump=cafeobj.img dnl AC_ARG_WITH(ccl64, dnl [AS_HELP_STRING([--with-ccl64=], dnl [specify the CCL64 interpreter @<:@default: ccl64@:>@])], dnl ccl64_interp=$withval,ccl64_interp=ccl64) ccl64_interp=ccl64 ccl64_dump=cafeobj.img dnl AC_ARG_WITH(gcl, dnl [AS_HELP_STRING([--with-gcl=], dnl [specify the GCL interpreter @<:@default: gcl@:>@])], dnl gcl_interp=$withval,gcl_interp=gcl) gcl_interp=gcl gcl_dump=cafeobj.exe dnl AC_ARG_WITH(cmu, dnl [AS_HELP_STRING([--with-cmu=], dnl [specify the CMU interpreter @<:@default: lisp@:>@])], dnl cmu_interp=$withval,cmu_interp=lisp) cmu_interp=lisp cmu_dump=cafeobj.core AC_PATH_PROG(gcl_path,gcl) AC_PATH_PROG(cmu_path,$cmu_interp) AC_PATH_PROG(sbcl_path,$sbcl_interp) AC_PATH_PROG(acl_path,$acl_interp) AC_PATH_PROG(clisp_path,$clisp_interp) AC_PATH_PROG(ccl32_path,$ccl32_interp) AC_PATH_PROG(ccl64_path,$ccl64_interp) AC_PROG_MAKE_SET AC_PROG_MKDIR_P AC_ARG_WITH(lisp, [AS_HELP_STRING([--with-lisp=all|@<:@,@:>@], [specify a list of lisp interpreters from "acl", "sbcl", or "clisp". Alternatively "all" can be specified to select all available.])], lisp=$withval) if test "x$lisp" = "x" then # no lisp specified, select one by default # we disable the currently not building ones!!! if test -n "$acl_path" ; then lisp=acl ; elif test -n "$sbcl_path" ; then lisp=sbcl ; elif test -n "$clisp_path" ; then lisp=clisp ; # elif test -n "$gcl_path" ; then lisp=gcl ; # elif test -n "$cmu_path" ; then lisp=cmu ; # elif test -n "$ccl32_path" ; then lisp=ccl ; # elif test -n "$ccl64_path" ; then lisp=ccl64 ; else AC_MSG_ERROR([no supported lisp interpreter found]) fi fi dnl support building for all interpreters do_all=0 if test "x$lisp" = "xall" then do_all=1 # this is the preferred order of interpreters!! # if nothing is specified, the first one found will be used! #lisp=acl,sbcl,clisp,gcl,cmu,ccl,ccl64 # use only currently supported ones lisp=acl-standalone,acl,sbcl,clisp fi dnl convert comma serparated list to space separated list lisp=$(echo $lisp | sed -e 's/,/ /g') goodlisp= firstchoice= for i in $lisp do case "x$i" in xcmu|xcmu-pc) if test -z "$cmu_path" then test $do_all = 1 || \ AC_MSG_ERROR([selected lisp interpreter $i is not available]) else goodlisp="$goodlisp $i" if test "x$firstchoice" = x then firstchoice=$i fi fi ;; xsbcl) if test -z "$sbcl_path" then test $do_all = 1 || \ AC_MSG_ERROR([selected lisp interpreter $i is not available]) else goodlisp="$goodlisp $i" if test "x$firstchoice" = x then firstchoice=$i fi fi ;; xacl|xacl-standalone) if test -z "$acl_path" then test $do_all = 1 || \ AC_MSG_ERROR([selected lisp interpreter $i is not available]) else goodlisp="$goodlisp $i" if test "x$firstchoice" = x then firstchoice=$i fi fi ;; xclisp) if test -z "$clisp_path" then test $do_all = 1 || \ AC_MSG_ERROR([selected lisp interpreter $i is not available]) else goodlisp="$goodlisp $i" if test "x$firstchoice" = x then firstchoice=$i fi fi ;; xccl) if test -z "$ccl32_path" then test $do_all = 1 || \ AC_MSG_ERROR([selected lisp interpreter $i is not available]) else goodlisp="$goodlisp $i" if test "x$firstchoice" = x then firstchoice=$i fi fi ;; xccl64) if test -z "$ccl64_path" then test $do_all = 1 || \ AC_MSG_ERROR([selected lisp interpreter $i is not available]) else goodlisp="$goodlisp $i" if test "x$firstchoice" = x then firstchoice=$i fi fi ;; xgcl) if test -z "$gcl_path" then test $do_all = 1 || \ AC_MSG_ERROR([selected lisp interpreter $i is not available]) else goodlisp="$goodlisp $i" if test "x$firstchoice" = x then firstchoice=$i fi fi ;; *) AC_MSG_ERROR([unknown lisp interpreter $i]) ;; esac done lisp="$goodlisp" if test -z "$lisp" then AC_MSG_ERROR([no usable lisp interpreter]) fi AC_MSG_NOTICE([Building for the following lisp interpreters: $lisp]) dnl check for emacs and lispdir AM_PATH_LISPDIR AC_SUBST(lisp) AC_SUBST(firstchoice) AC_SUBST(acl_interp) AC_SUBST(sbcl_interp) AC_SUBST(clisp_interp) AC_SUBST(cmu_interp) AC_SUBST(ccl32_interp) AC_SUBST(ccl64_interp) AC_SUBST(gcl_interp) AC_SUBST(acl_dump) AC_SUBST(acl_standalone_dump) AC_SUBST(sbcl_dump) AC_SUBST(clisp_dump) AC_SUBST(cmu_dump) AC_SUBST(ccl32_dump) AC_SUBST(ccl64_dump) AC_SUBST(gcl_dump) # test for 64/32 bit AC_CHECK_SIZEOF([long]) AS_IF([test "$ac_cv_sizeof_long" -eq 8], [AC_SUBST([OSBIT],64)], [AC_SUBST([OSBIT],32)]) AC_ARG_ENABLE([rebuild_doc], [AS_HELP_STRING([--enable-rebuild-doc], [Enable the rebuilding of documentation (not implemented) @<:@default=no@:>@])], [enable_rebuild_doc="${enableval}"], [enable_rebuild_doc=no]) if test x"$enable_rebuild_doc" = x"yes" then dnl check for documentation building programs AC_CHECK_PROG(xelatex_avail, [xelatex], [yes], [no]) AC_CHECK_PROG(bibtex_avail, [bibtex], [yes], [no]) AC_CHECK_PROG(pandoc_avail, [pandoc], [yes], [no]) AC_CHECK_PROG(pdflatex_avail, [pdflatex], [yes], [no]) if test $xelatex_avail = no \ -o $bibtex_avail = no \ -o $pandoc_avail = no \ -o $pdflatex_avail = no then AC_MSG_NOTICE([Not all TeX related programs are found, disabling rebuild of documentation.]) enable_rebuild_doc=no fi fi AC_SUBST(enable_rebuild_doc) AC_ARG_ENABLE(traditional_layout, [AS_HELP_STRING([--enable-traditional-layout], [Enable traditional layout @<:@default=no@:>@])], [enable_traditional_layout="${enableval}"], [enable_traditional_layout=no]) AC_SUBST(enable_traditional_layout) AC_ARG_ENABLE(windows, [AS_HELP_STRING([--enable-windows], [Prepare for Windows building])], [enable_windows="${enableval}"], [enable_windows=no]) AC_SUBST(enable_windows) AC_ARG_ENABLE(distribution, [AS_HELP_STRING([--enable-distribution], [Configure for binary distribution])], [enable_distribution="${enableval}"], [enable_distribution=no]) AC_SUBST(enable_distribution) AC_CONFIG_FILES([ Makefile make-cafeobj.lisp version.lisp xbin/cafeobj.in doc/refman/Makefile doc/manual/Makefile doc/RefCard/Makefile doc/PigNose/Makefile doc/citp-manual/Makefile doc/namespace/Makefile doc/etc/Makefile doc/search/Makefile ]) AC_OUTPUT() cafeobj-1.6.0/chaos-package.lisp0000644000000000000000000001032413373141167015313 0ustar rootwheel;;;-*- Mode:LISP; Package: COMMON-LISP-USER; Base:10; Syntax:Common-Lisp -*- ;;; ;;; Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. ;;; ;;; Redistribution and use in source and binary forms, with or without ;;; modification, are permitted provided that the following conditions ;;; are met: ;;; ;;; * Redistributions of source code must retain the above copyright ;;; notice, this list of conditions and the following disclaimer. ;;; ;;; * Redistributions in binary form must reproduce the above ;;; copyright notice, this list of conditions and the following ;;; disclaimer in the documentation and/or other materials ;;; provided with the distribution. ;;; ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ;;; #+LUCID (in-package "user") #+Excl (in-package :user) #+:ccl (in-package :common-lisp-user) #+gcl (in-package :user) #+Excl (eval-when (:execute :compile-toplevel :load-toplevel) (require 'loop)) #+:GCL (use-package :defpackage :common-lisp-user) #| (defpackage "FMCS" (:use #+:GCL "LISP" #-:GCL "COMMON-LISP" #+:MCL "CCL" #+:EXCL "EXCL") (:shadow "DEFCLASS" "DEFMETHOD" "MAKE-INSTANCE" "SLOT-VALUE" "STANDARD-OBJECT" "STANDARD-CLASS" "SELF" "CALL-NEXT-METHOD") (:export "*REDEFINE-WARNINGS*" "SELF" "$SLOT" "DEF$FLAVOR" "DEF$METHOD" "UNDEF$METHOD" "DEF$FRAME" "DEF$BEHAVIOR" "TRACE$METHOD" "UNTRACE$METHOD" "IS-TRACED$METHOD" "COMPILE-$FLAVOR-$METHODS" "DEFWHOPPER" "CONTINUE-WHOPPER" "$SEND" "LEXPR-$SEND" "FLAVORP" "FLAVOR-INSTANCEP" "FLAVOR-TYPEP" "FLAVOR-TYPE-OF" "GET-FLAVOR-INSTANCE-SLOTS" "SYMBOL-VALUE-IN-$INSTANCE" "MAKE-$INSTANCE" "MAKE-WINDOW-OR-INSTANCE" "MCS-TRACE" "MCS-UNTRACE" "MCS-IS-TRACED")) |# (pushnew :bigpink *features*) #+:mswindows (pushnew :cltl2 *features*) (require :asdf) (defpackage :cl-ppcre-asd (:use :cl :asdf)) (defpackage :cl-ppcre (:nicknames :ppcre) #+:genera (:shadowing-import-from :common-lisp :lambda :simple-string :string) (:use #-:genera :cl #+:genera :future-common-lisp) (:shadow :digit-char-p :defconstant) (:export :parse-string :create-scanner :create-optimized-test-function :parse-tree-synonym :define-parse-tree-synonym :scan :scan-to-strings :do-scans :do-matches :do-matches-as-strings :all-matches :all-matches-as-strings :split :regex-replace :regex-replace-all :regex-apropos :regex-apropos-list :quote-meta-chars :*regex-char-code-limit* :*use-bmh-matchers* :*allow-quoting* :*allow-named-registers* :*optimize-char-classes* :*property-resolver* :ppcre-error :ppcre-invocation-error :ppcre-syntax-error :ppcre-syntax-error-string :ppcre-syntax-error-pos :register-groups-bind :do-register-groups)) (defpackage "CHAOS" (:shadow "METHOD-NAME" "METHOD" "MAKE-METHOD" #-:GCL "OBJECT" ;; #+(:ALLEGRO-VERSION>= 7.0) "WHILE" #+:EXCL "CLASS" "TIMER" "MODULE" "MODULE-P" "LOAD-FILE" ) (:use #+:GCL "LISP" #-:GCL "COMMON-LISP" ;; "FMCS" #+:MCL "CCL" #+:EXCL "EXCL" #+:GCL "DEFPACKAGE" ;; #+:common-graphics "COMMON-GRAPHICS" ) ) cafeobj-1.6.0/INSTALL0000644000000000000000000001452113420023427012757 0ustar rootwheel --------------------------------------------- CafeOBJ Interpreter Installation Instructions --------------------------------------------- ============ Prerequisite ============ CafeOBJ interpreter is built on Common Lisp, thus you need some Common Lisp system to install CafeOBJ. CafeOBJ can be built on the following platforms: (1) SBCL version 1.1.7 (or later) http://www.sbcl.org/ (2) Allegro CL version 8.0 (or later) http://franz.com/ (3) CLISP version 2.4.9 (or later) http://www.clisp.org/ At least one of these needs to be installed in the users' PATH. Considerations concering redestribution --------------------------------------- Building the CafeOBJ interpreter with SBCL allows for redistribution without the need for SBCL being installed, as the dump itself can be executed. This is also possible with Allegro CL, but needs a specific license obtainable from Franz. With CLISP the interpreter has to be installed at the target system. ======== BUILDING ======== Building is done in the usual way with running the following commands in the source directory: ./configure make (sudo) make install See below for possible configuration. ====================== 1) configure arguments ====================== a) Selection of a lisp platform ------------------------------- Selection of the Common Lisp platform to build the CafeOBJ interpreter is done with the configure option --with-lisp as in ./configure --with-lisp="platform"[,"platform"] You can specify a list of interpreters to be used to build CafeOBJ. The wrapper provides the command line option --engine to select one of the underlying interpreters. "platform" should be one of the followings, and should provide the following command line program name configure argument program name sbcl sbcl -- SBCL acl alisp -- Allegro CL acl-standalone alisp -- Allegro CL with distribution license clisp clisp -- CLISP You must have one of these command in your PATH environment. -with-lisp="platform" can be omitted, in this case it selects the first interpreter found by testing in the following order: acl-standalone, acl, sbcl, clisp Finally, one can use -with-lisp=all which builds for all found Common Lisp platforms. In case your interpreter is named different than the above, you can override it with --with-sbcl= --with-acl= --with-clisp= Using the cafeobj command line argument --engine one can select the engine at run time. By default the one first listed in the configure call will be used. b) Installation location ------------------------ Be default CafeOBJ is installed in GNU standard compliant directories, that is $prefix/bin/ -- cafeobj - a shell script that invokes the necessary programs to start the CafeOBJ interpreter. (configure option --bindir) $prefix/lib/cafeobj-N.M/ -- dump files for the various lisp platforms (configure option --libdir + cafeobj-N.M) $prefix/share/cafeobj-N.M/lib/ -- standard libraries, if you made cafeobj with PigNose, fopl.mod will be put here. (configure option --datarootdir + cafeobj-N.M/lib) $prefix/share/cafeobj-N.M/prelude/ -- cafeobj standard prelude files. (configure option --datarootdir + cafeobj-N.M/prelude) $prefix/share/doc/cafeobj/ -- documentation and example files (configure option --docdir + cafeobj) $prefix is by default /usr/local, but can be selected with --prefix= during the configure run. There is also --enable-traditional-layout which selects traditional layout of the files, which is $prefix/bin/ -- cafeobj - a shell script that invokes the necessary programs to start the CafeOBJ interpreter. $prefix/cafeobj-N.M/bin/ -- necessary programs to start the CafeOBJ interpreter. and the dump files for the various lisp platforms $prefix/cafeobj-N.M/lib/ -- standard libraries, if you made cafeobj with PigNose, fopl.mod will be put here. $prefix/cafeobj-N.M/prelude/ -- cafeobj standard prelude files. $prefix/cafeobj-N.M/doc/ -- documentation and example files c) Rebuilding documentation pdfs -------------------------------- The configure switch --enable-rebuild-doc triggers a rebuild of all pdfs. Since some of these need special fonts and Japanese TeX systems to correctly produce pdfs, we recommend not using this. d) Emacs support file --------------------- We distribute an Emacs major mode in cafeobj-mode.el. The configure script will search for an installation of Emacs (binary emacs or xemacs) and install the elisp file into the respective site-lisp path. The selected destination can be adjusted with --with-lispdir Furthermore, the used emacs can be influenced with the EMACS and EMACSLOADPATH environment variables. =========================== 2) Building the interpreter =========================== Try building the CafeOBJ by invoking make This will make the needed CafeOBJ binaries within the sub directories. If something fails for your system, and you want to submit a bug report, you may wish to include your "config.status" file, your host type, operating system and information about the used Common Lisp interpreter including version number, make output, and anything else you think will be helpful. ======================= 3) Installing the files ======================= Invoke make install or, if you don't have permissions, maybe sudo make install This will install CafeOBJ interpreter (cafeobj). Staged installes are supported in two ways: make install DESTDIR= prefix all installations with $DESTDIR. make install prefix= will override the prefix set during initial configuration. Be warned that in this case the cafeobj script might not find the dumps. =========== 4) Clean up =========== (optional) By invoking make clean generated files are removed, but configuration remains as is. If you want to go back to a clean state of pre-configuration, use make distclean -- EOF cafeobj-1.6.0/deliver.cl0000755000000000000000000000735413373141170013714 0ustar rootwheel;;; -*- Mode: LISP; Syntax: Common-Lisp -*- ;;; ;;; Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. ;;; ;;; Redistribution and use in source and binary forms, with or without ;;; modification, are permitted provided that the following conditions ;;; are met: ;;; ;;; * Redistributions of source code must retain the above copyright ;;; notice, this list of conditions and the following disclaimer. ;;; ;;; * Redistributions in binary form must reproduce the above ;;; copyright notice, this list of conditions and the following ;;; disclaimer in the documentation and/or other materials ;;; provided with the distribution. ;;; ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ;;; (in-package :common-lisp-user) (eval-when (eval load) (load "chaos-package.fasl") ) (defun make-app (path) (generate-application "CafeOBJ" #-:mswindows "dumps/acl-standalone/" #+:mswindows "dist/cafeobj-1.5/" '("pignose.fasl" :emacs :eli :sock :process :acldns :collate :euc :ffcompat :list2 :fileutil :foreign :trace ;; :hmac :locale :regexp2 #-:mswindows :sigio ;; :ssl :streama :streamm :streamc :streamp) :application-type :exe :print-startup-message nil :allow-existing-directory t :copy-shared-libraries t :read-init-files nil :restart-app-function 'chaos::cafeobj-top-level ;; :restart-init-function 'chaos::chaos-init-fun :runtime :standard :suppress-allegro-cl-banner t :runtime-bundle t :include-compiler nil ;; :record-source-file-info nil ;; :record-xref-info nil ;; :load-source-file-info nil ;; :load-xref-info nil ;; :load-local-names-info nil :autoload-warning t :discard-local-name-info t :discard-source-file-info t ;; :discard-xref-into t :discard-arglists t :application-administration '(#+:mswindows (:batch-file "cafeobj.bat") ) )) (eval-when (eval load) (make-app nil)) ;;; EOF cafeobj-1.6.0/xbin/0000755000000000000000000000000013611200733012662 5ustar rootwheelcafeobj-1.6.0/xbin/cafeobj.sbcl.bat0000644000000000000000000000005113373141170015665 0ustar rootwheel%~dps0\sbcl\cafeobj.sbcl -prefix %~dps0 cafeobj-1.6.0/xbin/cafeobj.in.in0000644000000000000000000001267313373141170015225 0ustar rootwheel#!/bin/sh # # cafeobj wrapper script # # Copyright (c) 2000-2014 Toshimi Sawada. All rights reserved. # Copyright (c) 2014-2015 Norbert Preining. All rights reserved. # # Redistribution and use in source and binary forms, with or without # modification, are permitted provided that the following conditions # are met: # # * Redistributions of source code must retain the above copyright # notice, this list of conditions and the following disclaimer. # # * Redistributions in binary form must reproduce the above # copyright notice, this list of conditions and the following # disclaimer in the documentation and/or other materials # provided with the distribution. # # THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED # OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED # WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE # ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY # DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL # DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE # GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS # INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, # WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING # NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS # SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. # # TODO # - cmd line for ignoring choices, or extending it with # imagine dist install with local alisp!!! acl_interp=@acl_interp@ sbcl_interp=@sbcl_interp@ cmu_interp=@cmu_interp@ clisp_interp=@clisp_interp@ gcl_interp=@gcl_interp@ ccl32_interp=@ccl32_interp@ ccl64_interp=@ccl64_interp@ # support traditional layout traditional_layout=@enable_traditional_layout@ extra= if test "x@enable_traditional_layout@" = "xyes" ; then extra=bin/ fi acl_dump=${extra}acl/@acl_dump@ acl_standalone_dump=${extra}acl-standalone/@acl_standalone_dump@ sbcl_dump=${extra}sbcl/@sbcl_dump@ cmu_dump=${extra}cmu/@cmu_dump@ clisp_dump=${extra}clisp/@clisp_dump@ gcl_dump=${extra}gcl/@gcl_dump@ ccl32_dump=${extra}ccl/@ccl32_dump@ ccl64_dump=${extra}ccl64/@ccl64_dump@ binpath=`dirname "$0"` libpath="$binpath/../@LIBPATH@" sharepath="$binpath/../@SHAREPATH@" dohelp=0 engine=@FIRSTCHOICE@ while [ $# -gt 0 ] do key="$1" case $key in # don't shift away, will be handled by the cafeobj interpreter -h|-help|--help) dohelp=1 ; break ;; -engine|--engine) shift ; engine="$1" ; shift ;; -wrapper-libpath|--wrapper-libpath) shift ; libpath="$1" ; shift ;; -wrapper-sharepath|--wrapper-sharepath) shift ; sharepath="$1" ; shift ;; -list-engines|--list-engines) shift engines="" if [ -r "$libpath/$ccl32_dump" ] ; then engines="ccl $engines" ; fi if [ -r "$libpath/$ccl64_dump" ] ; then engines="ccl64 $engines" ; fi if [ -r "$libpath/$gcl_dump" ] ; then engines="gcl $engines" ; fi if [ -r "$libpath/$cmu_dump" ] ; then engines="cmu $engines" ; fi if [ -r "$libpath/$clisp_dump" ] ; then engines="clisp $engines" ; fi if [ -r "$libpath/$sbcl_dump" ] ; then engines="sbcl $engines" ; fi if [ -r "$libpath/$acl_standalone_dump" ] ; then engines="acl-standalone $engines" ; fi if [ -r "$libpath/$acl_dump" -o -r "$libpath/$acl_standalone_dump" ] ; then engines="acl $engines" ; fi echo "Available engine dumps: $engines" exit 0 ;; --) break ;; *) break ;; esac done if [ "$dohelp" = 1 ] ; then echo ' Usage: cafeobj [wrapper-options] [options] files ... Wrapper options: -engine NAME select the underlying Common Lisp engine. -list-engines lists all available common lisp engines -wrapper-libpath PATH sets the path to memory dumps -wrapper-sharepath PATH sets the path to CafeOBJ initialization files ' fi case "x$engine" in xacl) if [ -r "$libpath/$acl_dump" ] ; then exec "$acl_interp" -I "$libpath/$acl_dump" -- -prefix "$sharepath" $* elif [ -r "$libpath/$acl_standalone_dump" ] ; then exec "$libpath/$acl_standalone_dump" -- -prefix "$sharepath" $* else echo "ACL dump file not found: $libpath/$acl_dump" 2>&1 exit 1 fi ;; xacl-standalone) if [ -r "$libpath/$acl_standalone_dump" ] ; then exec "$libpath/$acl_standalone_dump" -- -prefix "$sharepath" $* else echo "ACL standalone dump file not found: $libpath/$acl_standalone_dump" 2>&1 exit 1 fi ;; xclisp) if [ -r "$libpath/$clisp_dump" ] ; then exec "$clisp_interp" -M "$libpath/$clisp_dump" $* else echo "CLISP dump file not found: $libpath/$clisp_dump" 2>&1 exit 1 fi ;; xcmu) if [ -r "$libpath/$cmu_dump" ] ; then exec "$cmu_interp" -core "$libpath/$cmu_dump" $* else echo "CMU dump file not found: $libpath/$cmu_dump" 2>&1 exit 1 fi ;; xgcl) if [ -r "$libpath/$gcl_dump" ] ; then exec "$libpath/$gcl_dump" $* else echo "GCL dump file not found: $libpath/$gcl_dump" 2>&1 exit 1 fi ;; xccl) if [ -r "$libpath/$ccl_dump" ] ; then exec "$ccl_interp" "$libpath/$ccl_dump" $* else echo "CCL dump file not found: $libpath/$ccl_dump" 2>&1 exit 1 fi ;; xccl64) if [ -r "$libpath/$ccl64_dump" ] ; then exec "$ccl64_interp" "$libpath/$ccl64_dump" $* else echo "CCL64 dump file not found: $libpath/$ccl64_dump" 2>&1 exit 1 fi ;; xsbcl) if [ -r "$libpath/$sbcl_dump" ] ; then exec "$libpath/$sbcl_dump" -prefix "$sharepath" $* else echo "SBCL dump file not found: $libpath/$sbcl_dump" 2>&1 exit 1 fi ;; *) echo "CafeOBJ: unknown engine selection $engine" >&2 exit 1 ;; esac cafeobj-1.6.0/#NEWS#0000644000000000000000000001360713611225600012536 0ustar rootwheel* CafeOBJ 1.6.0 =============== - CITP is officially renamed to PTCalc . but documents are not updated yet - PTCalc(CITP) enhacements . :init defined by :def is evaluated in the proof node to which it is applied . :init without substitution can be specified - Search predicate enhancements . nested search is properly handled . 'show path' accepts state specifier of the form 'depth-state' - Several bug fixes * CafeOBJ 1.5.8 =============== - Several bug fixes . make 'variables as constants' to only apply in the context of :init . id-completion should not aplied to non-exec axioms . minor bug fixes in making id conditions . fix inapropreate context handling in parameterized module - New command :bgrind/bgrind . prints xor-and normal form in 'grind' manner * CafeOBJ 1.5.7 =============== - CITP enhancements - adaption for newer SBCL * CafeOBJ 1.5.6 =============== - CITP enhancements * CafeOBJ 1.5.5 =============== - Enhancemets of a family of Bool term inspector commands: . 'binspect [ in : ] .' converts given into abstracted xor-and normal form . 'bshow [ tree | grind ]' shows abstracted Bool term . 'bresolve [ [ { | all } ] ] shows assignments which make abstracted Bool term true . 'bguess { imply | and | or }' tries with some heuristics to solve the abstracted Bool term - bug fix in ACZ rewriting - CITP changes . :ctf [ ] accepts constructors with arguments . new command :imply to make instantiated lhs of existing equation of the form 'eq lhs = true' a premise of a goal sentence . new tactic rd- which is similar to rd but cancels the normalization of the goal sentence if the sentence is not satisfied. - new switch 'tree horizontal'. if on 'show term tree' displays the term tree structure horizontally (default off). * CafeOBJ 1.5.4 =============== - CITP changes . new commands :ctf- and :csp- . new command :def(ine) to turn :ctf(-) and :csp(-) into proper tactics for :apply . new tactics nf, ct - improvements in the online help system - bug fixes in AC rewriting - small changes in the set of abbreviations of the Emacs mode - module system: require/provide can use Perl style :: separators to load modules from the libpath and its sub-directories - term inspection (binspect) to analyze xor terms * CafeOBJ 1.5.3 =============== - interpreter functions . 'describe module tree' (new) - prints out module importing structure . multi-line comments delimited by #| and |# . 'show modules' - does not print out hidden modules . 'preds' (new) - declare multiple Bool ops at once . new abbreviations: tr, ctr, pd, pds, bpd, bpds (for trans, ctrans, pred, preds, bpred, bpreds, respectively) . new meta label: :m-and-also, :m-or-else - CITP changes . new command :ctf, :csp . modules generated in CITP are hidden * CafeOBJ 1.5.2 =============== - Fixes to the wrapper to work with spaces in the path - make 'ls' command work on Windows (but not UNC path) * CafeOBJ 1.5.1 =============== Fixes for Windows packages to be run from UNC paths * CafeOBJ 1.5.0 =============== Several changes have been done over years, we summarize only a few: - introduction of a large family of search predicates for state/transition based specifications (see `search predicates' in the online help or manual) - addition of a (nearly) complete reference manual (reference-manual.pdf) - addition of CITP-like proving tool (see http://www.jaist.ac.jp/~danielmg/citp.html for the original version) - revised build system, allows for building and running CafeOBJ based on several lisp engines - improved online help system with search functionality (see `?' `?ap' etc) - build support has been stream-lined, currently supported Common Lisp implementations are SBCL, CLISP, Allegro CL - ... * many unmentioned releases * CafeOBJ 1.4.3PigNose ======================= a resolution based proof eningine PigNose. * Changes in CafeOBJ 1.4.3 =========================== various minor bug fixes * Changes in CafeOBJ 1.4.2b10 ============================= ** new `check' command check { coherency | coherence | coh } [ ] checks if operator is behaviouraly coherent * Changes in CafeOBJ 1.4.2b9 ============================ ** switch `fast parse' is obsolete * Changes in CafeOBJ 1.4.2b4 ============================ ** switch `mel always' now properly works for `parse' command. ** supports qulifying operator symbols by module name in terms. ** faster version of term parser for ad-hoc overloading operators. relating top-level switch: `fast parse', default on. ** made nesting limit of evaluating condition part. this prevents unexpected break in underlying Lisp system for many of the cases. related switch: `cond limit', accepting `.'(no limit) and positive integer. defaults value varies among underlying lisp. * Changes in CafeOBJ 1.4.2b2 ============================ ** Specifying views to parameters are easier for modules like: mod FOO (X :: TH1, Y :: TH2(X)) { ... } * Changes in CafeOBJ 1.4.2b1 ============================ This version has some experimental new features and several bug fixes. ** In addition to Gnu Common Lisp, CMU Common Lisp and Allegro Common Lisp can be used as a platform (see README and INSTALL for detail). ** Faster rewrite engine `brute' is now available, and can be invoked from CafeOBJ. ** Behavioural axioms can be used in equational reduction, and an operator attribute `coherent' is added for this purpose. ** A behavioural reduction command is introduced. ** Sort predicates (a partial MEL support) are introduced (experimental). Unfortunately, full implementation of `record' construct is not yet finished in this version. $Id: CHANGES,v 1.1.1.1 2003-06-19 08:25:55 sawada Exp $ cafeobj-1.6.0/make-source-tarball0000644000000000000000000000446013373141170015507 0ustar rootwheel#!/bin/bash # # make-source-tarball # create a source release tarball for CafeOBJ # # Copyright (c) 2014-2015, Norbert Preining. All rights reserved. # # Redistribution and use in source and binary forms, with or without # modification, are permitted provided that the following conditions # are met: # # * Redistributions of source code must retain the above copyright # notice, this list of conditions and the following disclaimer. # # * Redistributions in binary form must reproduce the above # copyright notice, this list of conditions and the following # disclaimer in the documentation and/or other materials # provided with the distribution. # # THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED # OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED # WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE # ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY # DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL # DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE # GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS # INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, # WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING # NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS # SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. # set -e version=$1 shift if [ x$version = x ] ; then echo "Usage: make-source-tarball VERSION" >&2 exit fi # consistency checks # check version numbers pver=`grep ^PACKAGE_VERSION= configure | sed -e "s/^.*='//" -e "s/'$//"` pmin=`grep ^VMINOR= configure | sed -e "s/^.*=//"` if [ ! "x$pver$pmin" = "x$version" ] ; then echo "Version mismatch: cmd line: $version, configure: $pver$pmin" >&2 exit 1 fi # check git status if ! git status --ignored | grep -q 'nothing to commit, working tree clean' ; then echo "git repo in unclean state, call git status --ignored!" >&2 exit 1 fi # the directory cannot exist, since otherwise the above git status would # have failed mkdir cafeobj-$version tar --exclude=cafeobj-$version \ --exclude=.git \ --exclude=.gitignore \ --exclude=tswd \ -cvf - . | tar -C cafeobj-$version -xvf - tar --owner=0 --group=0 -cvzf cafeobj-$version.tar.gz cafeobj-$version rm -rf cafeobj-$version cafeobj-1.6.0/make-release-tarballs0000644000000000000000000000567413533671262016032 0ustar rootwheel#!/bin/bash # # make-release-tarballs # create release tarballs for CafeOBJ # # Copyright (c) 2014-2018, Norbert Preining. All rights reserved. # # Redistribution and use in source and binary forms, with or without # modification, are permitted provided that the following conditions # are met: # # * Redistributions of source code must retain the above copyright # notice, this list of conditions and the following disclaimer. # # * Redistributions in binary form must reproduce the above # copyright notice, this list of conditions and the following # disclaimer in the documentation and/or other materials # provided with the distribution. # # THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED # OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED # WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE # ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY # DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL # DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE # GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS # INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, # WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING # NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS # SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. # version=$1 vminor=$2 shift shift # remaining components are the lisp interpreters for which we build default_components="bin share" TAR=tar if [ `uname` = 'Darwin' ] ; then TAR=gnutar fi if [ x$vminor = x ] ; then echo "Usage: make-dist-tarball VERSION MINOR " >&2 exit fi if [ ! -d dist/lib/cafeobj-$version ] ; then echo "Did you configure --enable-distribution && make && make install?" >&2 exit 1 fi if ! [ -d dist/bin -o -d dist/share ] ; then echo "Did you configure --enable-distribution && make && make install?" >&2 exit 1 fi for i in $* ; do case $i in acl-standalone|sbcl) true ;; *) echo "Unsupported standalone lisp interpreter: $i" >&2 ; exit ;; esac done cd dist for i in $* ; do distdir=lib/cafeobj-$version/$i case $i in acl-standalone) sname=acl ; dumpfile=$distdir/CafeOBJ ;; sbcl) sname=sbcl; dumpfile=$distdir/cafeobj.sbcl ;; esac if ! [ -d $distdir ] ; then echo "Cannot find dump for $i, exiting." >&2 exit 1 fi case `file $dumpfile` in *32-bit*) arch=x86 ;; *64-bit*) arch=x64 ;; *) echo "Cannot determine arch of CafeOBJ dump!" >&2 ; exit 1 ;; esac # # we have to make sure that the current engine is the default one # selected in the wrapper script! sed -e "s/^engine=.*/engine=$i/" bin/cafeobj > bin/cafeobj.new mv bin/cafeobj.new bin/cafeobj chmod ugo+x bin/cafeobj echo "Building $sname standalone for $arch`uname` ..." $TAR --numeric-owner --owner=0 --group=0 -cvzf ../cafeobj-$version$vminor-${sname}-${arch}`uname`.tar.gz \ $default_components $distdir done cd .. cafeobj-1.6.0/configure0000755000000000000000000047024213611176277013661 0ustar rootwheel#! /bin/sh # Guess values for system-dependent variables and create Makefiles. # Generated by GNU Autoconf 2.69 for CafeOBJ 1.6. # # # Copyright (C) 1992-1996, 1998-2012 Free Software Foundation, Inc. # # # This configure script is free software; the Free Software Foundation # gives unlimited permission to copy, distribute and modify it. ## -------------------- ## ## M4sh Initialization. ## ## -------------------- ## # Be more Bourne compatible DUALCASE=1; export DUALCASE # for MKS sh if test -n "${ZSH_VERSION+set}" && (emulate sh) >/dev/null 2>&1; then : emulate sh NULLCMD=: # Pre-4.2 versions of Zsh do word splitting on ${1+"$@"}, which # is contrary to our usage. Disable this feature. alias -g '${1+"$@"}'='"$@"' setopt NO_GLOB_SUBST else case `(set -o) 2>/dev/null` in #( *posix*) : set -o posix ;; #( *) : ;; esac fi as_nl=' ' export as_nl # Printing a long string crashes Solaris 7 /usr/bin/printf. as_echo='\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\' as_echo=$as_echo$as_echo$as_echo$as_echo$as_echo as_echo=$as_echo$as_echo$as_echo$as_echo$as_echo$as_echo # Prefer a ksh shell builtin over an external printf program on Solaris, # but without wasting forks for bash or zsh. if test -z "$BASH_VERSION$ZSH_VERSION" \ && (test "X`print -r -- $as_echo`" = "X$as_echo") 2>/dev/null; then as_echo='print -r --' as_echo_n='print -rn --' elif (test "X`printf %s $as_echo`" = "X$as_echo") 2>/dev/null; then as_echo='printf %s\n' as_echo_n='printf %s' else if test "X`(/usr/ucb/echo -n -n $as_echo) 2>/dev/null`" = "X-n $as_echo"; then as_echo_body='eval /usr/ucb/echo -n "$1$as_nl"' as_echo_n='/usr/ucb/echo -n' else as_echo_body='eval expr "X$1" : "X\\(.*\\)"' as_echo_n_body='eval arg=$1; case $arg in #( *"$as_nl"*) expr "X$arg" : "X\\(.*\\)$as_nl"; arg=`expr "X$arg" : ".*$as_nl\\(.*\\)"`;; esac; expr "X$arg" : "X\\(.*\\)" | tr -d "$as_nl" ' export as_echo_n_body as_echo_n='sh -c $as_echo_n_body as_echo' fi export as_echo_body as_echo='sh -c $as_echo_body as_echo' fi # The user is always right. if test "${PATH_SEPARATOR+set}" != set; then PATH_SEPARATOR=: (PATH='/bin;/bin'; FPATH=$PATH; sh -c :) >/dev/null 2>&1 && { (PATH='/bin:/bin'; FPATH=$PATH; sh -c :) >/dev/null 2>&1 || PATH_SEPARATOR=';' } fi # IFS # We need space, tab and new line, in precisely that order. Quoting is # there to prevent editors from complaining about space-tab. # (If _AS_PATH_WALK were called with IFS unset, it would disable word # splitting by setting IFS to empty value.) IFS=" "" $as_nl" # Find who we are. Look in the path if we contain no directory separator. as_myself= case $0 in #(( *[\\/]* ) as_myself=$0 ;; *) as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. test -r "$as_dir/$0" && as_myself=$as_dir/$0 && break done IFS=$as_save_IFS ;; esac # We did not find ourselves, most probably we were run as `sh COMMAND' # in which case we are not to be found in the path. if test "x$as_myself" = x; then as_myself=$0 fi if test ! -f "$as_myself"; then $as_echo "$as_myself: error: cannot find myself; rerun with an absolute file name" >&2 exit 1 fi # Unset variables that we do not need and which cause bugs (e.g. in # pre-3.0 UWIN ksh). But do not cause bugs in bash 2.01; the "|| exit 1" # suppresses any "Segmentation fault" message there. '((' could # trigger a bug in pdksh 5.2.14. for as_var in BASH_ENV ENV MAIL MAILPATH do eval test x\${$as_var+set} = xset \ && ( (unset $as_var) || exit 1) >/dev/null 2>&1 && unset $as_var || : done PS1='$ ' PS2='> ' PS4='+ ' # NLS nuisances. LC_ALL=C export LC_ALL LANGUAGE=C export LANGUAGE # CDPATH. (unset CDPATH) >/dev/null 2>&1 && unset CDPATH # Use a proper internal environment variable to ensure we don't fall # into an infinite loop, continuously re-executing ourselves. if test x"${_as_can_reexec}" != xno && test "x$CONFIG_SHELL" != x; then _as_can_reexec=no; export _as_can_reexec; # We cannot yet assume a decent shell, so we have to provide a # neutralization value for shells without unset; and this also # works around shells that cannot unset nonexistent variables. # Preserve -v and -x to the replacement shell. BASH_ENV=/dev/null ENV=/dev/null (unset BASH_ENV) >/dev/null 2>&1 && unset BASH_ENV ENV case $- in # (((( *v*x* | *x*v* ) as_opts=-vx ;; *v* ) as_opts=-v ;; *x* ) as_opts=-x ;; * ) as_opts= ;; esac exec $CONFIG_SHELL $as_opts "$as_myself" ${1+"$@"} # Admittedly, this is quite paranoid, since all the known shells bail # out after a failed `exec'. $as_echo "$0: could not re-execute with $CONFIG_SHELL" >&2 as_fn_exit 255 fi # We don't want this to propagate to other subprocesses. { _as_can_reexec=; unset _as_can_reexec;} if test "x$CONFIG_SHELL" = x; then as_bourne_compatible="if test -n \"\${ZSH_VERSION+set}\" && (emulate sh) >/dev/null 2>&1; then : emulate sh NULLCMD=: # Pre-4.2 versions of Zsh do word splitting on \${1+\"\$@\"}, which # is contrary to our usage. Disable this feature. alias -g '\${1+\"\$@\"}'='\"\$@\"' setopt NO_GLOB_SUBST else case \`(set -o) 2>/dev/null\` in #( *posix*) : set -o posix ;; #( *) : ;; esac fi " as_required="as_fn_return () { (exit \$1); } as_fn_success () { as_fn_return 0; } as_fn_failure () { as_fn_return 1; } as_fn_ret_success () { return 0; } as_fn_ret_failure () { return 1; } exitcode=0 as_fn_success || { exitcode=1; echo as_fn_success failed.; } as_fn_failure && { exitcode=1; echo as_fn_failure succeeded.; } as_fn_ret_success || { exitcode=1; echo as_fn_ret_success failed.; } as_fn_ret_failure && { exitcode=1; echo as_fn_ret_failure succeeded.; } if ( set x; as_fn_ret_success y && test x = \"\$1\" ); then : else exitcode=1; echo positional parameters were not saved. fi test x\$exitcode = x0 || exit 1 test -x / || exit 1" as_suggested=" as_lineno_1=";as_suggested=$as_suggested$LINENO;as_suggested=$as_suggested" as_lineno_1a=\$LINENO as_lineno_2=";as_suggested=$as_suggested$LINENO;as_suggested=$as_suggested" as_lineno_2a=\$LINENO eval 'test \"x\$as_lineno_1'\$as_run'\" != \"x\$as_lineno_2'\$as_run'\" && test \"x\`expr \$as_lineno_1'\$as_run' + 1\`\" = \"x\$as_lineno_2'\$as_run'\"' || exit 1 test \$(( 1 + 1 )) = 2 || exit 1" if (eval "$as_required") 2>/dev/null; then : as_have_required=yes else as_have_required=no fi if test x$as_have_required = xyes && (eval "$as_suggested") 2>/dev/null; then : else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR as_found=false for as_dir in /bin$PATH_SEPARATOR/usr/bin$PATH_SEPARATOR$PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. as_found=: case $as_dir in #( /*) for as_base in sh bash ksh sh5; do # Try only shells that exist, to save several forks. as_shell=$as_dir/$as_base if { test -f "$as_shell" || test -f "$as_shell.exe"; } && { $as_echo "$as_bourne_compatible""$as_required" | as_run=a "$as_shell"; } 2>/dev/null; then : CONFIG_SHELL=$as_shell as_have_required=yes if { $as_echo "$as_bourne_compatible""$as_suggested" | as_run=a "$as_shell"; } 2>/dev/null; then : break 2 fi fi done;; esac as_found=false done $as_found || { if { test -f "$SHELL" || test -f "$SHELL.exe"; } && { $as_echo "$as_bourne_compatible""$as_required" | as_run=a "$SHELL"; } 2>/dev/null; then : CONFIG_SHELL=$SHELL as_have_required=yes fi; } IFS=$as_save_IFS if test "x$CONFIG_SHELL" != x; then : export CONFIG_SHELL # We cannot yet assume a decent shell, so we have to provide a # neutralization value for shells without unset; and this also # works around shells that cannot unset nonexistent variables. # Preserve -v and -x to the replacement shell. BASH_ENV=/dev/null ENV=/dev/null (unset BASH_ENV) >/dev/null 2>&1 && unset BASH_ENV ENV case $- in # (((( *v*x* | *x*v* ) as_opts=-vx ;; *v* ) as_opts=-v ;; *x* ) as_opts=-x ;; * ) as_opts= ;; esac exec $CONFIG_SHELL $as_opts "$as_myself" ${1+"$@"} # Admittedly, this is quite paranoid, since all the known shells bail # out after a failed `exec'. $as_echo "$0: could not re-execute with $CONFIG_SHELL" >&2 exit 255 fi if test x$as_have_required = xno; then : $as_echo "$0: This script requires a shell more modern than all" $as_echo "$0: the shells that I found on your system." if test x${ZSH_VERSION+set} = xset ; then $as_echo "$0: In particular, zsh $ZSH_VERSION has bugs and should" $as_echo "$0: be upgraded to zsh 4.3.4 or later." else $as_echo "$0: Please tell bug-autoconf@gnu.org about your system, $0: including any error possibly output before this $0: message. Then install a modern shell, or manually run $0: the script under such a shell if you do have one." fi exit 1 fi fi fi SHELL=${CONFIG_SHELL-/bin/sh} export SHELL # Unset more variables known to interfere with behavior of common tools. CLICOLOR_FORCE= GREP_OPTIONS= unset CLICOLOR_FORCE GREP_OPTIONS ## --------------------- ## ## M4sh Shell Functions. ## ## --------------------- ## # as_fn_unset VAR # --------------- # Portably unset VAR. as_fn_unset () { { eval $1=; unset $1;} } as_unset=as_fn_unset # as_fn_set_status STATUS # ----------------------- # Set $? to STATUS, without forking. as_fn_set_status () { return $1 } # as_fn_set_status # as_fn_exit STATUS # ----------------- # Exit the shell with STATUS, even in a "trap 0" or "set -e" context. as_fn_exit () { set +e as_fn_set_status $1 exit $1 } # as_fn_exit # as_fn_mkdir_p # ------------- # Create "$as_dir" as a directory, including parents if necessary. as_fn_mkdir_p () { case $as_dir in #( -*) as_dir=./$as_dir;; esac test -d "$as_dir" || eval $as_mkdir_p || { as_dirs= while :; do case $as_dir in #( *\'*) as_qdir=`$as_echo "$as_dir" | sed "s/'/'\\\\\\\\''/g"`;; #'( *) as_qdir=$as_dir;; esac as_dirs="'$as_qdir' $as_dirs" as_dir=`$as_dirname -- "$as_dir" || $as_expr X"$as_dir" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ X"$as_dir" : 'X\(//\)[^/]' \| \ X"$as_dir" : 'X\(//\)$' \| \ X"$as_dir" : 'X\(/\)' \| . 2>/dev/null || $as_echo X"$as_dir" | sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ s//\1/ q } /^X\(\/\/\)[^/].*/{ s//\1/ q } /^X\(\/\/\)$/{ s//\1/ q } /^X\(\/\).*/{ s//\1/ q } s/.*/./; q'` test -d "$as_dir" && break done test -z "$as_dirs" || eval "mkdir $as_dirs" } || test -d "$as_dir" || as_fn_error $? "cannot create directory $as_dir" } # as_fn_mkdir_p # as_fn_executable_p FILE # ----------------------- # Test if FILE is an executable regular file. as_fn_executable_p () { test -f "$1" && test -x "$1" } # as_fn_executable_p # as_fn_append VAR VALUE # ---------------------- # Append the text in VALUE to the end of the definition contained in VAR. Take # advantage of any shell optimizations that allow amortized linear growth over # repeated appends, instead of the typical quadratic growth present in naive # implementations. if (eval "as_var=1; as_var+=2; test x\$as_var = x12") 2>/dev/null; then : eval 'as_fn_append () { eval $1+=\$2 }' else as_fn_append () { eval $1=\$$1\$2 } fi # as_fn_append # as_fn_arith ARG... # ------------------ # Perform arithmetic evaluation on the ARGs, and store the result in the # global $as_val. Take advantage of shells that can avoid forks. The arguments # must be portable across $(()) and expr. if (eval "test \$(( 1 + 1 )) = 2") 2>/dev/null; then : eval 'as_fn_arith () { as_val=$(( $* )) }' else as_fn_arith () { as_val=`expr "$@" || test $? -eq 1` } fi # as_fn_arith # as_fn_error STATUS ERROR [LINENO LOG_FD] # ---------------------------------------- # Output "`basename $0`: error: ERROR" to stderr. If LINENO and LOG_FD are # provided, also output the error to LOG_FD, referencing LINENO. Then exit the # script with STATUS, using 1 if that was 0. as_fn_error () { as_status=$1; test $as_status -eq 0 && as_status=1 if test "$4"; then as_lineno=${as_lineno-"$3"} as_lineno_stack=as_lineno_stack=$as_lineno_stack $as_echo "$as_me:${as_lineno-$LINENO}: error: $2" >&$4 fi $as_echo "$as_me: error: $2" >&2 as_fn_exit $as_status } # as_fn_error if expr a : '\(a\)' >/dev/null 2>&1 && test "X`expr 00001 : '.*\(...\)'`" = X001; then as_expr=expr else as_expr=false fi if (basename -- /) >/dev/null 2>&1 && test "X`basename -- / 2>&1`" = "X/"; then as_basename=basename else as_basename=false fi if (as_dir=`dirname -- /` && test "X$as_dir" = X/) >/dev/null 2>&1; then as_dirname=dirname else as_dirname=false fi as_me=`$as_basename -- "$0" || $as_expr X/"$0" : '.*/\([^/][^/]*\)/*$' \| \ X"$0" : 'X\(//\)$' \| \ X"$0" : 'X\(/\)' \| . 2>/dev/null || $as_echo X/"$0" | sed '/^.*\/\([^/][^/]*\)\/*$/{ s//\1/ q } /^X\/\(\/\/\)$/{ s//\1/ q } /^X\/\(\/\).*/{ s//\1/ q } s/.*/./; q'` # Avoid depending upon Character Ranges. as_cr_letters='abcdefghijklmnopqrstuvwxyz' as_cr_LETTERS='ABCDEFGHIJKLMNOPQRSTUVWXYZ' as_cr_Letters=$as_cr_letters$as_cr_LETTERS as_cr_digits='0123456789' as_cr_alnum=$as_cr_Letters$as_cr_digits as_lineno_1=$LINENO as_lineno_1a=$LINENO as_lineno_2=$LINENO as_lineno_2a=$LINENO eval 'test "x$as_lineno_1'$as_run'" != "x$as_lineno_2'$as_run'" && test "x`expr $as_lineno_1'$as_run' + 1`" = "x$as_lineno_2'$as_run'"' || { # Blame Lee E. McMahon (1931-1989) for sed's syntax. :-) sed -n ' p /[$]LINENO/= ' <$as_myself | sed ' s/[$]LINENO.*/&-/ t lineno b :lineno N :loop s/[$]LINENO\([^'$as_cr_alnum'_].*\n\)\(.*\)/\2\1\2/ t loop s/-\n.*// ' >$as_me.lineno && chmod +x "$as_me.lineno" || { $as_echo "$as_me: error: cannot create $as_me.lineno; rerun with a POSIX shell" >&2; as_fn_exit 1; } # If we had to re-execute with $CONFIG_SHELL, we're ensured to have # already done that, so ensure we don't try to do so again and fall # in an infinite loop. This has already happened in practice. _as_can_reexec=no; export _as_can_reexec # Don't try to exec as it changes $[0], causing all sort of problems # (the dirname of $[0] is not the place where we might find the # original and so on. Autoconf is especially sensitive to this). . "./$as_me.lineno" # Exit status is that of the last command. exit } ECHO_C= ECHO_N= ECHO_T= case `echo -n x` in #((((( -n*) case `echo 'xy\c'` in *c*) ECHO_T=' ';; # ECHO_T is single tab character. xy) ECHO_C='\c';; *) echo `echo ksh88 bug on AIX 6.1` > /dev/null ECHO_T=' ';; esac;; *) ECHO_N='-n';; esac rm -f conf$$ conf$$.exe conf$$.file if test -d conf$$.dir; then rm -f conf$$.dir/conf$$.file else rm -f conf$$.dir mkdir conf$$.dir 2>/dev/null fi if (echo >conf$$.file) 2>/dev/null; then if ln -s conf$$.file conf$$ 2>/dev/null; then as_ln_s='ln -s' # ... but there are two gotchas: # 1) On MSYS, both `ln -s file dir' and `ln file dir' fail. # 2) DJGPP < 2.04 has no symlinks; `ln -s' creates a wrapper executable. # In both cases, we have to default to `cp -pR'. ln -s conf$$.file conf$$.dir 2>/dev/null && test ! -f conf$$.exe || as_ln_s='cp -pR' elif ln conf$$.file conf$$ 2>/dev/null; then as_ln_s=ln else as_ln_s='cp -pR' fi else as_ln_s='cp -pR' fi rm -f conf$$ conf$$.exe conf$$.dir/conf$$.file conf$$.file rmdir conf$$.dir 2>/dev/null if mkdir -p . 2>/dev/null; then as_mkdir_p='mkdir -p "$as_dir"' else test -d ./-p && rmdir ./-p as_mkdir_p=false fi as_test_x='test -x' as_executable_p=as_fn_executable_p # Sed expression to map a string onto a valid CPP name. as_tr_cpp="eval sed 'y%*$as_cr_letters%P$as_cr_LETTERS%;s%[^_$as_cr_alnum]%_%g'" # Sed expression to map a string onto a valid variable name. as_tr_sh="eval sed 'y%*+%pp%;s%[^_$as_cr_alnum]%_%g'" test -n "$DJDIR" || exec 7<&0 &1 # Name of the host. # hostname on some systems (SVR3.2, old GNU/Linux) returns a bogus exit status, # so uname gets run too. ac_hostname=`(hostname || uname -n) 2>/dev/null | sed 1q` # # Initializations. # ac_default_prefix=/usr/local ac_clean_files= ac_config_libobj_dir=. LIBOBJS= cross_compiling=no subdirs= MFLAGS= MAKEFLAGS= # Identity of this package. PACKAGE_NAME='CafeOBJ' PACKAGE_TARNAME='cafeobj' PACKAGE_VERSION='1.6' PACKAGE_STRING='CafeOBJ 1.6' PACKAGE_BUGREPORT='' PACKAGE_URL='http://www.cafeobj.org/' ac_unique_file="make-cafeobj.lisp.in" # 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 enable_distribution enable_windows enable_traditional_layout enable_rebuild_doc pdflatex_avail pandoc_avail bibtex_avail xelatex_avail OSBIT EGREP GREP CPP OBJEXT EXEEXT ac_ct_CC CPPFLAGS LDFLAGS CFLAGS CC gcl_dump ccl64_dump ccl32_dump cmu_dump clisp_dump sbcl_dump acl_standalone_dump acl_dump gcl_interp ccl64_interp ccl32_interp cmu_interp clisp_interp sbcl_interp acl_interp firstchoice lisp lispdir EMACSLOADPATH EMACS MKDIR_P SET_MAKE ccl64_path ccl32_path clisp_path acl_path sbcl_path cmu_path gcl_path INSTALL_DATA INSTALL_SCRIPT INSTALL_PROGRAM PATCHLEVEL VMEMO VMINOR 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_URL PACKAGE_BUGREPORT PACKAGE_STRING PACKAGE_VERSION PACKAGE_TARNAME PACKAGE_NAME PATH_SEPARATOR SHELL' ac_subst_files='' ac_user_opts=' enable_option_checking with_sbcl with_acl with_clisp with_lisp with_lispdir enable_rebuild_doc enable_traditional_layout enable_windows enable_distribution ' ac_precious_vars='build_alias host_alias target_alias EMACS EMACSLOADPATH 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= ;; *) ac_optarg=yes ;; esac # Accept the important Cygnus configure options, so we can diagnose typos. case $ac_dashdash$ac_option in --) ac_dashdash=yes ;; -bindir | --bindir | --bindi | --bind | --bin | --bi) ac_prev=bindir ;; -bindir=* | --bindir=* | --bindi=* | --bind=* | --bin=* | --bi=*) bindir=$ac_optarg ;; -build | --build | --buil | --bui | --bu) ac_prev=build_alias ;; -build=* | --build=* | --buil=* | --bui=* | --bu=*) build_alias=$ac_optarg ;; -cache-file | --cache-file | --cache-fil | --cache-fi \ | --cache-f | --cache- | --cache | --cach | --cac | --ca | --c) ac_prev=cache_file ;; -cache-file=* | --cache-file=* | --cache-fil=* | --cache-fi=* \ | --cache-f=* | --cache-=* | --cache=* | --cach=* | --cac=* | --ca=* | --c=*) cache_file=$ac_optarg ;; --config-cache | -C) cache_file=config.cache ;; -datadir | --datadir | --datadi | --datad) ac_prev=datadir ;; -datadir=* | --datadir=* | --datadi=* | --datad=*) datadir=$ac_optarg ;; -datarootdir | --datarootdir | --datarootdi | --datarootd | --dataroot \ | --dataroo | --dataro | --datar) ac_prev=datarootdir ;; -datarootdir=* | --datarootdir=* | --datarootdi=* | --datarootd=* \ | --dataroot=* | --dataroo=* | --dataro=* | --datar=*) datarootdir=$ac_optarg ;; -disable-* | --disable-*) ac_useropt=`expr "x$ac_option" : 'x-*disable-\(.*\)'` # Reject names that are not valid shell variable names. expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null && as_fn_error $? "invalid feature name: $ac_useropt" ac_useropt_orig=$ac_useropt ac_useropt=`$as_echo "$ac_useropt" | sed 's/[-+.]/_/g'` case $ac_user_opts in *" "enable_$ac_useropt" "*) ;; *) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--disable-$ac_useropt_orig" ac_unrecognized_sep=', ';; esac eval enable_$ac_useropt=no ;; -docdir | --docdir | --docdi | --doc | --do) ac_prev=docdir ;; -docdir=* | --docdir=* | --docdi=* | --doc=* | --do=*) docdir=$ac_optarg ;; -dvidir | --dvidir | --dvidi | --dvid | --dvi | --dv) ac_prev=dvidir ;; -dvidir=* | --dvidir=* | --dvidi=* | --dvid=* | --dvi=* | --dv=*) dvidir=$ac_optarg ;; -enable-* | --enable-*) ac_useropt=`expr "x$ac_option" : 'x-*enable-\([^=]*\)'` # Reject names that are not valid shell variable names. expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null && as_fn_error $? "invalid feature name: $ac_useropt" ac_useropt_orig=$ac_useropt ac_useropt=`$as_echo "$ac_useropt" | sed 's/[-+.]/_/g'` case $ac_user_opts in *" "enable_$ac_useropt" "*) ;; *) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--enable-$ac_useropt_orig" ac_unrecognized_sep=', ';; esac eval enable_$ac_useropt=\$ac_optarg ;; -exec-prefix | --exec_prefix | --exec-prefix | --exec-prefi \ | --exec-pref | --exec-pre | --exec-pr | --exec-p | --exec- \ | --exec | --exe | --ex) ac_prev=exec_prefix ;; -exec-prefix=* | --exec_prefix=* | --exec-prefix=* | --exec-prefi=* \ | --exec-pref=* | --exec-pre=* | --exec-pr=* | --exec-p=* | --exec-=* \ | --exec=* | --exe=* | --ex=*) exec_prefix=$ac_optarg ;; -gas | --gas | --ga | --g) # Obsolete; use --with-gas. with_gas=yes ;; -help | --help | --hel | --he | -h) ac_init_help=long ;; -help=r* | --help=r* | --hel=r* | --he=r* | -hr*) ac_init_help=recursive ;; -help=s* | --help=s* | --hel=s* | --he=s* | -hs*) ac_init_help=short ;; -host | --host | --hos | --ho) ac_prev=host_alias ;; -host=* | --host=* | --hos=* | --ho=*) host_alias=$ac_optarg ;; -htmldir | --htmldir | --htmldi | --htmld | --html | --htm | --ht) ac_prev=htmldir ;; -htmldir=* | --htmldir=* | --htmldi=* | --htmld=* | --html=* | --htm=* \ | --ht=*) htmldir=$ac_optarg ;; -includedir | --includedir | --includedi | --included | --include \ | --includ | --inclu | --incl | --inc) ac_prev=includedir ;; -includedir=* | --includedir=* | --includedi=* | --included=* | --include=* \ | --includ=* | --inclu=* | --incl=* | --inc=*) includedir=$ac_optarg ;; -infodir | --infodir | --infodi | --infod | --info | --inf) ac_prev=infodir ;; -infodir=* | --infodir=* | --infodi=* | --infod=* | --info=* | --inf=*) infodir=$ac_optarg ;; -libdir | --libdir | --libdi | --libd) ac_prev=libdir ;; -libdir=* | --libdir=* | --libdi=* | --libd=*) libdir=$ac_optarg ;; -libexecdir | --libexecdir | --libexecdi | --libexecd | --libexec \ | --libexe | --libex | --libe) ac_prev=libexecdir ;; -libexecdir=* | --libexecdir=* | --libexecdi=* | --libexecd=* | --libexec=* \ | --libexe=* | --libex=* | --libe=*) libexecdir=$ac_optarg ;; -localedir | --localedir | --localedi | --localed | --locale) ac_prev=localedir ;; -localedir=* | --localedir=* | --localedi=* | --localed=* | --locale=*) localedir=$ac_optarg ;; -localstatedir | --localstatedir | --localstatedi | --localstated \ | --localstate | --localstat | --localsta | --localst | --locals) ac_prev=localstatedir ;; -localstatedir=* | --localstatedir=* | --localstatedi=* | --localstated=* \ | --localstate=* | --localstat=* | --localsta=* | --localst=* | --locals=*) localstatedir=$ac_optarg ;; -mandir | --mandir | --mandi | --mand | --man | --ma | --m) ac_prev=mandir ;; -mandir=* | --mandir=* | --mandi=* | --mand=* | --man=* | --ma=* | --m=*) mandir=$ac_optarg ;; -nfp | --nfp | --nf) # Obsolete; use --without-fp. with_fp=no ;; -no-create | --no-create | --no-creat | --no-crea | --no-cre \ | --no-cr | --no-c | -n) no_create=yes ;; -no-recursion | --no-recursion | --no-recursio | --no-recursi \ | --no-recurs | --no-recur | --no-recu | --no-rec | --no-re | --no-r) no_recursion=yes ;; -oldincludedir | --oldincludedir | --oldincludedi | --oldincluded \ | --oldinclude | --oldinclud | --oldinclu | --oldincl | --oldinc \ | --oldin | --oldi | --old | --ol | --o) ac_prev=oldincludedir ;; -oldincludedir=* | --oldincludedir=* | --oldincludedi=* | --oldincluded=* \ | --oldinclude=* | --oldinclud=* | --oldinclu=* | --oldincl=* | --oldinc=* \ | --oldin=* | --oldi=* | --old=* | --ol=* | --o=*) oldincludedir=$ac_optarg ;; -prefix | --prefix | --prefi | --pref | --pre | --pr | --p) ac_prev=prefix ;; -prefix=* | --prefix=* | --prefi=* | --pref=* | --pre=* | --pr=* | --p=*) prefix=$ac_optarg ;; -program-prefix | --program-prefix | --program-prefi | --program-pref \ | --program-pre | --program-pr | --program-p) ac_prev=program_prefix ;; -program-prefix=* | --program-prefix=* | --program-prefi=* \ | --program-pref=* | --program-pre=* | --program-pr=* | --program-p=*) program_prefix=$ac_optarg ;; -program-suffix | --program-suffix | --program-suffi | --program-suff \ | --program-suf | --program-su | --program-s) ac_prev=program_suffix ;; -program-suffix=* | --program-suffix=* | --program-suffi=* \ | --program-suff=* | --program-suf=* | --program-su=* | --program-s=*) program_suffix=$ac_optarg ;; -program-transform-name | --program-transform-name \ | --program-transform-nam | --program-transform-na \ | --program-transform-n | --program-transform- \ | --program-transform | --program-transfor \ | --program-transfo | --program-transf \ | --program-trans | --program-tran \ | --progr-tra | --program-tr | --program-t) ac_prev=program_transform_name ;; -program-transform-name=* | --program-transform-name=* \ | --program-transform-nam=* | --program-transform-na=* \ | --program-transform-n=* | --program-transform-=* \ | --program-transform=* | --program-transfor=* \ | --program-transfo=* | --program-transf=* \ | --program-trans=* | --program-tran=* \ | --progr-tra=* | --program-tr=* | --program-t=*) program_transform_name=$ac_optarg ;; -pdfdir | --pdfdir | --pdfdi | --pdfd | --pdf | --pd) ac_prev=pdfdir ;; -pdfdir=* | --pdfdir=* | --pdfdi=* | --pdfd=* | --pdf=* | --pd=*) pdfdir=$ac_optarg ;; -psdir | --psdir | --psdi | --psd | --ps) ac_prev=psdir ;; -psdir=* | --psdir=* | --psdi=* | --psd=* | --ps=*) psdir=$ac_optarg ;; -q | -quiet | --quiet | --quie | --qui | --qu | --q \ | -silent | --silent | --silen | --sile | --sil) silent=yes ;; -sbindir | --sbindir | --sbindi | --sbind | --sbin | --sbi | --sb) ac_prev=sbindir ;; -sbindir=* | --sbindir=* | --sbindi=* | --sbind=* | --sbin=* \ | --sbi=* | --sb=*) sbindir=$ac_optarg ;; -sharedstatedir | --sharedstatedir | --sharedstatedi \ | --sharedstated | --sharedstate | --sharedstat | --sharedsta \ | --sharedst | --shareds | --shared | --share | --shar \ | --sha | --sh) ac_prev=sharedstatedir ;; -sharedstatedir=* | --sharedstatedir=* | --sharedstatedi=* \ | --sharedstated=* | --sharedstate=* | --sharedstat=* | --sharedsta=* \ | --sharedst=* | --shareds=* | --shared=* | --share=* | --shar=* \ | --sha=* | --sh=*) sharedstatedir=$ac_optarg ;; -site | --site | --sit) ac_prev=site ;; -site=* | --site=* | --sit=*) site=$ac_optarg ;; -srcdir | --srcdir | --srcdi | --srcd | --src | --sr) ac_prev=srcdir ;; -srcdir=* | --srcdir=* | --srcdi=* | --srcd=* | --src=* | --sr=*) srcdir=$ac_optarg ;; -sysconfdir | --sysconfdir | --sysconfdi | --sysconfd | --sysconf \ | --syscon | --sysco | --sysc | --sys | --sy) ac_prev=sysconfdir ;; -sysconfdir=* | --sysconfdir=* | --sysconfdi=* | --sysconfd=* | --sysconf=* \ | --syscon=* | --sysco=* | --sysc=* | --sys=* | --sy=*) sysconfdir=$ac_optarg ;; -target | --target | --targe | --targ | --tar | --ta | --t) ac_prev=target_alias ;; -target=* | --target=* | --targe=* | --targ=* | --tar=* | --ta=* | --t=*) target_alias=$ac_optarg ;; -v | -verbose | --verbose | --verbos | --verbo | --verb) verbose=yes ;; -version | --version | --versio | --versi | --vers | -V) ac_init_version=: ;; -with-* | --with-*) ac_useropt=`expr "x$ac_option" : 'x-*with-\([^=]*\)'` # Reject names that are not valid shell variable names. expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null && as_fn_error $? "invalid package name: $ac_useropt" ac_useropt_orig=$ac_useropt ac_useropt=`$as_echo "$ac_useropt" | sed 's/[-+.]/_/g'` case $ac_user_opts in *" "with_$ac_useropt" "*) ;; *) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--with-$ac_useropt_orig" ac_unrecognized_sep=', ';; esac eval with_$ac_useropt=\$ac_optarg ;; -without-* | --without-*) ac_useropt=`expr "x$ac_option" : 'x-*without-\(.*\)'` # Reject names that are not valid shell variable names. expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null && as_fn_error $? "invalid package name: $ac_useropt" ac_useropt_orig=$ac_useropt ac_useropt=`$as_echo "$ac_useropt" | sed 's/[-+.]/_/g'` case $ac_user_opts in *" "with_$ac_useropt" "*) ;; *) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--without-$ac_useropt_orig" ac_unrecognized_sep=', ';; esac eval with_$ac_useropt=no ;; --x) # Obsolete; use --with-x. with_x=yes ;; -x-includes | --x-includes | --x-include | --x-includ | --x-inclu \ | --x-incl | --x-inc | --x-in | --x-i) ac_prev=x_includes ;; -x-includes=* | --x-includes=* | --x-include=* | --x-includ=* | --x-inclu=* \ | --x-incl=* | --x-inc=* | --x-in=* | --x-i=*) x_includes=$ac_optarg ;; -x-libraries | --x-libraries | --x-librarie | --x-librari \ | --x-librar | --x-libra | --x-libr | --x-lib | --x-li | --x-l) ac_prev=x_libraries ;; -x-libraries=* | --x-libraries=* | --x-librarie=* | --x-librari=* \ | --x-librar=* | --x-libra=* | --x-libr=* | --x-lib=* | --x-li=* | --x-l=*) x_libraries=$ac_optarg ;; -*) as_fn_error $? "unrecognized option: \`$ac_option' Try \`$0 --help' for more information" ;; *=*) ac_envvar=`expr "x$ac_option" : 'x\([^=]*\)='` # Reject names that are not valid shell variable names. case $ac_envvar in #( '' | [0-9]* | *[!_$as_cr_alnum]* ) as_fn_error $? "invalid variable name: \`$ac_envvar'" ;; esac eval $ac_envvar=\$ac_optarg export $ac_envvar ;; *) # FIXME: should be removed in autoconf 3.0. $as_echo "$as_me: WARNING: you should use --build, --host, --target" >&2 expr "x$ac_option" : ".*[^-._$as_cr_alnum]" >/dev/null && $as_echo "$as_me: WARNING: invalid host type: $ac_option" >&2 : "${build_alias=$ac_option} ${host_alias=$ac_option} ${target_alias=$ac_option}" ;; esac done if test -n "$ac_prev"; then ac_option=--`echo $ac_prev | sed 's/_/-/g'` as_fn_error $? "missing argument to $ac_option" fi if test -n "$ac_unrecognized_opts"; then case $enable_option_checking in no) ;; fatal) as_fn_error $? "unrecognized options: $ac_unrecognized_opts" ;; *) $as_echo "$as_me: WARNING: unrecognized options: $ac_unrecognized_opts" >&2 ;; esac fi # Check all directory arguments for consistency. for ac_var in exec_prefix prefix bindir sbindir libexecdir datarootdir \ datadir sysconfdir sharedstatedir localstatedir includedir \ oldincludedir docdir infodir htmldir dvidir pdfdir psdir \ libdir localedir mandir do eval ac_val=\$$ac_var # Remove trailing slashes. case $ac_val in */ ) ac_val=`expr "X$ac_val" : 'X\(.*[^/]\)' \| "X$ac_val" : 'X\(.*\)'` eval $ac_var=\$ac_val;; esac # Be sure to have absolute directory names. case $ac_val in [\\/$]* | ?:[\\/]* ) continue;; NONE | '' ) case $ac_var in *prefix ) continue;; esac;; esac as_fn_error $? "expected an absolute directory name for --$ac_var: $ac_val" done # There might be people who depend on the old broken behavior: `$host' # used to hold the argument of --host etc. # FIXME: To remove some day. build=$build_alias host=$host_alias target=$target_alias # FIXME: To remove some day. if test "x$host_alias" != x; then if test "x$build_alias" = x; then cross_compiling=maybe elif test "x$build_alias" != "x$host_alias"; then cross_compiling=yes fi fi ac_tool_prefix= test -n "$host_alias" && ac_tool_prefix=$host_alias- test "$silent" = yes && exec 6>/dev/null ac_pwd=`pwd` && test -n "$ac_pwd" && ac_ls_di=`ls -di .` && ac_pwd_ls_di=`cd "$ac_pwd" && ls -di .` || as_fn_error $? "working directory cannot be determined" test "X$ac_ls_di" = "X$ac_pwd_ls_di" || as_fn_error $? "pwd does not report name of working directory" # Find the source files, if location was not specified. if test -z "$srcdir"; then ac_srcdir_defaulted=yes # Try the directory containing this script, then the parent directory. ac_confdir=`$as_dirname -- "$as_myself" || $as_expr X"$as_myself" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ X"$as_myself" : 'X\(//\)[^/]' \| \ X"$as_myself" : 'X\(//\)$' \| \ X"$as_myself" : 'X\(/\)' \| . 2>/dev/null || $as_echo X"$as_myself" | sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ s//\1/ q } /^X\(\/\/\)[^/].*/{ s//\1/ q } /^X\(\/\/\)$/{ s//\1/ q } /^X\(\/\).*/{ s//\1/ q } s/.*/./; q'` srcdir=$ac_confdir if test ! -r "$srcdir/$ac_unique_file"; then srcdir=.. fi else ac_srcdir_defaulted=no fi if test ! -r "$srcdir/$ac_unique_file"; then test "$ac_srcdir_defaulted" = yes && srcdir="$ac_confdir or .." as_fn_error $? "cannot find sources ($ac_unique_file) in $srcdir" fi ac_msg="sources are in $srcdir, but \`cd $srcdir' does not work" ac_abs_confdir=`( cd "$srcdir" && test -r "./$ac_unique_file" || as_fn_error $? "$ac_msg" pwd)` # When building in place, set srcdir=. if test "$ac_abs_confdir" = "$ac_pwd"; then srcdir=. fi # Remove unnecessary trailing slashes from srcdir. # Double slashes in file names in object file debugging info # mess up M-x gdb in Emacs. case $srcdir in */) srcdir=`expr "X$srcdir" : 'X\(.*[^/]\)' \| "X$srcdir" : 'X\(.*\)'`;; esac for ac_var in $ac_precious_vars; do eval ac_env_${ac_var}_set=\${${ac_var}+set} eval ac_env_${ac_var}_value=\$${ac_var} eval ac_cv_env_${ac_var}_set=\${${ac_var}+set} eval ac_cv_env_${ac_var}_value=\$${ac_var} done # # Report the --help message. # if test "$ac_init_help" = "long"; then # Omit some internal or obsolete options to make the list less imposing. # This message is too long to be a string in the A/UX 3.1 sh. cat <<_ACEOF \`configure' configures CafeOBJ 1.6 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/cafeobj] --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 _ACEOF fi if test -n "$ac_init_help"; then case $ac_init_help in short | recursive ) echo "Configuration of CafeOBJ 1.6:";; 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-rebuild-doc Enable the rebuilding of documentation (not implemented) [default=no] --enable-traditional-layout Enable traditional layout [default=no] --enable-windows Prepare for Windows building --enable-distribution Configure for binary distribution Optional Packages: --with-PACKAGE[=ARG] use PACKAGE [ARG=yes] --without-PACKAGE do not use PACKAGE (same as --with-PACKAGE=no) --with-sbcl= specify the SBCL interpreter [default: sbcl] --with-acl= specify the ACL interpreter [default: alisp] --with-clisp= specify the CLISP interpreter [default: clisp] --with-lisp=all|[,] specify a list of lisp interpreters from "acl", "sbcl", or "clisp". Alternatively "all" can be specified to select all available. --with-lispdir override the default lisp directory Some influential environment variables: EMACS the Emacs editor command EMACSLOADPATH the Emacs library search path CC C compiler command CFLAGS C compiler flags LDFLAGS linker flags, e.g. -L if you have libraries in a nonstandard directory LIBS libraries to pass to the linker, e.g. -l CPPFLAGS (Objective) C/C++ preprocessor flags, e.g. -I if you have headers in a nonstandard directory CPP C preprocessor Use these variables to override the choices made by `configure' or to help it to find libraries and programs with nonstandard names/locations. Report bugs to the package provider. CafeOBJ home page: . _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 CafeOBJ configure 1.6 generated by GNU Autoconf 2.69 Copyright (C) 2012 Free Software Foundation, Inc. This configure script is free software; the Free Software Foundation gives unlimited permission to copy, distribute and modify it. _ACEOF exit fi ## ------------------------ ## ## Autoconf initialization. ## ## ------------------------ ## # ac_fn_c_try_compile LINENO # -------------------------- # Try to compile conftest.$ac_ext, and return whether this succeeded. ac_fn_c_try_compile () { as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack rm -f conftest.$ac_objext if { { ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" $as_echo "$ac_try_echo"; } >&5 (eval "$ac_compile") 2>conftest.err ac_status=$? if test -s conftest.err; then grep -v '^ *+' conftest.err >conftest.er1 cat conftest.er1 >&5 mv -f conftest.er1 conftest.err fi $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 test $ac_status = 0; } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then : ac_retval=0 else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_retval=1 fi eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno as_fn_set_status $ac_retval } # ac_fn_c_try_compile # ac_fn_c_try_run LINENO # ---------------------- # Try to link conftest.$ac_ext, and return whether this succeeded. Assumes # that executables *can* be run. ac_fn_c_try_run () { as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack if { { ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" $as_echo "$ac_try_echo"; } >&5 (eval "$ac_link") 2>&5 ac_status=$? $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 test $ac_status = 0; } && { ac_try='./conftest$ac_exeext' { { case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" $as_echo "$ac_try_echo"; } >&5 (eval "$ac_try") 2>&5 ac_status=$? $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 test $ac_status = 0; }; }; then : ac_retval=0 else $as_echo "$as_me: program exited with status $ac_status" >&5 $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_retval=$ac_status fi rm -rf conftest.dSYM conftest_ipa8_conftest.oo eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno as_fn_set_status $ac_retval } # ac_fn_c_try_run # ac_fn_c_compute_int LINENO EXPR VAR INCLUDES # -------------------------------------------- # Tries to find the compile-time value of EXPR in a program that includes # INCLUDES, setting VAR accordingly. Returns whether the value could be # computed ac_fn_c_compute_int () { as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack if test "$cross_compiling" = yes; then # Depending upon the size, compute the lo and hi bounds. cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ $4 int main () { static int test_array [1 - 2 * !(($2) >= 0)]; test_array [0] = 0; return test_array [0]; ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO"; then : ac_lo=0 ac_mid=0 while :; do cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ $4 int main () { static int test_array [1 - 2 * !(($2) <= $ac_mid)]; test_array [0] = 0; return test_array [0]; ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO"; then : ac_hi=$ac_mid; break else as_fn_arith $ac_mid + 1 && ac_lo=$as_val if test $ac_lo -le $ac_mid; then ac_lo= ac_hi= break fi as_fn_arith 2 '*' $ac_mid + 1 && ac_mid=$as_val fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext done else cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ $4 int main () { static int test_array [1 - 2 * !(($2) < 0)]; test_array [0] = 0; return test_array [0]; ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO"; then : ac_hi=-1 ac_mid=-1 while :; do cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ $4 int main () { static int test_array [1 - 2 * !(($2) >= $ac_mid)]; test_array [0] = 0; return test_array [0]; ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO"; then : ac_lo=$ac_mid; break else as_fn_arith '(' $ac_mid ')' - 1 && ac_hi=$as_val if test $ac_mid -le $ac_hi; then ac_lo= ac_hi= break fi as_fn_arith 2 '*' $ac_mid && ac_mid=$as_val fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext done else ac_lo= ac_hi= fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext # Binary search between lo and hi bounds. while test "x$ac_lo" != "x$ac_hi"; do as_fn_arith '(' $ac_hi - $ac_lo ')' / 2 + $ac_lo && ac_mid=$as_val cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ $4 int main () { static int test_array [1 - 2 * !(($2) <= $ac_mid)]; test_array [0] = 0; return test_array [0]; ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO"; then : ac_hi=$ac_mid else as_fn_arith '(' $ac_mid ')' + 1 && ac_lo=$as_val fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext done case $ac_lo in #(( ?*) eval "$3=\$ac_lo"; ac_retval=0 ;; '') ac_retval=1 ;; esac else cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ $4 static long int longval () { return $2; } static unsigned long int ulongval () { return $2; } #include #include int main () { FILE *f = fopen ("conftest.val", "w"); if (! f) return 1; if (($2) < 0) { long int i = longval (); if (i != ($2)) return 1; fprintf (f, "%ld", i); } else { unsigned long int i = ulongval (); if (i != ($2)) return 1; fprintf (f, "%lu", i); } /* Do not output a trailing newline, as this causes \r\n confusion on some platforms. */ return ferror (f) || fclose (f) != 0; ; return 0; } _ACEOF if ac_fn_c_try_run "$LINENO"; then : echo >>conftest.val; read $3 &5 (eval "$ac_cpp conftest.$ac_ext") 2>conftest.err ac_status=$? if test -s conftest.err; then grep -v '^ *+' conftest.err >conftest.er1 cat conftest.er1 >&5 mv -f conftest.er1 conftest.err fi $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 test $ac_status = 0; } > conftest.i && { test -z "$ac_c_preproc_warn_flag$ac_c_werror_flag" || test ! -s conftest.err }; then : ac_retval=0 else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_retval=1 fi eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno as_fn_set_status $ac_retval } # ac_fn_c_try_cpp # ac_fn_c_check_header_compile LINENO HEADER VAR INCLUDES # ------------------------------------------------------- # Tests whether HEADER exists and can be compiled using the include files in # INCLUDES, setting the cache variable VAR accordingly. ac_fn_c_check_header_compile () { as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $2" >&5 $as_echo_n "checking for $2... " >&6; } if eval \${$3+:} false; then : $as_echo_n "(cached) " >&6 else cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ $4 #include <$2> _ACEOF if ac_fn_c_try_compile "$LINENO"; then : eval "$3=yes" else eval "$3=no" fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi eval ac_res=\$$3 { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5 $as_echo "$ac_res" >&6; } eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno } # ac_fn_c_check_header_compile 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 CafeOBJ $as_me 1.6, which was generated by GNU Autoconf 2.69. Invocation command line was $ $0 $@ _ACEOF exec 5>>config.log { cat <<_ASUNAME ## --------- ## ## Platform. ## ## --------- ## hostname = `(hostname || uname -n) 2>/dev/null | sed 1q` uname -m = `(uname -m) 2>/dev/null || echo unknown` uname -r = `(uname -r) 2>/dev/null || echo unknown` uname -s = `(uname -s) 2>/dev/null || echo unknown` uname -v = `(uname -v) 2>/dev/null || echo unknown` /usr/bin/uname -p = `(/usr/bin/uname -p) 2>/dev/null || echo unknown` /bin/uname -X = `(/bin/uname -X) 2>/dev/null || echo unknown` /bin/arch = `(/bin/arch) 2>/dev/null || echo unknown` /usr/bin/arch -k = `(/usr/bin/arch -k) 2>/dev/null || echo unknown` /usr/convex/getsysinfo = `(/usr/convex/getsysinfo) 2>/dev/null || echo unknown` /usr/bin/hostinfo = `(/usr/bin/hostinfo) 2>/dev/null || echo unknown` /bin/machine = `(/bin/machine) 2>/dev/null || echo unknown` /usr/bin/oslevel = `(/usr/bin/oslevel) 2>/dev/null || echo unknown` /bin/universe = `(/bin/universe) 2>/dev/null || echo unknown` _ASUNAME as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. $as_echo "PATH: $as_dir" done IFS=$as_save_IFS } >&5 cat >&5 <<_ACEOF ## ----------- ## ## Core tests. ## ## ----------- ## _ACEOF # Keep a trace of the command line. # Strip out --no-create and --no-recursion so they do not pile up. # Strip out --silent because we don't want to record it for future runs. # Also quote any args containing shell meta-characters. # Make two passes to allow for proper duplicate-argument suppression. ac_configure_args= ac_configure_args0= ac_configure_args1= ac_must_keep_next=false for ac_pass in 1 2 do for ac_arg do case $ac_arg in -no-create | --no-c* | -n | -no-recursion | --no-r*) continue ;; -q | -quiet | --quiet | --quie | --qui | --qu | --q \ | -silent | --silent | --silen | --sile | --sil) continue ;; *\'*) ac_arg=`$as_echo "$ac_arg" | sed "s/'/'\\\\\\\\''/g"` ;; esac case $ac_pass in 1) as_fn_append ac_configure_args0 " '$ac_arg'" ;; 2) as_fn_append ac_configure_args1 " '$ac_arg'" if test $ac_must_keep_next = true; then ac_must_keep_next=false # Got value, back to normal. else case $ac_arg in *=* | --config-cache | -C | -disable-* | --disable-* \ | -enable-* | --enable-* | -gas | --g* | -nfp | --nf* \ | -q | -quiet | --q* | -silent | --sil* | -v | -verb* \ | -with-* | --with-* | -without-* | --without-* | --x) case "$ac_configure_args0 " in "$ac_configure_args1"*" '$ac_arg' "* ) continue ;; esac ;; -* ) ac_must_keep_next=true ;; esac fi as_fn_append ac_configure_args " '$ac_arg'" ;; esac done done { ac_configure_args0=; unset ac_configure_args0;} { ac_configure_args1=; unset ac_configure_args1;} # When interrupted or exit'd, cleanup temporary files, and complete # config.log. We remove comments because anyway the quotes in there # would cause problems or look ugly. # WARNING: Use '\'' to represent an apostrophe within the trap. # WARNING: Do not start the trap code with a newline, due to a FreeBSD 4.0 bug. trap 'exit_status=$? # Save into config.log some information that might help in debugging. { echo $as_echo "## ---------------- ## ## Cache variables. ## ## ---------------- ##" echo # The following way of writing the cache mishandles newlines in values, ( for ac_var in `(set) 2>&1 | sed -n '\''s/^\([a-zA-Z_][a-zA-Z0-9_]*\)=.*/\1/p'\''`; do eval ac_val=\$$ac_var case $ac_val in #( *${as_nl}*) case $ac_var in #( *_cv_*) { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: cache variable $ac_var contains a newline" >&5 $as_echo "$as_me: WARNING: cache variable $ac_var contains a newline" >&2;} ;; esac case $ac_var in #( _ | IFS | as_nl) ;; #( BASH_ARGV | BASH_SOURCE) eval $ac_var= ;; #( *) { eval $ac_var=; unset $ac_var;} ;; esac ;; esac done (set) 2>&1 | case $as_nl`(ac_space='\'' '\''; set) 2>&1` in #( *${as_nl}ac_space=\ *) sed -n \ "s/'\''/'\''\\\\'\'''\''/g; s/^\\([_$as_cr_alnum]*_cv_[_$as_cr_alnum]*\\)=\\(.*\\)/\\1='\''\\2'\''/p" ;; #( *) sed -n "/^[_$as_cr_alnum]*_cv_[_$as_cr_alnum]*=/p" ;; esac | sort ) echo $as_echo "## ----------------- ## ## Output variables. ## ## ----------------- ##" echo for ac_var in $ac_subst_vars do eval ac_val=\$$ac_var case $ac_val in *\'\''*) ac_val=`$as_echo "$ac_val" | sed "s/'\''/'\''\\\\\\\\'\'''\''/g"`;; esac $as_echo "$ac_var='\''$ac_val'\''" done | sort echo if test -n "$ac_subst_files"; then $as_echo "## ------------------- ## ## File substitutions. ## ## ------------------- ##" echo for ac_var in $ac_subst_files do eval ac_val=\$$ac_var case $ac_val in *\'\''*) ac_val=`$as_echo "$ac_val" | sed "s/'\''/'\''\\\\\\\\'\'''\''/g"`;; esac $as_echo "$ac_var='\''$ac_val'\''" done | sort echo fi if test -s confdefs.h; then $as_echo "## ----------- ## ## confdefs.h. ## ## ----------- ##" echo cat confdefs.h echo fi test "$ac_signal" != 0 && $as_echo "$as_me: caught signal $ac_signal" $as_echo "$as_me: exit $exit_status" } >&5 rm -f core *.core core.conftest.* && rm -f -r conftest* confdefs* conf$$* $ac_clean_files && exit $exit_status ' 0 for ac_signal in 1 2 13 15; do trap 'ac_signal='$ac_signal'; as_fn_exit 1' $ac_signal done ac_signal=0 # confdefs.h avoids OS command line length limits that DEFS can exceed. rm -f -r conftest* confdefs.h $as_echo "/* confdefs.h */" > confdefs.h # Predefined preprocessor variables. cat >>confdefs.h <<_ACEOF #define PACKAGE_NAME "$PACKAGE_NAME" _ACEOF cat >>confdefs.h <<_ACEOF #define PACKAGE_TARNAME "$PACKAGE_TARNAME" _ACEOF cat >>confdefs.h <<_ACEOF #define PACKAGE_VERSION "$PACKAGE_VERSION" _ACEOF cat >>confdefs.h <<_ACEOF #define PACKAGE_STRING "$PACKAGE_STRING" _ACEOF cat >>confdefs.h <<_ACEOF #define PACKAGE_BUGREPORT "$PACKAGE_BUGREPORT" _ACEOF cat >>confdefs.h <<_ACEOF #define PACKAGE_URL "$PACKAGE_URL" _ACEOF # Let the site file select an alternate cache file if it wants to. # Prefer an explicitly selected file to automatically selected ones. ac_site_file1=NONE ac_site_file2=NONE if test -n "$CONFIG_SITE"; then # We do not want a PATH search for config.site. case $CONFIG_SITE in #(( -*) ac_site_file1=./$CONFIG_SITE;; */*) ac_site_file1=$CONFIG_SITE;; *) ac_site_file1=./$CONFIG_SITE;; esac elif test "x$prefix" != xNONE; then ac_site_file1=$prefix/share/config.site ac_site_file2=$prefix/etc/config.site else ac_site_file1=$ac_default_prefix/share/config.site ac_site_file2=$ac_default_prefix/etc/config.site fi for ac_site_file in "$ac_site_file1" "$ac_site_file2" do test "x$ac_site_file" = xNONE && continue if test /dev/null != "$ac_site_file" && test -r "$ac_site_file"; then { $as_echo "$as_me:${as_lineno-$LINENO}: loading site script $ac_site_file" >&5 $as_echo "$as_me: loading site script $ac_site_file" >&6;} sed 's/^/| /' "$ac_site_file" >&5 . "$ac_site_file" \ || { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error $? "failed to load site script $ac_site_file See \`config.log' for more details" "$LINENO" 5; } fi done if test -r "$cache_file"; then # Some versions of bash will fail to source /dev/null (special files # actually), so we avoid doing that. DJGPP emulates it as a regular file. if test /dev/null != "$cache_file" && test -f "$cache_file"; then { $as_echo "$as_me:${as_lineno-$LINENO}: loading cache $cache_file" >&5 $as_echo "$as_me: loading cache $cache_file" >&6;} case $cache_file in [\\/]* | ?:[\\/]* ) . "$cache_file";; *) . "./$cache_file";; esac fi else { $as_echo "$as_me:${as_lineno-$LINENO}: creating cache $cache_file" >&5 $as_echo "$as_me: creating cache $cache_file" >&6;} >$cache_file fi # Check that the precious variables saved in the cache have kept the same # value. ac_cache_corrupted=false for ac_var in $ac_precious_vars; do eval ac_old_set=\$ac_cv_env_${ac_var}_set eval ac_new_set=\$ac_env_${ac_var}_set eval ac_old_val=\$ac_cv_env_${ac_var}_value eval ac_new_val=\$ac_env_${ac_var}_value case $ac_old_set,$ac_new_set in set,) { $as_echo "$as_me:${as_lineno-$LINENO}: error: \`$ac_var' was set to \`$ac_old_val' in the previous run" >&5 $as_echo "$as_me: error: \`$ac_var' was set to \`$ac_old_val' in the previous run" >&2;} ac_cache_corrupted=: ;; ,set) { $as_echo "$as_me:${as_lineno-$LINENO}: error: \`$ac_var' was not set in the previous run" >&5 $as_echo "$as_me: error: \`$ac_var' was not set in the previous run" >&2;} ac_cache_corrupted=: ;; ,);; *) if test "x$ac_old_val" != "x$ac_new_val"; then # differences in whitespace do not lead to failure. ac_old_val_w=`echo x $ac_old_val` ac_new_val_w=`echo x $ac_new_val` if test "$ac_old_val_w" != "$ac_new_val_w"; then { $as_echo "$as_me:${as_lineno-$LINENO}: error: \`$ac_var' has changed since the previous run:" >&5 $as_echo "$as_me: error: \`$ac_var' has changed since the previous run:" >&2;} ac_cache_corrupted=: else { $as_echo "$as_me:${as_lineno-$LINENO}: warning: ignoring whitespace changes in \`$ac_var' since the previous run:" >&5 $as_echo "$as_me: warning: ignoring whitespace changes in \`$ac_var' since the previous run:" >&2;} eval $ac_var=\$ac_old_val fi { $as_echo "$as_me:${as_lineno-$LINENO}: former value: \`$ac_old_val'" >&5 $as_echo "$as_me: former value: \`$ac_old_val'" >&2;} { $as_echo "$as_me:${as_lineno-$LINENO}: current value: \`$ac_new_val'" >&5 $as_echo "$as_me: current value: \`$ac_new_val'" >&2;} fi;; esac # Pass precious variables to config.status. if test "$ac_new_set" = set; then case $ac_new_val in *\'*) ac_arg=$ac_var=`$as_echo "$ac_new_val" | sed "s/'/'\\\\\\\\''/g"` ;; *) ac_arg=$ac_var=$ac_new_val ;; esac case " $ac_configure_args " in *" '$ac_arg' "*) ;; # Avoid dups. Use of quotes ensures accuracy. *) as_fn_append ac_configure_args " '$ac_arg'" ;; esac fi done if $ac_cache_corrupted; then { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} { $as_echo "$as_me:${as_lineno-$LINENO}: error: changes in the environment can compromise the build" >&5 $as_echo "$as_me: error: changes in the environment can compromise the build" >&2;} as_fn_error $? "run \`make distclean' and/or \`rm $cache_file' and start over" "$LINENO" 5 fi ## -------------------- ## ## Main body of script. ## ## -------------------- ## ac_ext=c ac_cpp='$CPP $CPPFLAGS' ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' ac_compiler_gnu=$ac_cv_c_compiler_gnu VMINOR=.0 VMEMO=PigNose0.99 PATCHLEVEL= 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"` ac_aux_dir= for ac_dir in "$srcdir" "$srcdir/.." "$srcdir/../.."; do if test -f "$ac_dir/install-sh"; then ac_aux_dir=$ac_dir ac_install_sh="$ac_aux_dir/install-sh -c" break elif test -f "$ac_dir/install.sh"; then ac_aux_dir=$ac_dir ac_install_sh="$ac_aux_dir/install.sh -c" break elif test -f "$ac_dir/shtool"; then ac_aux_dir=$ac_dir ac_install_sh="$ac_aux_dir/shtool install -c" break fi done if test -z "$ac_aux_dir"; then as_fn_error $? "cannot find install-sh, install.sh, or shtool in \"$srcdir\" \"$srcdir/..\" \"$srcdir/../..\"" "$LINENO" 5 fi # These three variables are undocumented and unsupported, # and are intended to be withdrawn in a future Autoconf release. # They can cause serious problems if a builder's source tree is in a directory # whose full name contains unusual characters. ac_config_guess="$SHELL $ac_aux_dir/config.guess" # Please don't use this var. ac_config_sub="$SHELL $ac_aux_dir/config.sub" # Please don't use this var. ac_configure="$SHELL $ac_aux_dir/configure" # Please don't use this var. # Find a good install program. We prefer a C program (faster), # so one script is as good as another. But avoid the broken or # incompatible versions: # SysV /etc/install, /usr/sbin/install # SunOS /usr/etc/install # IRIX /sbin/install # AIX /bin/install # AmigaOS /C/install, which installs bootblocks on floppy discs # AIX 4 /usr/bin/installbsd, which doesn't work without a -g flag # AFS /usr/afsws/bin/install, which mishandles nonexistent args # SVR4 /usr/ucb/install, which tries to use the nonexistent group "staff" # OS/2's system install, which has a completely different semantic # ./install, which can be erroneously created by make from ./install.sh. # Reject install programs that cannot install multiple files. { $as_echo "$as_me:${as_lineno-$LINENO}: checking for a BSD-compatible install" >&5 $as_echo_n "checking for a BSD-compatible install... " >&6; } if test -z "$INSTALL"; then if ${ac_cv_path_install+:} false; then : $as_echo_n "(cached) " >&6 else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. # Account for people who put trailing slashes in PATH elements. case $as_dir/ in #(( ./ | .// | /[cC]/* | \ /etc/* | /usr/sbin/* | /usr/etc/* | /sbin/* | /usr/afsws/bin/* | \ ?:[\\/]os2[\\/]install[\\/]* | ?:[\\/]OS2[\\/]INSTALL[\\/]* | \ /usr/ucb/* ) ;; *) # OSF1 and SCO ODT 3.0 have their own names for install. # Don't use installbsd from OSF since it installs stuff as root # by default. for ac_prog in ginstall scoinst install; do for ac_exec_ext in '' $ac_executable_extensions; do if as_fn_executable_p "$as_dir/$ac_prog$ac_exec_ext"; then if test $ac_prog = install && grep dspmsg "$as_dir/$ac_prog$ac_exec_ext" >/dev/null 2>&1; then # AIX install. It has an incompatible calling convention. : elif test $ac_prog = install && grep pwplus "$as_dir/$ac_prog$ac_exec_ext" >/dev/null 2>&1; then # program-specific install script used by HP pwplus--don't use. : else rm -rf conftest.one conftest.two conftest.dir echo one > conftest.one echo two > conftest.two mkdir conftest.dir if "$as_dir/$ac_prog$ac_exec_ext" -c conftest.one conftest.two "`pwd`/conftest.dir" && test -s conftest.one && test -s conftest.two && test -s conftest.dir/conftest.one && test -s conftest.dir/conftest.two then ac_cv_path_install="$as_dir/$ac_prog$ac_exec_ext -c" break 3 fi fi fi done done ;; esac done IFS=$as_save_IFS rm -rf conftest.one conftest.two conftest.dir fi if test "${ac_cv_path_install+set}" = set; then INSTALL=$ac_cv_path_install else # As a last resort, use the slow shell script. Don't cache a # value for INSTALL within a source directory, because that will # break other packages using the cache if that directory is # removed, or if the value is a relative name. INSTALL=$ac_install_sh fi fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $INSTALL" >&5 $as_echo "$INSTALL" >&6; } # Use test -z because SunOS4 sh mishandles braces in ${var-val}. # It thinks the first close brace ends the variable substitution. test -z "$INSTALL_PROGRAM" && INSTALL_PROGRAM='${INSTALL}' test -z "$INSTALL_SCRIPT" && INSTALL_SCRIPT='${INSTALL}' test -z "$INSTALL_DATA" && INSTALL_DATA='${INSTALL} -m 644' # Check whether --with-sbcl was given. if test "${with_sbcl+set}" = set; then : withval=$with_sbcl; sbcl_interp=$withval else sbcl_interp=sbcl fi sbcl_dump=cafeobj.sbcl # Check whether --with-acl was given. if test "${with_acl+set}" = set; then : withval=$with_acl; acl_interp=$withval else acl_interp=alisp fi acl_dump=cafeobj.acl acl_standalone_dump=CafeOBJ # Check whether --with-clisp was given. if test "${with_clisp+set}" = set; then : withval=$with_clisp; clisp_interp=$withval else clisp_interp=clisp fi clisp_dump=cafeobj.mem ccl32_interp=ccl ccl32_dump=cafeobj.img ccl64_interp=ccl64 ccl64_dump=cafeobj.img gcl_interp=gcl gcl_dump=cafeobj.exe cmu_interp=lisp cmu_dump=cafeobj.core # Extract the first word of "gcl", so it can be a program name with args. set dummy gcl; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if ${ac_cv_path_gcl_path+:} false; then : $as_echo_n "(cached) " >&6 else case $gcl_path in [\\/]* | ?:[\\/]*) ac_cv_path_gcl_path="$gcl_path" # Let the user override the test with a path. ;; *) as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_path_gcl_path="$as_dir/$ac_word$ac_exec_ext" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS ;; esac fi gcl_path=$ac_cv_path_gcl_path if test -n "$gcl_path"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $gcl_path" >&5 $as_echo "$gcl_path" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi # Extract the first word of "$cmu_interp", so it can be a program name with args. set dummy $cmu_interp; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if ${ac_cv_path_cmu_path+:} false; then : $as_echo_n "(cached) " >&6 else case $cmu_path in [\\/]* | ?:[\\/]*) ac_cv_path_cmu_path="$cmu_path" # Let the user override the test with a path. ;; *) as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_path_cmu_path="$as_dir/$ac_word$ac_exec_ext" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS ;; esac fi cmu_path=$ac_cv_path_cmu_path if test -n "$cmu_path"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $cmu_path" >&5 $as_echo "$cmu_path" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi # Extract the first word of "$sbcl_interp", so it can be a program name with args. set dummy $sbcl_interp; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if ${ac_cv_path_sbcl_path+:} false; then : $as_echo_n "(cached) " >&6 else case $sbcl_path in [\\/]* | ?:[\\/]*) ac_cv_path_sbcl_path="$sbcl_path" # Let the user override the test with a path. ;; *) as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_path_sbcl_path="$as_dir/$ac_word$ac_exec_ext" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS ;; esac fi sbcl_path=$ac_cv_path_sbcl_path if test -n "$sbcl_path"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $sbcl_path" >&5 $as_echo "$sbcl_path" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi # Extract the first word of "$acl_interp", so it can be a program name with args. set dummy $acl_interp; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if ${ac_cv_path_acl_path+:} false; then : $as_echo_n "(cached) " >&6 else case $acl_path in [\\/]* | ?:[\\/]*) ac_cv_path_acl_path="$acl_path" # Let the user override the test with a path. ;; *) as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_path_acl_path="$as_dir/$ac_word$ac_exec_ext" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS ;; esac fi acl_path=$ac_cv_path_acl_path if test -n "$acl_path"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $acl_path" >&5 $as_echo "$acl_path" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi # Extract the first word of "$clisp_interp", so it can be a program name with args. set dummy $clisp_interp; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if ${ac_cv_path_clisp_path+:} false; then : $as_echo_n "(cached) " >&6 else case $clisp_path in [\\/]* | ?:[\\/]*) ac_cv_path_clisp_path="$clisp_path" # Let the user override the test with a path. ;; *) as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_path_clisp_path="$as_dir/$ac_word$ac_exec_ext" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS ;; esac fi clisp_path=$ac_cv_path_clisp_path if test -n "$clisp_path"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $clisp_path" >&5 $as_echo "$clisp_path" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi # Extract the first word of "$ccl32_interp", so it can be a program name with args. set dummy $ccl32_interp; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if ${ac_cv_path_ccl32_path+:} false; then : $as_echo_n "(cached) " >&6 else case $ccl32_path in [\\/]* | ?:[\\/]*) ac_cv_path_ccl32_path="$ccl32_path" # Let the user override the test with a path. ;; *) as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_path_ccl32_path="$as_dir/$ac_word$ac_exec_ext" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS ;; esac fi ccl32_path=$ac_cv_path_ccl32_path if test -n "$ccl32_path"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ccl32_path" >&5 $as_echo "$ccl32_path" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi # Extract the first word of "$ccl64_interp", so it can be a program name with args. set dummy $ccl64_interp; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if ${ac_cv_path_ccl64_path+:} false; then : $as_echo_n "(cached) " >&6 else case $ccl64_path in [\\/]* | ?:[\\/]*) ac_cv_path_ccl64_path="$ccl64_path" # Let the user override the test with a path. ;; *) as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_path_ccl64_path="$as_dir/$ac_word$ac_exec_ext" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS ;; esac fi ccl64_path=$ac_cv_path_ccl64_path if test -n "$ccl64_path"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ccl64_path" >&5 $as_echo "$ccl64_path" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi { $as_echo "$as_me:${as_lineno-$LINENO}: checking whether ${MAKE-make} sets \$(MAKE)" >&5 $as_echo_n "checking whether ${MAKE-make} sets \$(MAKE)... " >&6; } set x ${MAKE-make} ac_make=`$as_echo "$2" | sed 's/+/p/g; s/[^a-zA-Z0-9_]/_/g'` if eval \${ac_cv_prog_make_${ac_make}_set+:} false; then : $as_echo_n "(cached) " >&6 else cat >conftest.make <<\_ACEOF SHELL = /bin/sh all: @echo '@@@%%%=$(MAKE)=@@@%%%' _ACEOF # GNU make sometimes prints "make[1]: Entering ...", which would confuse us. case `${MAKE-make} -f conftest.make 2>/dev/null` in *@@@%%%=?*=@@@%%%*) eval ac_cv_prog_make_${ac_make}_set=yes;; *) eval ac_cv_prog_make_${ac_make}_set=no;; esac rm -f conftest.make fi if eval test \$ac_cv_prog_make_${ac_make}_set = yes; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 $as_echo "yes" >&6; } SET_MAKE= else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } SET_MAKE="MAKE=${MAKE-make}" fi { $as_echo "$as_me:${as_lineno-$LINENO}: checking for a thread-safe mkdir -p" >&5 $as_echo_n "checking for a thread-safe mkdir -p... " >&6; } if test -z "$MKDIR_P"; then if ${ac_cv_path_mkdir+:} false; then : $as_echo_n "(cached) " >&6 else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH$PATH_SEPARATOR/opt/sfw/bin do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_prog in mkdir gmkdir; do for ac_exec_ext in '' $ac_executable_extensions; do as_fn_executable_p "$as_dir/$ac_prog$ac_exec_ext" || continue case `"$as_dir/$ac_prog$ac_exec_ext" --version 2>&1` in #( 'mkdir (GNU coreutils) '* | \ 'mkdir (coreutils) '* | \ 'mkdir (fileutils) '4.1*) ac_cv_path_mkdir=$as_dir/$ac_prog$ac_exec_ext break 3;; esac done done done IFS=$as_save_IFS fi test -d ./--version && rmdir ./--version if test "${ac_cv_path_mkdir+set}" = set; then MKDIR_P="$ac_cv_path_mkdir -p" else # As a last resort, use the slow shell script. Don't cache a # value for MKDIR_P within a source directory, because that will # break other packages using the cache if that directory is # removed, or if the value is a relative name. MKDIR_P="$ac_install_sh -d" fi fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $MKDIR_P" >&5 $as_echo "$MKDIR_P" >&6; } # Check whether --with-lisp was given. if test "${with_lisp+set}" = set; then : withval=$with_lisp; lisp=$withval fi if test "x$lisp" = "x" then # no lisp specified, select one by default # we disable the currently not building ones!!! if test -n "$acl_path" ; then lisp=acl ; elif test -n "$sbcl_path" ; then lisp=sbcl ; elif test -n "$clisp_path" ; then lisp=clisp ; # elif test -n "$gcl_path" ; then lisp=gcl ; # elif test -n "$cmu_path" ; then lisp=cmu ; # elif test -n "$ccl32_path" ; then lisp=ccl ; # elif test -n "$ccl64_path" ; then lisp=ccl64 ; else as_fn_error $? "no supported lisp interpreter found" "$LINENO" 5 fi fi do_all=0 if test "x$lisp" = "xall" then do_all=1 # this is the preferred order of interpreters!! # if nothing is specified, the first one found will be used! #lisp=acl,sbcl,clisp,gcl,cmu,ccl,ccl64 # use only currently supported ones lisp=acl-standalone,acl,sbcl,clisp fi lisp=$(echo $lisp | sed -e 's/,/ /g') goodlisp= firstchoice= for i in $lisp do case "x$i" in xcmu|xcmu-pc) if test -z "$cmu_path" then test $do_all = 1 || \ as_fn_error $? "selected lisp interpreter $i is not available" "$LINENO" 5 else goodlisp="$goodlisp $i" if test "x$firstchoice" = x then firstchoice=$i fi fi ;; xsbcl) if test -z "$sbcl_path" then test $do_all = 1 || \ as_fn_error $? "selected lisp interpreter $i is not available" "$LINENO" 5 else goodlisp="$goodlisp $i" if test "x$firstchoice" = x then firstchoice=$i fi fi ;; xacl|xacl-standalone) if test -z "$acl_path" then test $do_all = 1 || \ as_fn_error $? "selected lisp interpreter $i is not available" "$LINENO" 5 else goodlisp="$goodlisp $i" if test "x$firstchoice" = x then firstchoice=$i fi fi ;; xclisp) if test -z "$clisp_path" then test $do_all = 1 || \ as_fn_error $? "selected lisp interpreter $i is not available" "$LINENO" 5 else goodlisp="$goodlisp $i" if test "x$firstchoice" = x then firstchoice=$i fi fi ;; xccl) if test -z "$ccl32_path" then test $do_all = 1 || \ as_fn_error $? "selected lisp interpreter $i is not available" "$LINENO" 5 else goodlisp="$goodlisp $i" if test "x$firstchoice" = x then firstchoice=$i fi fi ;; xccl64) if test -z "$ccl64_path" then test $do_all = 1 || \ as_fn_error $? "selected lisp interpreter $i is not available" "$LINENO" 5 else goodlisp="$goodlisp $i" if test "x$firstchoice" = x then firstchoice=$i fi fi ;; xgcl) if test -z "$gcl_path" then test $do_all = 1 || \ as_fn_error $? "selected lisp interpreter $i is not available" "$LINENO" 5 else goodlisp="$goodlisp $i" if test "x$firstchoice" = x then firstchoice=$i fi fi ;; *) as_fn_error $? "unknown lisp interpreter $i" "$LINENO" 5 ;; esac done lisp="$goodlisp" if test -z "$lisp" then as_fn_error $? "no usable lisp interpreter" "$LINENO" 5 fi { $as_echo "$as_me:${as_lineno-$LINENO}: Building for the following lisp interpreters: $lisp" >&5 $as_echo "$as_me: Building for the following lisp interpreters: $lisp" >&6;} # If set to t, that means we are running in a shell under Emacs. # If you have an Emacs named "t", then use the full path. test x"$EMACS" = xt && EMACS= for ac_prog in emacs xemacs do # Extract the first word of "$ac_prog", so it can be a program name with args. set dummy $ac_prog; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if ${ac_cv_prog_EMACS+:} false; then : $as_echo_n "(cached) " >&6 else if test -n "$EMACS"; then ac_cv_prog_EMACS="$EMACS" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_prog_EMACS="$ac_prog" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS fi fi EMACS=$ac_cv_prog_EMACS if test -n "$EMACS"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $EMACS" >&5 $as_echo "$EMACS" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi test -n "$EMACS" && break done test -n "$EMACS" || EMACS="no" # Check whether --with-lispdir was given. if test "${with_lispdir+set}" = set; then : withval=$with_lispdir; lispdir="$withval" { $as_echo "$as_me:${as_lineno-$LINENO}: checking where .elc files should go" >&5 $as_echo_n "checking where .elc files should go... " >&6; } { $as_echo "$as_me:${as_lineno-$LINENO}: result: $lispdir" >&5 $as_echo "$lispdir" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: checking where .elc files should go" >&5 $as_echo_n "checking where .elc files should go... " >&6; } if ${am_cv_lispdir+:} false; then : $as_echo_n "(cached) " >&6 else if test $EMACS != "no"; then if test x${lispdir+set} != xset; then # If $EMACS isn't GNU Emacs or XEmacs, this can blow up pretty badly # Some emacsen will start up in interactive mode, requiring C-x C-c to exit, # which is non-obvious for non-emacs users. # Redirecting /dev/null should help a bit; pity we can't detect "broken" # emacsen earlier and avoid running this altogether. { { $as_echo "$as_me:${as_lineno-$LINENO}: \$EMACS -batch -Q -eval '(while load-path (princ (concat (car load-path) \"\\n\")) (setq load-path (cdr load-path)))' conftest.out"; } >&5 ($EMACS -batch -Q -eval '(while load-path (princ (concat (car load-path) "\n")) (setq load-path (cdr load-path)))' conftest.out) 2>&5 ac_status=$? $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 test $ac_status = 0; } am_cv_lispdir=`sed -n \ -e 's,/$,,' \ -e '/.*\/lib\/x*emacs\/site-lisp$/{s,.*/lib/\(x*emacs/site-lisp\)$,${libdir}/\1,;p;q;}' \ -e '/.*\/share\/x*emacs\/site-lisp$/{s,.*/share/\(x*emacs/site-lisp\),${datarootdir}/\1,;p;q;}' \ conftest.out` rm conftest.out fi fi test -z "$am_cv_lispdir" && am_cv_lispdir='${datadir}/emacs/site-lisp' fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $am_cv_lispdir" >&5 $as_echo "$am_cv_lispdir" >&6; } lispdir="$am_cv_lispdir" fi # test for 64/32 bit 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 # Extract the first word of "${ac_tool_prefix}gcc", so it can be a program name with args. set dummy ${ac_tool_prefix}gcc; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if ${ac_cv_prog_CC+:} false; then : $as_echo_n "(cached) " >&6 else if test -n "$CC"; then ac_cv_prog_CC="$CC" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_prog_CC="${ac_tool_prefix}gcc" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS fi fi CC=$ac_cv_prog_CC if test -n "$CC"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $CC" >&5 $as_echo "$CC" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi fi if test -z "$ac_cv_prog_CC"; then ac_ct_CC=$CC # Extract the first word of "gcc", so it can be a program name with args. set dummy gcc; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if ${ac_cv_prog_ac_ct_CC+:} false; then : $as_echo_n "(cached) " >&6 else if test -n "$ac_ct_CC"; then ac_cv_prog_ac_ct_CC="$ac_ct_CC" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_prog_ac_ct_CC="gcc" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS fi fi ac_ct_CC=$ac_cv_prog_ac_ct_CC if test -n "$ac_ct_CC"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_ct_CC" >&5 $as_echo "$ac_ct_CC" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi if test "x$ac_ct_CC" = x; then CC="" else case $cross_compiling:$ac_tool_warned in yes:) { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5 $as_echo "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;} ac_tool_warned=yes ;; esac CC=$ac_ct_CC fi else CC="$ac_cv_prog_CC" fi if test -z "$CC"; then if test -n "$ac_tool_prefix"; then # Extract the first word of "${ac_tool_prefix}cc", so it can be a program name with args. set dummy ${ac_tool_prefix}cc; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if ${ac_cv_prog_CC+:} false; then : $as_echo_n "(cached) " >&6 else if test -n "$CC"; then ac_cv_prog_CC="$CC" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_prog_CC="${ac_tool_prefix}cc" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS fi fi CC=$ac_cv_prog_CC if test -n "$CC"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $CC" >&5 $as_echo "$CC" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi fi fi if test -z "$CC"; then # Extract the first word of "cc", so it can be a program name with args. set dummy cc; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if ${ac_cv_prog_CC+:} false; then : $as_echo_n "(cached) " >&6 else if test -n "$CC"; then ac_cv_prog_CC="$CC" # Let the user override the test. else ac_prog_rejected=no as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then if test "$as_dir/$ac_word$ac_exec_ext" = "/usr/ucb/cc"; then ac_prog_rejected=yes continue fi ac_cv_prog_CC="cc" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS if test $ac_prog_rejected = yes; then # We found a bogon in the path, so make sure we never use it. set dummy $ac_cv_prog_CC shift if test $# != 0; then # We chose a different compiler from the bogus one. # However, it has the same basename, so the bogon will be chosen # first if we set CC to just the basename; use the full file name. shift ac_cv_prog_CC="$as_dir/$ac_word${1+' '}$@" fi fi fi fi CC=$ac_cv_prog_CC if test -n "$CC"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $CC" >&5 $as_echo "$CC" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi fi if test -z "$CC"; then if test -n "$ac_tool_prefix"; then for ac_prog in cl.exe do # Extract the first word of "$ac_tool_prefix$ac_prog", so it can be a program name with args. set dummy $ac_tool_prefix$ac_prog; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if ${ac_cv_prog_CC+:} false; then : $as_echo_n "(cached) " >&6 else if test -n "$CC"; then ac_cv_prog_CC="$CC" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_prog_CC="$ac_tool_prefix$ac_prog" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS fi fi CC=$ac_cv_prog_CC if test -n "$CC"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $CC" >&5 $as_echo "$CC" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi test -n "$CC" && break done fi if test -z "$CC"; then ac_ct_CC=$CC for ac_prog in cl.exe do # Extract the first word of "$ac_prog", so it can be a program name with args. set dummy $ac_prog; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if ${ac_cv_prog_ac_ct_CC+:} false; then : $as_echo_n "(cached) " >&6 else if test -n "$ac_ct_CC"; then ac_cv_prog_ac_ct_CC="$ac_ct_CC" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_prog_ac_ct_CC="$ac_prog" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS fi fi ac_ct_CC=$ac_cv_prog_ac_ct_CC if test -n "$ac_ct_CC"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_ct_CC" >&5 $as_echo "$ac_ct_CC" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi test -n "$ac_ct_CC" && break done if test "x$ac_ct_CC" = x; then CC="" else case $cross_compiling:$ac_tool_warned in yes:) { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5 $as_echo "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;} ac_tool_warned=yes ;; esac CC=$ac_ct_CC fi fi fi test -z "$CC" && { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error $? "no acceptable C compiler found in \$PATH See \`config.log' for more details" "$LINENO" 5; } # Provide some information about the compiler. $as_echo "$as_me:${as_lineno-$LINENO}: checking for C compiler version" >&5 set X $ac_compile ac_compiler=$2 for ac_option in --version -v -V -qversion; do { { ac_try="$ac_compiler $ac_option >&5" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" $as_echo "$ac_try_echo"; } >&5 (eval "$ac_compiler $ac_option >&5") 2>conftest.err ac_status=$? if test -s conftest.err; then sed '10a\ ... rest of stderr output deleted ... 10q' conftest.err >conftest.er1 cat conftest.er1 >&5 fi rm -f conftest.er1 conftest.err $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 test $ac_status = 0; } done cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int main () { ; return 0; } _ACEOF ac_clean_files_save=$ac_clean_files ac_clean_files="$ac_clean_files a.out a.out.dSYM a.exe b.out" # Try to create an executable without -o first, disregard a.out. # It will help us diagnose broken compilers, and finding out an intuition # of exeext. { $as_echo "$as_me:${as_lineno-$LINENO}: checking whether the C compiler works" >&5 $as_echo_n "checking whether the C compiler works... " >&6; } ac_link_default=`$as_echo "$ac_link" | sed 's/ -o *conftest[^ ]*//'` # The possible output files: ac_files="a.out conftest.exe conftest a.exe a_out.exe b.out conftest.*" ac_rmfiles= for ac_file in $ac_files do case $ac_file in *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.map | *.inf | *.dSYM | *.o | *.obj ) ;; * ) ac_rmfiles="$ac_rmfiles $ac_file";; esac done rm -f $ac_rmfiles if { { ac_try="$ac_link_default" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" $as_echo "$ac_try_echo"; } >&5 (eval "$ac_link_default") 2>&5 ac_status=$? $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 test $ac_status = 0; }; then : # Autoconf-2.13 could set the ac_cv_exeext variable to `no'. # So ignore a value of `no', otherwise this would lead to `EXEEXT = no' # in a Makefile. We should not override ac_cv_exeext if it was cached, # so that the user can short-circuit this test for compilers unknown to # Autoconf. for ac_file in $ac_files '' do test -f "$ac_file" || continue case $ac_file in *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.map | *.inf | *.dSYM | *.o | *.obj ) ;; [ab].out ) # We found the default executable, but exeext='' is most # certainly right. break;; *.* ) if test "${ac_cv_exeext+set}" = set && test "$ac_cv_exeext" != no; then :; else ac_cv_exeext=`expr "$ac_file" : '[^.]*\(\..*\)'` fi # We set ac_cv_exeext here because the later test for it is not # safe: cross compilers may not add the suffix if given an `-o' # argument, so we may need to know it at that point already. # Even if this section looks crufty: it has the advantage of # actually working. break;; * ) break;; esac done test "$ac_cv_exeext" = no && ac_cv_exeext= else ac_file='' fi if test -z "$ac_file"; then : { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error 77 "C compiler cannot create executables See \`config.log' for more details" "$LINENO" 5; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 $as_echo "yes" >&6; } fi { $as_echo "$as_me:${as_lineno-$LINENO}: checking for C compiler default output file name" >&5 $as_echo_n "checking for C compiler default output file name... " >&6; } { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_file" >&5 $as_echo "$ac_file" >&6; } ac_exeext=$ac_cv_exeext rm -f -r a.out a.out.dSYM a.exe conftest$ac_cv_exeext b.out ac_clean_files=$ac_clean_files_save { $as_echo "$as_me:${as_lineno-$LINENO}: checking for suffix of executables" >&5 $as_echo_n "checking for suffix of executables... " >&6; } if { { ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" $as_echo "$ac_try_echo"; } >&5 (eval "$ac_link") 2>&5 ac_status=$? $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 test $ac_status = 0; }; then : # If both `conftest.exe' and `conftest' are `present' (well, observable) # catch `conftest.exe'. For instance with Cygwin, `ls conftest' will # work properly (i.e., refer to `conftest.exe'), while it won't with # `rm'. for ac_file in conftest.exe conftest conftest.*; do test -f "$ac_file" || continue case $ac_file in *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.map | *.inf | *.dSYM | *.o | *.obj ) ;; *.* ) ac_cv_exeext=`expr "$ac_file" : '[^.]*\(\..*\)'` break;; * ) break;; esac done else { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error $? "cannot compute suffix of executables: cannot compile and link See \`config.log' for more details" "$LINENO" 5; } fi rm -f conftest conftest$ac_cv_exeext { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_exeext" >&5 $as_echo "$ac_cv_exeext" >&6; } rm -f conftest.$ac_ext EXEEXT=$ac_cv_exeext ac_exeext=$EXEEXT cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include int main () { FILE *f = fopen ("conftest.out", "w"); return ferror (f) || fclose (f) != 0; ; return 0; } _ACEOF ac_clean_files="$ac_clean_files conftest.out" # Check that the compiler produces executables we can run. If not, either # the compiler is broken, or we cross compile. { $as_echo "$as_me:${as_lineno-$LINENO}: checking whether we are cross compiling" >&5 $as_echo_n "checking whether we are cross compiling... " >&6; } if test "$cross_compiling" != yes; then { { ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" $as_echo "$ac_try_echo"; } >&5 (eval "$ac_link") 2>&5 ac_status=$? $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 test $ac_status = 0; } if { ac_try='./conftest$ac_cv_exeext' { { case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" $as_echo "$ac_try_echo"; } >&5 (eval "$ac_try") 2>&5 ac_status=$? $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 test $ac_status = 0; }; }; then cross_compiling=no else if test "$cross_compiling" = maybe; then cross_compiling=yes else { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error $? "cannot run C compiled programs. If you meant to cross compile, use \`--host'. See \`config.log' for more details" "$LINENO" 5; } fi fi fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $cross_compiling" >&5 $as_echo "$cross_compiling" >&6; } rm -f conftest.$ac_ext conftest$ac_cv_exeext conftest.out ac_clean_files=$ac_clean_files_save { $as_echo "$as_me:${as_lineno-$LINENO}: checking for suffix of object files" >&5 $as_echo_n "checking for suffix of object files... " >&6; } if ${ac_cv_objext+:} false; then : $as_echo_n "(cached) " >&6 else cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int main () { ; return 0; } _ACEOF rm -f conftest.o conftest.obj if { { ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" $as_echo "$ac_try_echo"; } >&5 (eval "$ac_compile") 2>&5 ac_status=$? $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 test $ac_status = 0; }; then : for ac_file in conftest.o conftest.obj conftest.*; do test -f "$ac_file" || continue; case $ac_file in *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.map | *.inf | *.dSYM ) ;; *) ac_cv_objext=`expr "$ac_file" : '.*\.\(.*\)'` break;; esac done else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error $? "cannot compute suffix of object files: cannot compile See \`config.log' for more details" "$LINENO" 5; } fi rm -f conftest.$ac_cv_objext conftest.$ac_ext fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_objext" >&5 $as_echo "$ac_cv_objext" >&6; } OBJEXT=$ac_cv_objext ac_objext=$OBJEXT { $as_echo "$as_me:${as_lineno-$LINENO}: checking whether we are using the GNU C compiler" >&5 $as_echo_n "checking whether we are using the GNU C compiler... " >&6; } if ${ac_cv_c_compiler_gnu+:} false; then : $as_echo_n "(cached) " >&6 else cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int main () { #ifndef __GNUC__ choke me #endif ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO"; then : ac_compiler_gnu=yes else ac_compiler_gnu=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext ac_cv_c_compiler_gnu=$ac_compiler_gnu fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_c_compiler_gnu" >&5 $as_echo "$ac_cv_c_compiler_gnu" >&6; } if test $ac_compiler_gnu = yes; then GCC=yes else GCC= fi ac_test_CFLAGS=${CFLAGS+set} ac_save_CFLAGS=$CFLAGS { $as_echo "$as_me:${as_lineno-$LINENO}: checking whether $CC accepts -g" >&5 $as_echo_n "checking whether $CC accepts -g... " >&6; } if ${ac_cv_prog_cc_g+:} false; then : $as_echo_n "(cached) " >&6 else ac_save_c_werror_flag=$ac_c_werror_flag ac_c_werror_flag=yes ac_cv_prog_cc_g=no CFLAGS="-g" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int main () { ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO"; then : ac_cv_prog_cc_g=yes else CFLAGS="" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int main () { ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO"; then : else ac_c_werror_flag=$ac_save_c_werror_flag CFLAGS="-g" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int main () { ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO"; then : ac_cv_prog_cc_g=yes fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext ac_c_werror_flag=$ac_save_c_werror_flag fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_prog_cc_g" >&5 $as_echo "$ac_cv_prog_cc_g" >&6; } if test "$ac_test_CFLAGS" = set; then CFLAGS=$ac_save_CFLAGS elif test $ac_cv_prog_cc_g = yes; then if test "$GCC" = yes; then CFLAGS="-g -O2" else CFLAGS="-g" fi else if test "$GCC" = yes; then CFLAGS="-O2" else CFLAGS= fi fi { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $CC option to accept ISO C89" >&5 $as_echo_n "checking for $CC option to accept ISO C89... " >&6; } if ${ac_cv_prog_cc_c89+:} false; then : $as_echo_n "(cached) " >&6 else ac_cv_prog_cc_c89=no ac_save_CC=$CC cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include #include struct stat; /* Most of the following tests are stolen from RCS 5.7's src/conf.sh. */ struct buf { int x; }; FILE * (*rcsopen) (struct buf *, struct stat *, int); static char *e (p, i) char **p; int i; { return p[i]; } static char *f (char * (*g) (char **, int), char **p, ...) { char *s; va_list v; va_start (v,p); s = g (p, va_arg (v,int)); va_end (v); return s; } /* OSF 4.0 Compaq cc is some sort of almost-ANSI by default. It has function prototypes and stuff, but not '\xHH' hex character constants. These don't provoke an error unfortunately, instead are silently treated as 'x'. The following induces an error, until -std is added to get proper ANSI mode. Curiously '\x00'!='x' always comes out true, for an array size at least. It's necessary to write '\x00'==0 to get something that's true only with -std. */ int osf4_cc_array ['\x00' == 0 ? 1 : -1]; /* IBM C 6 for AIX is almost-ANSI by default, but it replaces macro parameters inside strings and character constants. */ #define FOO(x) 'x' int xlc6_cc_array[FOO(a) == 'x' ? 1 : -1]; int test (int i, double x); struct s1 {int (*f) (int a);}; struct s2 {int (*f) (double a);}; int pairnames (int, char **, FILE *(*)(struct buf *, struct stat *, int), int, int); int argc; char **argv; int main () { return f (e, argv, 0) != argv[0] || f (e, argv, 1) != argv[1]; ; return 0; } _ACEOF for ac_arg in '' -qlanglvl=extc89 -qlanglvl=ansi -std \ -Ae "-Aa -D_HPUX_SOURCE" "-Xc -D__EXTENSIONS__" do CC="$ac_save_CC $ac_arg" if ac_fn_c_try_compile "$LINENO"; then : ac_cv_prog_cc_c89=$ac_arg fi rm -f core conftest.err conftest.$ac_objext test "x$ac_cv_prog_cc_c89" != "xno" && break done rm -f conftest.$ac_ext CC=$ac_save_CC fi # AC_CACHE_VAL case "x$ac_cv_prog_cc_c89" in x) { $as_echo "$as_me:${as_lineno-$LINENO}: result: none needed" >&5 $as_echo "none needed" >&6; } ;; xno) { $as_echo "$as_me:${as_lineno-$LINENO}: result: unsupported" >&5 $as_echo "unsupported" >&6; } ;; *) CC="$CC $ac_cv_prog_cc_c89" { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_prog_cc_c89" >&5 $as_echo "$ac_cv_prog_cc_c89" >&6; } ;; esac if test "x$ac_cv_prog_cc_c89" != xno; then : fi ac_ext=c ac_cpp='$CPP $CPPFLAGS' ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' ac_compiler_gnu=$ac_cv_c_compiler_gnu ac_ext=c ac_cpp='$CPP $CPPFLAGS' ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' ac_compiler_gnu=$ac_cv_c_compiler_gnu { $as_echo "$as_me:${as_lineno-$LINENO}: checking how to run the C preprocessor" >&5 $as_echo_n "checking how to run the C preprocessor... " >&6; } # On Suns, sometimes $CPP names a directory. if test -n "$CPP" && test -d "$CPP"; then CPP= fi if test -z "$CPP"; then if ${ac_cv_prog_CPP+:} false; then : $as_echo_n "(cached) " >&6 else # Double quotes because CPP needs to be expanded for CPP in "$CC -E" "$CC -E -traditional-cpp" "/lib/cpp" do ac_preproc_ok=false for ac_c_preproc_warn_flag in '' yes do # Use a header file that comes with gcc, so configuring glibc # with a fresh cross-compiler works. # Prefer to if __STDC__ is defined, since # exists even on freestanding compilers. # On the NeXT, cc -E runs the code through the compiler's parser, # not just through cpp. "Syntax error" is here to catch this case. cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #ifdef __STDC__ # include #else # include #endif Syntax error _ACEOF if ac_fn_c_try_cpp "$LINENO"; then : else # Broken: fails on valid input. continue fi rm -f conftest.err conftest.i conftest.$ac_ext # OK, works on sane cases. Now check whether nonexistent headers # can be detected and how. cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include _ACEOF if ac_fn_c_try_cpp "$LINENO"; then : # Broken: success on invalid input. continue else # Passes both tests. ac_preproc_ok=: break fi rm -f conftest.err conftest.i conftest.$ac_ext done # Because of `break', _AC_PREPROC_IFELSE's cleaning code was skipped. rm -f conftest.i conftest.err conftest.$ac_ext if $ac_preproc_ok; then : break fi done ac_cv_prog_CPP=$CPP fi CPP=$ac_cv_prog_CPP else ac_cv_prog_CPP=$CPP fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $CPP" >&5 $as_echo "$CPP" >&6; } ac_preproc_ok=false for ac_c_preproc_warn_flag in '' yes do # Use a header file that comes with gcc, so configuring glibc # with a fresh cross-compiler works. # Prefer to if __STDC__ is defined, since # exists even on freestanding compilers. # On the NeXT, cc -E runs the code through the compiler's parser, # not just through cpp. "Syntax error" is here to catch this case. cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #ifdef __STDC__ # include #else # include #endif Syntax error _ACEOF if ac_fn_c_try_cpp "$LINENO"; then : else # Broken: fails on valid input. continue fi rm -f conftest.err conftest.i conftest.$ac_ext # OK, works on sane cases. Now check whether nonexistent headers # can be detected and how. cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include _ACEOF if ac_fn_c_try_cpp "$LINENO"; then : # Broken: success on invalid input. continue else # Passes both tests. ac_preproc_ok=: break fi rm -f conftest.err conftest.i conftest.$ac_ext done # Because of `break', _AC_PREPROC_IFELSE's cleaning code was skipped. rm -f conftest.i conftest.err conftest.$ac_ext if $ac_preproc_ok; then : else { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error $? "C preprocessor \"$CPP\" fails sanity check See \`config.log' for more details" "$LINENO" 5; } fi ac_ext=c ac_cpp='$CPP $CPPFLAGS' ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' ac_compiler_gnu=$ac_cv_c_compiler_gnu { $as_echo "$as_me:${as_lineno-$LINENO}: checking for grep that handles long lines and -e" >&5 $as_echo_n "checking for grep that handles long lines and -e... " >&6; } if ${ac_cv_path_GREP+:} false; then : $as_echo_n "(cached) " >&6 else if test -z "$GREP"; then ac_path_GREP_found=false # Loop through the user's path and test for each of PROGNAME-LIST as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH$PATH_SEPARATOR/usr/xpg4/bin do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_prog in grep ggrep; do for ac_exec_ext in '' $ac_executable_extensions; do ac_path_GREP="$as_dir/$ac_prog$ac_exec_ext" as_fn_executable_p "$ac_path_GREP" || continue # Check for GNU ac_path_GREP and select it if it is found. # Check for GNU $ac_path_GREP case `"$ac_path_GREP" --version 2>&1` in *GNU*) ac_cv_path_GREP="$ac_path_GREP" ac_path_GREP_found=:;; *) ac_count=0 $as_echo_n 0123456789 >"conftest.in" while : do cat "conftest.in" "conftest.in" >"conftest.tmp" mv "conftest.tmp" "conftest.in" cp "conftest.in" "conftest.nl" $as_echo 'GREP' >> "conftest.nl" "$ac_path_GREP" -e 'GREP$' -e '-(cannot match)-' < "conftest.nl" >"conftest.out" 2>/dev/null || break diff "conftest.out" "conftest.nl" >/dev/null 2>&1 || break as_fn_arith $ac_count + 1 && ac_count=$as_val if test $ac_count -gt ${ac_path_GREP_max-0}; then # Best one so far, save it but keep looking for a better one ac_cv_path_GREP="$ac_path_GREP" ac_path_GREP_max=$ac_count fi # 10*(2^10) chars as input seems more than enough test $ac_count -gt 10 && break done rm -f conftest.in conftest.tmp conftest.nl conftest.out;; esac $ac_path_GREP_found && break 3 done done done IFS=$as_save_IFS if test -z "$ac_cv_path_GREP"; then as_fn_error $? "no acceptable grep could be found in $PATH$PATH_SEPARATOR/usr/xpg4/bin" "$LINENO" 5 fi else ac_cv_path_GREP=$GREP fi fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_path_GREP" >&5 $as_echo "$ac_cv_path_GREP" >&6; } GREP="$ac_cv_path_GREP" { $as_echo "$as_me:${as_lineno-$LINENO}: checking for egrep" >&5 $as_echo_n "checking for egrep... " >&6; } if ${ac_cv_path_EGREP+:} false; then : $as_echo_n "(cached) " >&6 else if echo a | $GREP -E '(a|b)' >/dev/null 2>&1 then ac_cv_path_EGREP="$GREP -E" else if test -z "$EGREP"; then ac_path_EGREP_found=false # Loop through the user's path and test for each of PROGNAME-LIST as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH$PATH_SEPARATOR/usr/xpg4/bin do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_prog in egrep; do for ac_exec_ext in '' $ac_executable_extensions; do ac_path_EGREP="$as_dir/$ac_prog$ac_exec_ext" as_fn_executable_p "$ac_path_EGREP" || continue # Check for GNU ac_path_EGREP and select it if it is found. # Check for GNU $ac_path_EGREP case `"$ac_path_EGREP" --version 2>&1` in *GNU*) ac_cv_path_EGREP="$ac_path_EGREP" ac_path_EGREP_found=:;; *) ac_count=0 $as_echo_n 0123456789 >"conftest.in" while : do cat "conftest.in" "conftest.in" >"conftest.tmp" mv "conftest.tmp" "conftest.in" cp "conftest.in" "conftest.nl" $as_echo 'EGREP' >> "conftest.nl" "$ac_path_EGREP" 'EGREP$' < "conftest.nl" >"conftest.out" 2>/dev/null || break diff "conftest.out" "conftest.nl" >/dev/null 2>&1 || break as_fn_arith $ac_count + 1 && ac_count=$as_val if test $ac_count -gt ${ac_path_EGREP_max-0}; then # Best one so far, save it but keep looking for a better one ac_cv_path_EGREP="$ac_path_EGREP" ac_path_EGREP_max=$ac_count fi # 10*(2^10) chars as input seems more than enough test $ac_count -gt 10 && break done rm -f conftest.in conftest.tmp conftest.nl conftest.out;; esac $ac_path_EGREP_found && break 3 done done done IFS=$as_save_IFS if test -z "$ac_cv_path_EGREP"; then as_fn_error $? "no acceptable egrep could be found in $PATH$PATH_SEPARATOR/usr/xpg4/bin" "$LINENO" 5 fi else ac_cv_path_EGREP=$EGREP fi fi fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_path_EGREP" >&5 $as_echo "$ac_cv_path_EGREP" >&6; } EGREP="$ac_cv_path_EGREP" { $as_echo "$as_me:${as_lineno-$LINENO}: checking for ANSI C header files" >&5 $as_echo_n "checking for ANSI C header files... " >&6; } if ${ac_cv_header_stdc+:} false; then : $as_echo_n "(cached) " >&6 else cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include #include #include #include int main () { ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO"; then : ac_cv_header_stdc=yes else ac_cv_header_stdc=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext if test $ac_cv_header_stdc = yes; then # SunOS 4.x string.h does not declare mem*, contrary to ANSI. cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include _ACEOF if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | $EGREP "memchr" >/dev/null 2>&1; then : else ac_cv_header_stdc=no fi rm -f conftest* fi if test $ac_cv_header_stdc = yes; then # ISC 2.0.2 stdlib.h does not declare free, contrary to ANSI. cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include _ACEOF if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | $EGREP "free" >/dev/null 2>&1; then : else ac_cv_header_stdc=no fi rm -f conftest* fi if test $ac_cv_header_stdc = yes; then # /bin/cc in Irix-4.0.5 gets non-ANSI ctype macros unless using -ansi. if test "$cross_compiling" = yes; then : : else cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include #include #if ((' ' & 0x0FF) == 0x020) # define ISLOWER(c) ('a' <= (c) && (c) <= 'z') # define TOUPPER(c) (ISLOWER(c) ? 'A' + ((c) - 'a') : (c)) #else # define ISLOWER(c) \ (('a' <= (c) && (c) <= 'i') \ || ('j' <= (c) && (c) <= 'r') \ || ('s' <= (c) && (c) <= 'z')) # define TOUPPER(c) (ISLOWER(c) ? ((c) | 0x40) : (c)) #endif #define XOR(e, f) (((e) && !(f)) || (!(e) && (f))) int main () { int i; for (i = 0; i < 256; i++) if (XOR (islower (i), ISLOWER (i)) || toupper (i) != TOUPPER (i)) return 2; return 0; } _ACEOF if ac_fn_c_try_run "$LINENO"; then : else ac_cv_header_stdc=no fi rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ conftest.$ac_objext conftest.beam conftest.$ac_ext fi fi fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_header_stdc" >&5 $as_echo "$ac_cv_header_stdc" >&6; } if test $ac_cv_header_stdc = yes; then $as_echo "#define STDC_HEADERS 1" >>confdefs.h fi # On IRIX 5.3, sys/types and inttypes.h are conflicting. for ac_header in sys/types.h sys/stat.h stdlib.h string.h memory.h strings.h \ inttypes.h stdint.h unistd.h do : as_ac_Header=`$as_echo "ac_cv_header_$ac_header" | $as_tr_sh` ac_fn_c_check_header_compile "$LINENO" "$ac_header" "$as_ac_Header" "$ac_includes_default " if eval test \"x\$"$as_ac_Header"\" = x"yes"; then : cat >>confdefs.h <<_ACEOF #define `$as_echo "HAVE_$ac_header" | $as_tr_cpp` 1 _ACEOF fi done # The cast to long int works around a bug in the HP C Compiler # version HP92453-01 B.11.11.23709.GP, which incorrectly rejects # declarations like `int a3[[(sizeof (unsigned char)) >= 0]];'. # This bug is HP SR number 8606223364. { $as_echo "$as_me:${as_lineno-$LINENO}: checking size of long" >&5 $as_echo_n "checking size of long... " >&6; } if ${ac_cv_sizeof_long+:} false; then : $as_echo_n "(cached) " >&6 else if ac_fn_c_compute_int "$LINENO" "(long int) (sizeof (long))" "ac_cv_sizeof_long" "$ac_includes_default"; then : else if test "$ac_cv_type_long" = yes; then { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error 77 "cannot compute sizeof (long) See \`config.log' for more details" "$LINENO" 5; } else ac_cv_sizeof_long=0 fi fi fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_sizeof_long" >&5 $as_echo "$ac_cv_sizeof_long" >&6; } cat >>confdefs.h <<_ACEOF #define SIZEOF_LONG $ac_cv_sizeof_long _ACEOF if test "$ac_cv_sizeof_long" -eq 8; then : OSBIT=64 else OSBIT=32 fi # Check whether --enable-rebuild_doc was given. if test "${enable_rebuild_doc+set}" = set; then : enableval=$enable_rebuild_doc; enable_rebuild_doc="${enableval}" else enable_rebuild_doc=no fi if test x"$enable_rebuild_doc" = x"yes" then # Extract the first word of "xelatex", so it can be a program name with args. set dummy xelatex; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if ${ac_cv_prog_xelatex_avail+:} false; then : $as_echo_n "(cached) " >&6 else if test -n "$xelatex_avail"; then ac_cv_prog_xelatex_avail="$xelatex_avail" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_prog_xelatex_avail="yes" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS test -z "$ac_cv_prog_xelatex_avail" && ac_cv_prog_xelatex_avail="no" fi fi xelatex_avail=$ac_cv_prog_xelatex_avail if test -n "$xelatex_avail"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $xelatex_avail" >&5 $as_echo "$xelatex_avail" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi # Extract the first word of "bibtex", so it can be a program name with args. set dummy bibtex; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if ${ac_cv_prog_bibtex_avail+:} false; then : $as_echo_n "(cached) " >&6 else if test -n "$bibtex_avail"; then ac_cv_prog_bibtex_avail="$bibtex_avail" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_prog_bibtex_avail="yes" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS test -z "$ac_cv_prog_bibtex_avail" && ac_cv_prog_bibtex_avail="no" fi fi bibtex_avail=$ac_cv_prog_bibtex_avail if test -n "$bibtex_avail"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $bibtex_avail" >&5 $as_echo "$bibtex_avail" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi # Extract the first word of "pandoc", so it can be a program name with args. set dummy pandoc; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if ${ac_cv_prog_pandoc_avail+:} false; then : $as_echo_n "(cached) " >&6 else if test -n "$pandoc_avail"; then ac_cv_prog_pandoc_avail="$pandoc_avail" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_prog_pandoc_avail="yes" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS test -z "$ac_cv_prog_pandoc_avail" && ac_cv_prog_pandoc_avail="no" fi fi pandoc_avail=$ac_cv_prog_pandoc_avail if test -n "$pandoc_avail"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $pandoc_avail" >&5 $as_echo "$pandoc_avail" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi # Extract the first word of "pdflatex", so it can be a program name with args. set dummy pdflatex; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if ${ac_cv_prog_pdflatex_avail+:} false; then : $as_echo_n "(cached) " >&6 else if test -n "$pdflatex_avail"; then ac_cv_prog_pdflatex_avail="$pdflatex_avail" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_prog_pdflatex_avail="yes" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS test -z "$ac_cv_prog_pdflatex_avail" && ac_cv_prog_pdflatex_avail="no" fi fi pdflatex_avail=$ac_cv_prog_pdflatex_avail if test -n "$pdflatex_avail"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $pdflatex_avail" >&5 $as_echo "$pdflatex_avail" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi if test $xelatex_avail = no \ -o $bibtex_avail = no \ -o $pandoc_avail = no \ -o $pdflatex_avail = no then { $as_echo "$as_me:${as_lineno-$LINENO}: Not all TeX related programs are found, disabling rebuild of documentation." >&5 $as_echo "$as_me: Not all TeX related programs are found, disabling rebuild of documentation." >&6;} enable_rebuild_doc=no fi fi # Check whether --enable-traditional_layout was given. if test "${enable_traditional_layout+set}" = set; then : enableval=$enable_traditional_layout; enable_traditional_layout="${enableval}" else enable_traditional_layout=no fi # Check whether --enable-windows was given. if test "${enable_windows+set}" = set; then : enableval=$enable_windows; enable_windows="${enableval}" else enable_windows=no fi # Check whether --enable-distribution was given. if test "${enable_distribution+set}" = set; then : enableval=$enable_distribution; enable_distribution="${enableval}" else enable_distribution=no fi ac_config_files="$ac_config_files Makefile make-cafeobj.lisp version.lisp xbin/cafeobj.in doc/refman/Makefile doc/manual/Makefile doc/RefCard/Makefile doc/PigNose/Makefile doc/citp-manual/Makefile doc/namespace/Makefile doc/etc/Makefile doc/search/Makefile" cat >confcache <<\_ACEOF # This file is a shell script that caches the results of configure # tests run on this system so they can be shared between configure # scripts and configure runs, see configure's option --config-cache. # It is not useful on other systems. If it contains results you don't # want to keep, you may remove or edit it. # # config.status only pays attention to the cache file if you give it # the --recheck option to rerun configure. # # `ac_cv_env_foo' variables (set or unset) will be overridden when # loading this file, other *unset* `ac_cv_foo' will be assigned the # following values. _ACEOF # The following way of writing the cache mishandles newlines in values, # but we know of no workaround that is simple, portable, and efficient. # So, we kill variables containing newlines. # Ultrix sh set writes to stderr and can't be redirected directly, # and sets the high bit in the cache file unless we assign to the vars. ( for ac_var in `(set) 2>&1 | sed -n 's/^\([a-zA-Z_][a-zA-Z0-9_]*\)=.*/\1/p'`; do eval ac_val=\$$ac_var case $ac_val in #( *${as_nl}*) case $ac_var in #( *_cv_*) { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: cache variable $ac_var contains a newline" >&5 $as_echo "$as_me: WARNING: cache variable $ac_var contains a newline" >&2;} ;; esac case $ac_var in #( _ | IFS | as_nl) ;; #( BASH_ARGV | BASH_SOURCE) eval $ac_var= ;; #( *) { eval $ac_var=; unset $ac_var;} ;; esac ;; esac done (set) 2>&1 | case $as_nl`(ac_space=' '; set) 2>&1` in #( *${as_nl}ac_space=\ *) # `set' does not quote correctly, so add quotes: double-quote # substitution turns \\\\ into \\, and sed turns \\ into \. sed -n \ "s/'/'\\\\''/g; s/^\\([_$as_cr_alnum]*_cv_[_$as_cr_alnum]*\\)=\\(.*\\)/\\1='\\2'/p" ;; #( *) # `set' quotes correctly as required by POSIX, so do not add quotes. sed -n "/^[_$as_cr_alnum]*_cv_[_$as_cr_alnum]*=/p" ;; esac | sort ) | sed ' /^ac_cv_env_/b end t clear :clear s/^\([^=]*\)=\(.*[{}].*\)$/test "${\1+set}" = set || &/ t end s/^\([^=]*\)=\(.*\)$/\1=${\1=\2}/ :end' >>confcache if diff "$cache_file" confcache >/dev/null 2>&1; then :; else if test -w "$cache_file"; then if test "x$cache_file" != "x/dev/null"; then { $as_echo "$as_me:${as_lineno-$LINENO}: updating cache $cache_file" >&5 $as_echo "$as_me: updating cache $cache_file" >&6;} if test ! -f "$cache_file" || test -h "$cache_file"; then cat confcache >"$cache_file" else case $cache_file in #( */* | ?:*) mv -f confcache "$cache_file"$$ && mv -f "$cache_file"$$ "$cache_file" ;; #( *) mv -f confcache "$cache_file" ;; esac fi fi else { $as_echo "$as_me:${as_lineno-$LINENO}: not updating unwritable cache $cache_file" >&5 $as_echo "$as_me: not updating unwritable cache $cache_file" >&6;} fi fi rm -f confcache test "x$prefix" = xNONE && prefix=$ac_default_prefix # Let make expand exec_prefix. test "x$exec_prefix" = xNONE && exec_prefix='${prefix}' # Transform confdefs.h into DEFS. # Protect against shell expansion while executing Makefile rules. # Protect against Makefile macro expansion. # # If the first sed substitution is executed (which looks for macros that # take arguments), then branch to the quote section. Otherwise, # look for a macro that doesn't take arguments. ac_script=' :mline /\\$/{ N s,\\\n,, b mline } t clear :clear s/^[ ]*#[ ]*define[ ][ ]*\([^ (][^ (]*([^)]*)\)[ ]*\(.*\)/-D\1=\2/g t quote s/^[ ]*#[ ]*define[ ][ ]*\([^ ][^ ]*\)[ ]*\(.*\)/-D\1=\2/g t quote b any :quote s/[ `~#$^&*(){}\\|;'\''"<>?]/\\&/g s/\[/\\&/g s/\]/\\&/g s/\$/$$/g H :any ${ g s/^\n// s/\n/ /g p } ' DEFS=`sed -n "$ac_script" confdefs.h` ac_libobjs= ac_ltlibobjs= U= for ac_i in : $LIBOBJS; do test "x$ac_i" = x: && continue # 1. Remove the extension, and $U if already installed. ac_script='s/\$U\././;s/\.o$//;s/\.obj$//' ac_i=`$as_echo "$ac_i" | sed "$ac_script"` # 2. Prepend LIBOBJDIR. When used with automake>=1.10 LIBOBJDIR # will be set to the directory where LIBOBJS objects are built. as_fn_append ac_libobjs " \${LIBOBJDIR}$ac_i\$U.$ac_objext" as_fn_append ac_ltlibobjs " \${LIBOBJDIR}$ac_i"'$U.lo' done LIBOBJS=$ac_libobjs LTLIBOBJS=$ac_ltlibobjs : "${CONFIG_STATUS=./config.status}" ac_write_fail=0 ac_clean_files_save=$ac_clean_files ac_clean_files="$ac_clean_files $CONFIG_STATUS" { $as_echo "$as_me:${as_lineno-$LINENO}: creating $CONFIG_STATUS" >&5 $as_echo "$as_me: creating $CONFIG_STATUS" >&6;} as_write_fail=0 cat >$CONFIG_STATUS <<_ASEOF || as_write_fail=1 #! $SHELL # Generated by $as_me. # Run this file to recreate the current configuration. # Compiler output produced by configure, useful for debugging # configure, is in config.log if it exists. debug=false ac_cs_recheck=false ac_cs_silent=false SHELL=\${CONFIG_SHELL-$SHELL} export SHELL _ASEOF cat >>$CONFIG_STATUS <<\_ASEOF || as_write_fail=1 ## -------------------- ## ## M4sh Initialization. ## ## -------------------- ## # Be more Bourne compatible DUALCASE=1; export DUALCASE # for MKS sh if test -n "${ZSH_VERSION+set}" && (emulate sh) >/dev/null 2>&1; then : emulate sh NULLCMD=: # Pre-4.2 versions of Zsh do word splitting on ${1+"$@"}, which # is contrary to our usage. Disable this feature. alias -g '${1+"$@"}'='"$@"' setopt NO_GLOB_SUBST else case `(set -o) 2>/dev/null` in #( *posix*) : set -o posix ;; #( *) : ;; esac fi as_nl=' ' export as_nl # Printing a long string crashes Solaris 7 /usr/bin/printf. as_echo='\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\' as_echo=$as_echo$as_echo$as_echo$as_echo$as_echo as_echo=$as_echo$as_echo$as_echo$as_echo$as_echo$as_echo # Prefer a ksh shell builtin over an external printf program on Solaris, # but without wasting forks for bash or zsh. if test -z "$BASH_VERSION$ZSH_VERSION" \ && (test "X`print -r -- $as_echo`" = "X$as_echo") 2>/dev/null; then as_echo='print -r --' as_echo_n='print -rn --' elif (test "X`printf %s $as_echo`" = "X$as_echo") 2>/dev/null; then as_echo='printf %s\n' as_echo_n='printf %s' else if test "X`(/usr/ucb/echo -n -n $as_echo) 2>/dev/null`" = "X-n $as_echo"; then as_echo_body='eval /usr/ucb/echo -n "$1$as_nl"' as_echo_n='/usr/ucb/echo -n' else as_echo_body='eval expr "X$1" : "X\\(.*\\)"' as_echo_n_body='eval arg=$1; case $arg in #( *"$as_nl"*) expr "X$arg" : "X\\(.*\\)$as_nl"; arg=`expr "X$arg" : ".*$as_nl\\(.*\\)"`;; esac; expr "X$arg" : "X\\(.*\\)" | tr -d "$as_nl" ' export as_echo_n_body as_echo_n='sh -c $as_echo_n_body as_echo' fi export as_echo_body as_echo='sh -c $as_echo_body as_echo' fi # The user is always right. if test "${PATH_SEPARATOR+set}" != set; then PATH_SEPARATOR=: (PATH='/bin;/bin'; FPATH=$PATH; sh -c :) >/dev/null 2>&1 && { (PATH='/bin:/bin'; FPATH=$PATH; sh -c :) >/dev/null 2>&1 || PATH_SEPARATOR=';' } fi # IFS # We need space, tab and new line, in precisely that order. Quoting is # there to prevent editors from complaining about space-tab. # (If _AS_PATH_WALK were called with IFS unset, it would disable word # splitting by setting IFS to empty value.) IFS=" "" $as_nl" # Find who we are. Look in the path if we contain no directory separator. as_myself= case $0 in #(( *[\\/]* ) as_myself=$0 ;; *) as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. test -r "$as_dir/$0" && as_myself=$as_dir/$0 && break done IFS=$as_save_IFS ;; esac # We did not find ourselves, most probably we were run as `sh COMMAND' # in which case we are not to be found in the path. if test "x$as_myself" = x; then as_myself=$0 fi if test ! -f "$as_myself"; then $as_echo "$as_myself: error: cannot find myself; rerun with an absolute file name" >&2 exit 1 fi # Unset variables that we do not need and which cause bugs (e.g. in # pre-3.0 UWIN ksh). But do not cause bugs in bash 2.01; the "|| exit 1" # suppresses any "Segmentation fault" message there. '((' could # trigger a bug in pdksh 5.2.14. for as_var in BASH_ENV ENV MAIL MAILPATH do eval test x\${$as_var+set} = xset \ && ( (unset $as_var) || exit 1) >/dev/null 2>&1 && unset $as_var || : done PS1='$ ' PS2='> ' PS4='+ ' # NLS nuisances. LC_ALL=C export LC_ALL LANGUAGE=C export LANGUAGE # CDPATH. (unset CDPATH) >/dev/null 2>&1 && unset CDPATH # as_fn_error STATUS ERROR [LINENO LOG_FD] # ---------------------------------------- # Output "`basename $0`: error: ERROR" to stderr. If LINENO and LOG_FD are # provided, also output the error to LOG_FD, referencing LINENO. Then exit the # script with STATUS, using 1 if that was 0. as_fn_error () { as_status=$1; test $as_status -eq 0 && as_status=1 if test "$4"; then as_lineno=${as_lineno-"$3"} as_lineno_stack=as_lineno_stack=$as_lineno_stack $as_echo "$as_me:${as_lineno-$LINENO}: error: $2" >&$4 fi $as_echo "$as_me: error: $2" >&2 as_fn_exit $as_status } # as_fn_error # as_fn_set_status STATUS # ----------------------- # Set $? to STATUS, without forking. as_fn_set_status () { return $1 } # as_fn_set_status # as_fn_exit STATUS # ----------------- # Exit the shell with STATUS, even in a "trap 0" or "set -e" context. as_fn_exit () { set +e as_fn_set_status $1 exit $1 } # as_fn_exit # as_fn_unset VAR # --------------- # Portably unset VAR. as_fn_unset () { { eval $1=; unset $1;} } as_unset=as_fn_unset # as_fn_append VAR VALUE # ---------------------- # Append the text in VALUE to the end of the definition contained in VAR. Take # advantage of any shell optimizations that allow amortized linear growth over # repeated appends, instead of the typical quadratic growth present in naive # implementations. if (eval "as_var=1; as_var+=2; test x\$as_var = x12") 2>/dev/null; then : eval 'as_fn_append () { eval $1+=\$2 }' else as_fn_append () { eval $1=\$$1\$2 } fi # as_fn_append # as_fn_arith ARG... # ------------------ # Perform arithmetic evaluation on the ARGs, and store the result in the # global $as_val. Take advantage of shells that can avoid forks. The arguments # must be portable across $(()) and expr. if (eval "test \$(( 1 + 1 )) = 2") 2>/dev/null; then : eval 'as_fn_arith () { as_val=$(( $* )) }' else as_fn_arith () { as_val=`expr "$@" || test $? -eq 1` } fi # as_fn_arith if expr a : '\(a\)' >/dev/null 2>&1 && test "X`expr 00001 : '.*\(...\)'`" = X001; then as_expr=expr else as_expr=false fi if (basename -- /) >/dev/null 2>&1 && test "X`basename -- / 2>&1`" = "X/"; then as_basename=basename else as_basename=false fi if (as_dir=`dirname -- /` && test "X$as_dir" = X/) >/dev/null 2>&1; then as_dirname=dirname else as_dirname=false fi as_me=`$as_basename -- "$0" || $as_expr X/"$0" : '.*/\([^/][^/]*\)/*$' \| \ X"$0" : 'X\(//\)$' \| \ X"$0" : 'X\(/\)' \| . 2>/dev/null || $as_echo X/"$0" | sed '/^.*\/\([^/][^/]*\)\/*$/{ s//\1/ q } /^X\/\(\/\/\)$/{ s//\1/ q } /^X\/\(\/\).*/{ s//\1/ q } s/.*/./; q'` # Avoid depending upon Character Ranges. as_cr_letters='abcdefghijklmnopqrstuvwxyz' as_cr_LETTERS='ABCDEFGHIJKLMNOPQRSTUVWXYZ' as_cr_Letters=$as_cr_letters$as_cr_LETTERS as_cr_digits='0123456789' as_cr_alnum=$as_cr_Letters$as_cr_digits ECHO_C= ECHO_N= ECHO_T= case `echo -n x` in #((((( -n*) case `echo 'xy\c'` in *c*) ECHO_T=' ';; # ECHO_T is single tab character. xy) ECHO_C='\c';; *) echo `echo ksh88 bug on AIX 6.1` > /dev/null ECHO_T=' ';; esac;; *) ECHO_N='-n';; esac rm -f conf$$ conf$$.exe conf$$.file if test -d conf$$.dir; then rm -f conf$$.dir/conf$$.file else rm -f conf$$.dir mkdir conf$$.dir 2>/dev/null fi if (echo >conf$$.file) 2>/dev/null; then if ln -s conf$$.file conf$$ 2>/dev/null; then as_ln_s='ln -s' # ... but there are two gotchas: # 1) On MSYS, both `ln -s file dir' and `ln file dir' fail. # 2) DJGPP < 2.04 has no symlinks; `ln -s' creates a wrapper executable. # In both cases, we have to default to `cp -pR'. ln -s conf$$.file conf$$.dir 2>/dev/null && test ! -f conf$$.exe || as_ln_s='cp -pR' elif ln conf$$.file conf$$ 2>/dev/null; then as_ln_s=ln else as_ln_s='cp -pR' fi else as_ln_s='cp -pR' fi rm -f conf$$ conf$$.exe conf$$.dir/conf$$.file conf$$.file rmdir conf$$.dir 2>/dev/null # as_fn_mkdir_p # ------------- # Create "$as_dir" as a directory, including parents if necessary. as_fn_mkdir_p () { case $as_dir in #( -*) as_dir=./$as_dir;; esac test -d "$as_dir" || eval $as_mkdir_p || { as_dirs= while :; do case $as_dir in #( *\'*) as_qdir=`$as_echo "$as_dir" | sed "s/'/'\\\\\\\\''/g"`;; #'( *) as_qdir=$as_dir;; esac as_dirs="'$as_qdir' $as_dirs" as_dir=`$as_dirname -- "$as_dir" || $as_expr X"$as_dir" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ X"$as_dir" : 'X\(//\)[^/]' \| \ X"$as_dir" : 'X\(//\)$' \| \ X"$as_dir" : 'X\(/\)' \| . 2>/dev/null || $as_echo X"$as_dir" | sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ s//\1/ q } /^X\(\/\/\)[^/].*/{ s//\1/ q } /^X\(\/\/\)$/{ s//\1/ q } /^X\(\/\).*/{ s//\1/ q } s/.*/./; q'` test -d "$as_dir" && break done test -z "$as_dirs" || eval "mkdir $as_dirs" } || test -d "$as_dir" || as_fn_error $? "cannot create directory $as_dir" } # as_fn_mkdir_p if mkdir -p . 2>/dev/null; then as_mkdir_p='mkdir -p "$as_dir"' else test -d ./-p && rmdir ./-p as_mkdir_p=false fi # as_fn_executable_p FILE # ----------------------- # Test if FILE is an executable regular file. as_fn_executable_p () { test -f "$1" && test -x "$1" } # as_fn_executable_p as_test_x='test -x' as_executable_p=as_fn_executable_p # Sed expression to map a string onto a valid CPP name. as_tr_cpp="eval sed 'y%*$as_cr_letters%P$as_cr_LETTERS%;s%[^_$as_cr_alnum]%_%g'" # Sed expression to map a string onto a valid variable name. as_tr_sh="eval sed 'y%*+%pp%;s%[^_$as_cr_alnum]%_%g'" exec 6>&1 ## ----------------------------------- ## ## Main body of $CONFIG_STATUS script. ## ## ----------------------------------- ## _ASEOF test $as_write_fail = 0 && chmod +x $CONFIG_STATUS || ac_write_fail=1 cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 # Save the log message, to keep $0 and so on meaningful, and to # report actual input values of CONFIG_FILES etc. instead of their # values after options handling. ac_log=" This file was extended by CafeOBJ $as_me 1.6, which was generated by GNU Autoconf 2.69. Invocation command line was CONFIG_FILES = $CONFIG_FILES CONFIG_HEADERS = $CONFIG_HEADERS CONFIG_LINKS = $CONFIG_LINKS CONFIG_COMMANDS = $CONFIG_COMMANDS $ $0 $@ on `(hostname || uname -n) 2>/dev/null | sed 1q` " _ACEOF case $ac_config_files in *" "*) set x $ac_config_files; shift; ac_config_files=$*;; esac cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 # Files that config.status was made for. config_files="$ac_config_files" _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 ac_cs_usage="\ \`$as_me' instantiates files and other configuration actions from templates according to the current configuration. Unless the files and actions are specified as TAGs, all are instantiated by default. Usage: $0 [OPTION]... [TAG]... -h, --help print this help, then exit -V, --version print version number and configuration settings, then exit --config print configuration, then exit -q, --quiet, --silent do not print progress messages -d, --debug don't remove temporary files --recheck update $as_me by reconfiguring in the same conditions --file=FILE[:TEMPLATE] instantiate the configuration file FILE Configuration files: $config_files Report bugs to the package provider. CafeOBJ home page: ." _ACEOF cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 ac_cs_config="`$as_echo "$ac_configure_args" | sed 's/^ //; s/[\\""\`\$]/\\\\&/g'`" ac_cs_version="\\ CafeOBJ config.status 1.6 configured by $0, generated by GNU Autoconf 2.69, with options \\"\$ac_cs_config\\" Copyright (C) 2012 Free Software Foundation, Inc. This config.status script is free software; the Free Software Foundation gives unlimited permission to copy, distribute and modify it." ac_pwd='$ac_pwd' srcdir='$srcdir' INSTALL='$INSTALL' MKDIR_P='$MKDIR_P' test -n "\$AWK" || AWK=awk _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 # The default lists apply if the user does not specify any file. ac_need_defaults=: while test $# != 0 do case $1 in --*=?*) ac_option=`expr "X$1" : 'X\([^=]*\)='` ac_optarg=`expr "X$1" : 'X[^=]*=\(.*\)'` ac_shift=: ;; --*=) ac_option=`expr "X$1" : 'X\([^=]*\)='` ac_optarg= ac_shift=: ;; *) ac_option=$1 ac_optarg=$2 ac_shift=shift ;; esac case $ac_option in # Handling of the options. -recheck | --recheck | --rechec | --reche | --rech | --rec | --re | --r) ac_cs_recheck=: ;; --version | --versio | --versi | --vers | --ver | --ve | --v | -V ) $as_echo "$ac_cs_version"; exit ;; --config | --confi | --conf | --con | --co | --c ) $as_echo "$ac_cs_config"; exit ;; --debug | --debu | --deb | --de | --d | -d ) debug=: ;; --file | --fil | --fi | --f ) $ac_shift case $ac_optarg in *\'*) ac_optarg=`$as_echo "$ac_optarg" | sed "s/'/'\\\\\\\\''/g"` ;; '') as_fn_error $? "missing file argument" ;; esac as_fn_append CONFIG_FILES " '$ac_optarg'" ac_need_defaults=false;; --he | --h | --help | --hel | -h ) $as_echo "$ac_cs_usage"; exit ;; -q | -quiet | --quiet | --quie | --qui | --qu | --q \ | -silent | --silent | --silen | --sile | --sil | --si | --s) ac_cs_silent=: ;; # This is an error. -*) as_fn_error $? "unrecognized option: \`$1' Try \`$0 --help' for more information." ;; *) as_fn_append ac_config_targets " $1" ac_need_defaults=false ;; esac shift done ac_configure_extra_args= if $ac_cs_silent; then exec 6>/dev/null ac_configure_extra_args="$ac_configure_extra_args --silent" fi _ACEOF cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 if \$ac_cs_recheck; then set X $SHELL '$0' $ac_configure_args \$ac_configure_extra_args --no-create --no-recursion shift \$as_echo "running CONFIG_SHELL=$SHELL \$*" >&6 CONFIG_SHELL='$SHELL' export CONFIG_SHELL exec "\$@" fi _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 exec 5>>config.log { echo sed 'h;s/./-/g;s/^.../## /;s/...$/ ##/;p;x;p;x' <<_ASBOX ## Running $as_me. ## _ASBOX $as_echo "$ac_log" } >&5 _ACEOF cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 _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 "Makefile") CONFIG_FILES="$CONFIG_FILES Makefile" ;; "make-cafeobj.lisp") CONFIG_FILES="$CONFIG_FILES make-cafeobj.lisp" ;; "version.lisp") CONFIG_FILES="$CONFIG_FILES version.lisp" ;; "xbin/cafeobj.in") CONFIG_FILES="$CONFIG_FILES xbin/cafeobj.in" ;; "doc/refman/Makefile") CONFIG_FILES="$CONFIG_FILES doc/refman/Makefile" ;; "doc/manual/Makefile") CONFIG_FILES="$CONFIG_FILES doc/manual/Makefile" ;; "doc/RefCard/Makefile") CONFIG_FILES="$CONFIG_FILES doc/RefCard/Makefile" ;; "doc/PigNose/Makefile") CONFIG_FILES="$CONFIG_FILES doc/PigNose/Makefile" ;; "doc/citp-manual/Makefile") CONFIG_FILES="$CONFIG_FILES doc/citp-manual/Makefile" ;; "doc/namespace/Makefile") CONFIG_FILES="$CONFIG_FILES doc/namespace/Makefile" ;; "doc/etc/Makefile") CONFIG_FILES="$CONFIG_FILES doc/etc/Makefile" ;; "doc/search/Makefile") CONFIG_FILES="$CONFIG_FILES doc/search/Makefile" ;; *) as_fn_error $? "invalid argument: \`$ac_config_target'" "$LINENO" 5;; esac done # If the user did not use the arguments to specify the items to instantiate, # then the envvar interface is used. Set only those that are not. # We use the long form for the default assignment because of an extremely # bizarre bug on SunOS 4.1.3. if $ac_need_defaults; then test "${CONFIG_FILES+set}" = set || CONFIG_FILES=$config_files fi # Have a temporary directory for convenience. Make it in the build tree # simply because there is no reason against having it here, and in addition, # creating and moving files from /tmp can sometimes cause problems. # Hook for its removal unless debugging. # Note that there is a small window in which the directory will not be cleaned: # after its creation but before its name has been assigned to `$tmp'. $debug || { tmp= ac_tmp= trap 'exit_status=$? : "${ac_tmp:=$tmp}" { test ! -d "$ac_tmp" || rm -fr "$ac_tmp"; } && exit $exit_status ' 0 trap 'as_fn_exit 1' 1 2 13 15 } # Create a (secure) tmp directory for tmp files. { tmp=`(umask 077 && mktemp -d "./confXXXXXX") 2>/dev/null` && test -d "$tmp" } || { tmp=./conf$$-$RANDOM (umask 077 && mkdir "$tmp") } || as_fn_error $? "cannot create a temporary directory in ." "$LINENO" 5 ac_tmp=$tmp # Set up the scripts for CONFIG_FILES section. # No need to generate them if there are no CONFIG_FILES. # This happens for instance with `./config.status config.h'. if test -n "$CONFIG_FILES"; then ac_cr=`echo X | tr X '\015'` # On cygwin, bash can eat \r inside `` if the user requested igncr. # But we know of no other shell where ac_cr would be empty at this # point, so we can use a bashism as a fallback. if test "x$ac_cr" = x; then eval ac_cr=\$\'\\r\' fi ac_cs_awk_cr=`$AWK 'BEGIN { print "a\rb" }' /dev/null` if test "$ac_cs_awk_cr" = "a${ac_cr}b"; then ac_cs_awk_cr='\\r' else ac_cs_awk_cr=$ac_cr fi echo 'BEGIN {' >"$ac_tmp/subs1.awk" && _ACEOF { echo "cat >conf$$subs.awk <<_ACEOF" && echo "$ac_subst_vars" | sed 's/.*/&!$&$ac_delim/' && echo "_ACEOF" } >conf$$subs.sh || as_fn_error $? "could not make $CONFIG_STATUS" "$LINENO" 5 ac_delim_num=`echo "$ac_subst_vars" | grep -c '^'` ac_delim='%!_!# ' for ac_last_try in false false false false false :; do . ./conf$$subs.sh || as_fn_error $? "could not make $CONFIG_STATUS" "$LINENO" 5 ac_delim_n=`sed -n "s/.*$ac_delim\$/X/p" conf$$subs.awk | grep -c X` if test $ac_delim_n = $ac_delim_num; then break elif $ac_last_try; then as_fn_error $? "could not make $CONFIG_STATUS" "$LINENO" 5 else ac_delim="$ac_delim!$ac_delim _$ac_delim!! " fi done rm -f conf$$subs.sh cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 cat >>"\$ac_tmp/subs1.awk" <<\\_ACAWK && _ACEOF sed -n ' h s/^/S["/; s/!.*/"]=/ p g s/^[^!]*!// :repl t repl s/'"$ac_delim"'$// t delim :nl h s/\(.\{148\}\)..*/\1/ t more1 s/["\\]/\\&/g; s/^/"/; s/$/\\n"\\/ p n b repl :more1 s/["\\]/\\&/g; s/^/"/; s/$/"\\/ p g s/.\{148\}// t nl :delim h s/\(.\{148\}\)..*/\1/ t more2 s/["\\]/\\&/g; s/^/"/; s/$/"/ p b :more2 s/["\\]/\\&/g; s/^/"/; s/$/"\\/ p g s/.\{148\}// t delim ' >$CONFIG_STATUS || ac_write_fail=1 rm -f conf$$subs.awk cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 _ACAWK cat >>"\$ac_tmp/subs1.awk" <<_ACAWK && for (key in S) S_is_set[key] = 1 FS = "" } { line = $ 0 nfields = split(line, field, "@") substed = 0 len = length(field[1]) for (i = 2; i < nfields; i++) { key = field[i] keylen = length(key) if (S_is_set[key]) { value = S[key] line = substr(line, 1, len) "" value "" substr(line, len + keylen + 3) len += length(value) + length(field[++i]) substed = 1 } else len += 1 + keylen } print line } _ACAWK _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 if sed "s/$ac_cr//" < /dev/null > /dev/null 2>&1; then sed "s/$ac_cr\$//; s/$ac_cr/$ac_cs_awk_cr/g" else cat fi < "$ac_tmp/subs1.awk" > "$ac_tmp/subs.awk" \ || as_fn_error $? "could not setup config files machinery" "$LINENO" 5 _ACEOF # VPATH may cause trouble with some makes, so we remove sole $(srcdir), # ${srcdir} and @srcdir@ entries from VPATH if srcdir is ".", strip leading and # trailing colons and then remove the whole line if VPATH becomes empty # (actually we leave an empty line to preserve line numbers). if test "x$srcdir" = x.; then ac_vpsub='/^[ ]*VPATH[ ]*=[ ]*/{ h s/// s/^/:/ s/[ ]*$/:/ s/:\$(srcdir):/:/g s/:\${srcdir}:/:/g s/:@srcdir@:/:/g s/^:*// s/:*$// x s/\(=[ ]*\).*/\1/ G s/\n// s/^[^=]*=[ ]*$// }' fi cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 fi # test -n "$CONFIG_FILES" eval set X " :F $CONFIG_FILES " shift for ac_tag do case $ac_tag in :[FHLC]) ac_mode=$ac_tag; continue;; esac case $ac_mode$ac_tag in :[FHL]*:*);; :L* | :C*:*) as_fn_error $? "invalid tag \`$ac_tag'" "$LINENO" 5;; :[FH]-) ac_tag=-:-;; :[FH]*) ac_tag=$ac_tag:$ac_tag.in;; esac ac_save_IFS=$IFS IFS=: set x $ac_tag IFS=$ac_save_IFS shift ac_file=$1 shift case $ac_mode in :L) ac_source=$1;; :[FH]) ac_file_inputs= for ac_f do case $ac_f in -) ac_f="$ac_tmp/stdin";; *) # Look for the file first in the build tree, then in the source tree # (if the path is not absolute). The absolute path cannot be DOS-style, # because $ac_f cannot contain `:'. test -f "$ac_f" || case $ac_f in [\\/$]*) false;; *) test -f "$srcdir/$ac_f" && ac_f="$srcdir/$ac_f";; esac || as_fn_error 1 "cannot find input file: \`$ac_f'" "$LINENO" 5;; esac case $ac_f in *\'*) ac_f=`$as_echo "$ac_f" | sed "s/'/'\\\\\\\\''/g"`;; esac as_fn_append ac_file_inputs " '$ac_f'" done # Let's still pretend it is `configure' which instantiates (i.e., don't # use $as_me), people would be surprised to read: # /* config.h. Generated by config.status. */ configure_input='Generated from '` $as_echo "$*" | sed 's|^[^:]*/||;s|:[^:]*/|, |g' `' by configure.' if test x"$ac_file" != x-; then configure_input="$ac_file. $configure_input" { $as_echo "$as_me:${as_lineno-$LINENO}: creating $ac_file" >&5 $as_echo "$as_me: creating $ac_file" >&6;} fi # Neutralize special characters interpreted by sed in replacement strings. case $configure_input in #( *\&* | *\|* | *\\* ) ac_sed_conf_input=`$as_echo "$configure_input" | sed 's/[\\\\&|]/\\\\&/g'`;; #( *) ac_sed_conf_input=$configure_input;; esac case $ac_tag in *:-:* | *:-) cat >"$ac_tmp/stdin" \ || as_fn_error $? "could not create $ac_file" "$LINENO" 5 ;; esac ;; esac ac_dir=`$as_dirname -- "$ac_file" || $as_expr X"$ac_file" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ X"$ac_file" : 'X\(//\)[^/]' \| \ X"$ac_file" : 'X\(//\)$' \| \ X"$ac_file" : 'X\(/\)' \| . 2>/dev/null || $as_echo X"$ac_file" | sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ s//\1/ q } /^X\(\/\/\)[^/].*/{ s//\1/ q } /^X\(\/\/\)$/{ s//\1/ q } /^X\(\/\).*/{ s//\1/ q } s/.*/./; q'` as_dir="$ac_dir"; as_fn_mkdir_p ac_builddir=. case "$ac_dir" in .) ac_dir_suffix= ac_top_builddir_sub=. ac_top_build_prefix= ;; *) ac_dir_suffix=/`$as_echo "$ac_dir" | sed 's|^\.[\\/]||'` # A ".." for each directory in $ac_dir_suffix. ac_top_builddir_sub=`$as_echo "$ac_dir_suffix" | sed 's|/[^\\/]*|/..|g;s|/||'` case $ac_top_builddir_sub in "") ac_top_builddir_sub=. ac_top_build_prefix= ;; *) ac_top_build_prefix=$ac_top_builddir_sub/ ;; esac ;; esac ac_abs_top_builddir=$ac_pwd ac_abs_builddir=$ac_pwd$ac_dir_suffix # for backward compatibility: ac_top_builddir=$ac_top_build_prefix case $srcdir in .) # We are building in place. ac_srcdir=. ac_top_srcdir=$ac_top_builddir_sub ac_abs_top_srcdir=$ac_pwd ;; [\\/]* | ?:[\\/]* ) # Absolute name. ac_srcdir=$srcdir$ac_dir_suffix; ac_top_srcdir=$srcdir ac_abs_top_srcdir=$srcdir ;; *) # Relative name. ac_srcdir=$ac_top_build_prefix$srcdir$ac_dir_suffix ac_top_srcdir=$ac_top_build_prefix$srcdir ac_abs_top_srcdir=$ac_pwd/$srcdir ;; esac ac_abs_srcdir=$ac_abs_top_srcdir$ac_dir_suffix case $ac_mode in :F) # # CONFIG_FILE # case $INSTALL in [\\/$]* | ?:[\\/]* ) ac_INSTALL=$INSTALL ;; *) ac_INSTALL=$ac_top_build_prefix$INSTALL ;; esac ac_MKDIR_P=$MKDIR_P case $MKDIR_P in [\\/$]* | ?:[\\/]* ) ;; */*) ac_MKDIR_P=$ac_top_build_prefix$MKDIR_P ;; esac _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 # If the template does not know about datarootdir, expand it. # FIXME: This hack should be removed a few years after 2.60. ac_datarootdir_hack=; ac_datarootdir_seen= ac_sed_dataroot=' /datarootdir/ { p q } /@datadir@/p /@docdir@/p /@infodir@/p /@localedir@/p /@mandir@/p' case `eval "sed -n \"\$ac_sed_dataroot\" $ac_file_inputs"` in *datarootdir*) ac_datarootdir_seen=yes;; *@datadir@*|*@docdir@*|*@infodir@*|*@localedir@*|*@mandir@*) { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $ac_file_inputs seems to ignore the --datarootdir setting" >&5 $as_echo "$as_me: WARNING: $ac_file_inputs seems to ignore the --datarootdir setting" >&2;} _ACEOF cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 ac_datarootdir_hack=' s&@datadir@&$datadir&g s&@docdir@&$docdir&g s&@infodir@&$infodir&g s&@localedir@&$localedir&g s&@mandir@&$mandir&g s&\\\${datarootdir}&$datarootdir&g' ;; esac _ACEOF # Neutralize VPATH when `$srcdir' = `.'. # Shell code in configure.ac might set extrasub. # FIXME: do we really want to maintain this feature? cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 ac_sed_extra="$ac_vpsub $extrasub _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 :t /@[a-zA-Z_][a-zA-Z_0-9]*@/!b s|@configure_input@|$ac_sed_conf_input|;t t s&@top_builddir@&$ac_top_builddir_sub&;t t s&@top_build_prefix@&$ac_top_build_prefix&;t t s&@srcdir@&$ac_srcdir&;t t s&@abs_srcdir@&$ac_abs_srcdir&;t t s&@top_srcdir@&$ac_top_srcdir&;t t s&@abs_top_srcdir@&$ac_abs_top_srcdir&;t t s&@builddir@&$ac_builddir&;t t s&@abs_builddir@&$ac_abs_builddir&;t t s&@abs_top_builddir@&$ac_abs_top_builddir&;t t s&@INSTALL@&$ac_INSTALL&;t t s&@MKDIR_P@&$ac_MKDIR_P&;t t $ac_datarootdir_hack " eval sed \"\$ac_sed_extra\" "$ac_file_inputs" | $AWK -f "$ac_tmp/subs.awk" \ >$ac_tmp/out || as_fn_error $? "could not create $ac_file" "$LINENO" 5 test -z "$ac_datarootdir_hack$ac_datarootdir_seen" && { ac_out=`sed -n '/\${datarootdir}/p' "$ac_tmp/out"`; test -n "$ac_out"; } && { ac_out=`sed -n '/^[ ]*datarootdir[ ]*:*=/p' \ "$ac_tmp/out"`; test -z "$ac_out"; } && { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $ac_file contains a reference to the variable \`datarootdir' which seems to be undefined. Please make sure it is defined" >&5 $as_echo "$as_me: WARNING: $ac_file contains a reference to the variable \`datarootdir' which seems to be undefined. Please make sure it is defined" >&2;} rm -f "$ac_tmp/stdin" case $ac_file in -) cat "$ac_tmp/out" && rm -f "$ac_tmp/out";; *) rm -f "$ac_file" && mv "$ac_tmp/out" "$ac_file";; esac \ || as_fn_error $? "could not create $ac_file" "$LINENO" 5 ;; esac done # for ac_tag as_fn_exit 0 _ACEOF ac_clean_files=$ac_clean_files_save test $ac_write_fail = 0 || as_fn_error $? "write failure creating $CONFIG_STATUS" "$LINENO" 5 # configure is writing to config.log, and then calls config.status. # config.status does its own redirection, appending to config.log. # Unfortunately, on DOS this fails, as config.log is still kept open # by configure, so config.status won't be able to write to it; its # output is simply discarded. So we exec the FD to /dev/null, # effectively closing config.log, so it can be properly (re)opened and # appended to by config.status. When coming back to configure, we # need to make the FD available again. if test "$no_create" != yes; then ac_cs_success=: ac_config_status_args= test "$silent" = yes && ac_config_status_args="$ac_config_status_args --quiet" exec 5>/dev/null $SHELL $CONFIG_STATUS $ac_config_status_args || ac_cs_success=false exec 5>>config.log # Use ||, not &&, to avoid exiting from the if with $? = 1, which # would make configure fail if this is the last instruction. $ac_cs_success || as_fn_exit 1 fi if test -n "$ac_unrecognized_opts" && test "$enable_option_checking" != no; then { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: unrecognized options: $ac_unrecognized_opts" >&5 $as_echo "$as_me: WARNING: unrecognized options: $ac_unrecognized_opts" >&2;} fi cafeobj-1.6.0/acl-init.lisp0000644000000000000000000000334613373141167014333 0ustar rootwheel;;; ;;; Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. ;;; ;;; Redistribution and use in source and binary forms, with or without ;;; modification, are permitted provided that the following conditions ;;; are met: ;;; ;;; * Redistributions of source code must retain the above copyright ;;; notice, this list of conditions and the following disclaimer. ;;; ;;; * Redistributions in binary form must reproduce the above ;;; copyright notice, this list of conditions and the following ;;; disclaimer in the documentation and/or other materials ;;; provided with the distribution. ;;; ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ;;; (in-package :chaos) (defvar .cafeobj-sys-dir. nil) (defun chaos::chaos-init-fun (&rest ignore) (declare (ignore ignore)) (setq .cafeobj-sys-dir. (translate-logical-pathname #p"sys:")) (setq *cafeobj-install-dir* #+mswindows (namestring .cafeobj-sys-dir.) #-mswindows (namestring (merge-pathnames .cafeobj-sys-dir. #p".."))) (set-cafeobj-standard-library-path) ) ;;; EOF cafeobj-1.6.0/comlib/0000755000000000000000000000000013611200224013162 5ustar rootwheelcafeobj-1.6.0/comlib/list.lisp0000644000000000000000000001155513373141170015046 0ustar rootwheel;;;-*- Mode:Lisp; Syntax:Common-Lisp; Package:CHAOS -*- ;;; ;;; Copyright (c) 2000-2018, Toshimi Sawada. All rights reserved. ;;; ;;; Redistribution and use in source and binary forms, with or without ;;; modification, are permitted provided that the following conditions ;;; are met: ;;; ;;; * Redistributions of source code must retain the above copyright ;;; notice, this list of conditions and the following disclaimer. ;;; ;;; * Redistributions in binary form must reproduce the above ;;; copyright notice, this list of conditions and the following ;;; disclaimer in the documentation and/or other materials ;;; provided with the distribution. ;;; ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ;;; (in-package :CHAOS) #|============================================================================== System: Chaos Module: comlib File: list.lisp ==============================================================================|# #-:chaos-debug (declaim (optimize (speed 3) (safety 0) #-GCL (debug 0))) #+:chaos-debug (declaim (optimize (speed 1) (safety 3) #-GCL (debug 3))) ;;; A collection of utilities on List structure ;;; ************** ;;; List Structure______________________________________________________________ ;;; ************** ;;; flatten-list ;;; flattens list L, i.e., returns a single list containing the ;;; same atoms as L but with any internal lists 'dissolved'. ;;; For example, ;;; (flatten-list '(a (b c) d)) ==> (a b c d) ;;; Recursively flattens components of L, according to the following rules: ;;; - an atom is already flattened. ;;; - a list whose CAR is also a list is flattened by appending the ;;; flattened CAR to the flattened CDR (this is what dissolves internal ;;; lists). ;;; - a list whose CAR is an atom is flattened by just flattening the CDR ;;; and CONSing the original CAR onto the result. ;;; These rules were chosen with some attention to minimizing CONSing." (defun flatten-list (L) ;; (declare (optimize (speed 3) (safety 0))) (cond ((null L) '()) ((atom L) L) ((consp L) (if (consp (car L)) (append (flatten-list (car L)) (flatten-list (cdr L))) (cons (car L) (flatten-list (cdr L))))) )) ;;; firstn ;;; Returns a new list the same as List with only the first N elements. (defun firstn (list &optional (n 1)) (declare ;; (optimize (speed 3) (safety 0)) (type list list) (type fixnum n)) (cond ((> n (length list)) list) ((< n 0) nil) (t (ldiff list (nthcdr n list))))) ;;; in-order-union ;;; Append and remove duplicates. Like union, but the objects are ;;; guarranteed to stay in order. (defun in-order-union (list1 list2 &optional (test #'eql)) (remove-duplicates (append list1 list2) :from-end t :test test)) ;;; true-list-p ;;; Returns t if the term is a non-dotted list. Note that nil is a true list. (defun true-list-p (term) ;; (declare (optimize (speed 3) (safety 0))) (and (listp term) (not (cdr (last term))))) ;;; rotate-list ;;; Returns a new list rotated at numth element. ;;; (defun rotate-list (list num minusp) (declare (type fixnum num) (type list list)) (let ((len (length list)) (new-stack (copy-list list))) (declare (type fixnum len) (type list new-stack)) (when (>= (abs num) len) (return-from rotate-list nil)) (cond ((or (< num 0) (and (= num 0) minusp)) (setq num (- len (1+ (abs num)))) (print num) (setq new-stack (setq new-stack (nconc (nthcdr num new-stack) (firstn new-stack num)))) ) (t (rotatef (nth 0 new-stack) (nth num new-stack)))) new-stack)) ;;; delete-nth ;;; Returns a new list deleted the nth element ;;; (defun delete-nth (nth lst) (declare (fixnum nth) (type list lst)) (let ((len (length lst)) (new-lst nil)) (when (>= nth len) (return-from delete-nth nil)) (setq new-lst (nconc (firstn lst nth) (nthcdr (1+ nth) lst))) new-lst)) ;;; EOF cafeobj-1.6.0/comlib/macros.lisp0000644000000000000000000001622113373141170015352 0ustar rootwheel;;;-*- Mode:Lisp; Syntax:Common-Lisp; Package:CHAOS -*- ;;; ;;; Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. ;;; ;;; Redistribution and use in source and binary forms, with or without ;;; modification, are permitted provided that the following conditions ;;; are met: ;;; ;;; * Redistributions of source code must retain the above copyright ;;; notice, this list of conditions and the following disclaimer. ;;; ;;; * Redistributions in binary form must reproduce the above ;;; copyright notice, this list of conditions and the following ;;; disclaimer in the documentation and/or other materials ;;; provided with the distribution. ;;; ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ;;; (in-package :CHAOS) #|============================================================================== System: Chaos Module: comlib File: macros.lisp ==============================================================================|# #-:chaos-debug (declaim (optimize (speed 3) (safety 0) #-GCL (debug 0))) #+:chaos-debug (declaim (optimize (speed 1) (safety 3) #-GCL (debug 3))) ;;;== DESCTIPTION ============================================================== ;;; A collection of misc utility macros. ;;; ******* ;;; DECLAIM_____________________________________________________________________ ;;; ******* ;;;#-(or cltl2 GCL) ;;;(defmacro declaim (arg) `(proclaim ',arg)) ;;; **************** ;;; FAMOUS ONCE-ONLY____________________________________________________________ ;;; **************** (defmacro once-only (vars &body body) (let ((gensym-var (gensym)) (run-time-vars (gensym)) (run-time-vals (gensym)) (expand-time-val-forms ())) (dolist (var vars) (push `(if (or (symbolp ,var) (numberp ,var) (and (listp ,var) (member (car ,var) '(quote function)))) ,var (let ((,gensym-var (gensym))) (push ,gensym-var ,run-time-vars) (push ,var ,run-time-vals) ,gensym-var)) expand-time-val-forms)) `(let* (,run-time-vars ,run-time-vals (wrapped-body (let ,(mapcar #'list vars (reverse expand-time-val-forms)) ,@body))) `(let ,(mapcar #'list (reverse ,run-time-vars) (reverse ,run-time-vals)) ,wrapped-body)))) ;;; ********************************* ;;; Specialized MEMBER/ASSOC/POSITION___________________________________________ ;;; ********************************* #-:ccl (defmacro memq (item list) `(member ,item ,list :test #'eq)) #-:ccl (defmacro assq (item list) `(assoc ,item ,list :test #'eq)) (defmacro posq (item list) `(position ,item ,list :test #'eq)) (defmacro memeq (item list) `(member ,item ,list :test #'equal)) (defmacro asseq (item list) `(assoc ,item ,list :test #'equal)) (defmacro poseq (item list) `(position ,item ,list :test #'equal)) ;;; ********** ;;; CASE-EQUAL__________________________________________________________________ ;;; ********** ;;; same as normal `case' test by equal instead of eql. (defmacro case-equal (keyform &rest clauses &aux (form nil) (key (gensym))) (dolist (clause (reverse clauses) `(let ((,key ,keyform)) ,form)) #+GCL (declare (object clause)) (cond ((or (eq (car clause) 't) (eq (car clause) 'otherwise)) (setq form `(progn ,@(cdr clause)))) ((consp (car clause)) (setq form `(if (member ,key ',(car clause) :test #'equal) (progn ,@(cdr clause)) ,form))) ((car clause) (setq form `(if (equal ,key ',(car clause)) (progn ,@(cdr clause)) ,form))))) ) ;;; ************** ;;; DOTIMES-FIXNUM______________________________________________________________ ;;; ************** ;;; FROM OBJ3 implementation by Tim.Winkler of SRI. ;;; I don't know how this could be efficient in general, but for GCL(KCL..) this ;;; works well. ;;; (defmacro dotimes-fixnum (&rest body) (let ((var (car (car body))) (lim (cadr (car body))) (res (cddr (car body))) (acts (cdr body)) (limvar (gensym)) (lab (gensym))) ` (block () (let* ((,limvar ,lim) (,var 0)) (declare (type fixnum ,var ,limvar)) (tagbody ,lab (if (>= ,var ,limvar) (return (progn ,@res))) (tagbody ,@acts) (setf (the fixnum ,var) (the fixnum (1+ (the fixnum ,var)))) (go ,lab))))) ) ;;; **************** ;;; Syntactic Sugars____________________________________________________________ ;;; **************** (defmacro msetq (vars value) `(multiple-value-setq ,vars ,value)) (defmacro mlet (vars value &body body) `(multiple-value-bind ,vars ,value ,@body)) ;;; let-if ;;; Binds let arguments only if condition is non-nil, and evaluates body ;;; in any case. (defmacro let-if (condition bindings &body body) `(if ,condition (let ,bindings ,@body) (progn ,@(if (eq (caar body) 'declare) (cdr body) body)))) ;;; when-bind ;;; Binds the symbol to predicate and executes body only if predicate ;;; is non-nil." (defmacro when-bind ((symbol predicate) &body body) `(let ((,symbol ,predicate)) (when ,symbol ,@body))) ;;; while ;;; Keeps invoking the body while the test is true; test is tested before each ;;; loop. ;;;; #-(or :allegro-v6.0 :allegro-v6.1 :allegro-v6.2 :allegro-v7.0 :allegro-v8.0) #-(or :allegro) (defmacro while (test &body body) (let ((end-test (gensym)) (loop (gensym))) `(block nil (tagbody (go ,end-test) ,loop ,@body ,end-test (when ,test (go ,loop)) (return))))) ;;; while-not ;;; Keeps invoking the body while the test is not true; test is tested before ;;; each loop. (defmacro while-not (test &body body) (let ((end-test (gensym)) (loop (gensym))) `(block nil (tagbody (go ,end-test) ,loop ,@body ,end-test (unless ,test (go ,loop)) (return))))) ;;; def-synonym sym1 sym2 ;;; (defmacro def-synonym (sym1 sym2) `(setf (symbol-function ',sym1) (symbol-function ',sym2))) ;;; ;;; #-:excl #-(or :excl ccl) (defmacro fixnump (num) `(typep ,num 'fixnum)) ;;; EOF cafeobj-1.6.0/comlib/string.lisp0000644000000000000000000000611713373141170015377 0ustar rootwheel;;;-*- Mode:Lisp; Syntax:Common-Lisp; Package:CHAOS -*- ;;; ;;; Copyright (c) 2000-2018, Toshimi Sawada. All rights reserved. ;;; ;;; Redistribution and use in source and binary forms, with or without ;;; modification, are permitted provided that the following conditions ;;; are met: ;;; ;;; * Redistributions of source code must retain the above copyright ;;; notice, this list of conditions and the following disclaimer. ;;; ;;; * Redistributions in binary form must reproduce the above ;;; copyright notice, this list of conditions and the following ;;; disclaimer in the documentation and/or other materials ;;; provided with the distribution. ;;; ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ;;; (in-package :CHAOS) #|============================================================================== System: Chaos Module: comlib File: string.lisp ==============================================================================|# #-:chaos-debug (declaim (optimize (speed 3) (safety 0) #-GCL (debug 0))) #+:chaos-debug (declaim (optimize (speed 1) (safety 3) #-GCL (debug 3))) ;;; A collection of string utilities. ;;; ******* ;;; Strings_____________________________________________________________________ ;;; ******* ;;; parse-with-delimiter : String -> List[String] ;;; Breaks LINE into a list of strings, using DELIM as a breaking point. (defun parse-with-delimiter (line &optional (delim #\newline)) (declare (type simple-string line) (type character delim)) ;; what about #\return instead of #\newline? (let ((pos (position delim line))) (cond (pos (cons (subseq line 0 pos) (parse-with-delimiter (subseq line (1+ pos)) delim))) (t (list line))))) (defun parse-with-delimiter2 (line &optional (delim #\newline)) (declare (type simple-string line) (type character delim)) ;; what about #\return instead of #\newline? (let ((pos (position delim line))) (cond (pos (cons (subseq line 0 pos) (cons (string delim) (parse-with-delimiter2 (subseq line (1+ pos)) delim)))) (t (list line))))) ;;; numeric-char-p ;;; (defmacro numeric-char-p (char) `(let ((cc (char-code ,char))) (and (>= cc (char-code #\0)) (<= cc (char-code #\9))))) ;;; EOF cafeobj-1.6.0/comlib/reader.lisp0000644000000000000000000012713713373141170015341 0ustar rootwheel;;;-*- Mode:LISP; Package:CHAOS; Base:10; Syntax:Common-lisp -*- ;;; ;;; Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. ;;; ;;; Redistribution and use in source and binary forms, with or without ;;; modification, are permitted provided that the following conditions ;;; are met: ;;; ;;; * Redistributions of source code must retain the above copyright ;;; notice, this list of conditions and the following disclaimer. ;;; ;;; * Redistributions in binary form must reproduce the above ;;; copyright notice, this list of conditions and the following ;;; disclaimer in the documentation and/or other materials ;;; provided with the distribution. ;;; ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ;;; (in-package :chaos) #|============================================================================== System:Chaos Module:comlib File: reader.lisp ==============================================================================|# #-:chaos-debug (declaim (optimize (speed 3) (safety 0) #-GCL (debug 0))) #+:chaos-debug (declaim (optimize (speed 1) (safety 3) #-GCL (debug 3))) ;;; SCHEMA BASED Genral Reader. ;;; ;;; BASED ON OBJ3 READER ROUTINES. ;;; ;;;; Copyright 1988,1991 SRI International. ;;; ;;; SCHEMA ;;;============================================================================= ;;; Schemas match patterns ;;; choices must be determined by first symbol of context ;;; e.g. if an optional element doesn't occur what occurs first ;;; must be an explicit symbol in the schema ;;; ;;;--- BUILT-IN PATTERNS ------------------------------------------------------- ;;; To parse the OBJ3 syntax more easier, these definitions are just the same ;;; as of OBJ3 schema. ;;; ;;; (:optional PAT) - optional occurrence of pattern ;;; (:if-present PAT) - optional occurrence of pattern ;;; *NOTE* ;;; :optional - omit if next token matches following context ;;; :if-present - assume if first matches ;;; (:one-of PAT1 PAT2 ...) - one of patterns determined by first of patterns ;;; (:one-of-default PAT1 PAT2 ...) ... with a default to PAT1 ;;; (:seq-of PAT) - some number of repetitions of PAT ;;; (:many-of PAT1 PAT2 ...) - roughly (:seq-of (:one-of PAT1 ...)) ;;; :symbol - a symbol ;;; :symbols - (:seq-of :symbol) ;;; :int - an integer ;;; :term - sequence of tokens up to terminator which follows ;;; :sort - a sort name (possibly qualified) ;;; :sorts - (:seq-of :sort) ;;; :comment - string of characters to end of current line ;;; :commentlong - variation of above with provision for long comments ;;; (:+ a b c) - any of several symbols ;;; (:! SCHEMA-NAME) - match the named schema ;;; (:call LISP-EXPR) - escape to Lisp ;;; (:rdr ("char1" "char2"...) PAT) - make characters be single-char and ;;; then match pattern, returning status of characters to previous when done ;;; :modexp - read a term with balanced (/) [/] view/endv ;;; particular tricky case: view A to B[view C to D is ... endv] { ... } ;;; :chaos-item - read a (possibly parenthesized) item ;;; otherwise: symbol - matches symbol if it is not defined as the schema name. ;;; (:pred PREDICATE) - matches a token satisfying predicate ;;; :append PAT - analogous to ,@; incorporate structure from PAT ;;; into result "removing one set of parentheses" ;;; :upto - specify ending context for repeated form ;;; :args - for command arguments. read rest of line till \newline. ;;; ;;;--- DEFINING NEW SCHEMA & Its Reader .... (defvar *reader-special-schema-patterns* nil) ;;; READER schema-pattern-name schemas ;;; read input from *standard-input*, parse according to schemas ;;; (defun reader (name schms) (declare (type symbol name) (type list schms) (values t)) (let ((*reader-schema-env* schms)) (!lex-read-init) (read-named name *reader-void* nil) )) ;;; ;;; ERROR HANDLERS ;;; (defun abort-general-reader (msg) (with-output-chaos-error ('reader-error) (princ msg) (when *chaos-input-source* (print-next) (princ "file: ") (princ (namestring *chaos-input-source*))) (when (and *reader-current-schema* (general-read-is-simple-schema *reader-current-schema*)) (print-next) (princ "expecting: ") (let ((*print-indent-contin* t)) ;; (break) ;; (general-read-print-schema *reader-current-schema*) (general-read-display-schema *reader-current-schema* :short))) (when *reader-starting-position* (print-next) (princ "starting character position was: ") (princ *reader-starting-position*)))) (defun general-read-eof-error () (declare (values t)) (abort-general-reader "Unexpected EOF.")) (defun general-read-abort () (declare (values t)) (abort-general-reader "Cancel reading input...")) ;;; STRING-MATCH string1 string2 ;;; basic string matching function. ;;; (defun string-match (x y) (declare (values (or null t))) (cond ((stringp x) (string= (the simple-string x) (if (stringp y) (the simple-string y) (the simple-string (string-downcase (string y)))))) ((characterp x) (eql (the character x) (the character y))) (t (eq x y)))) ;;; GENERAL-READ-STRING-MATCHES : token pattern -> Bool ;;; used to match tokens against "patterns" which should be ;;; either a symbol, string, or of one of the forms ;;; (:+ a b c ...) or (:pred PRED) ;;; (defun general-read-string-matches (x y) (declare (values (or null t))) (and (atom x) (if (atom y) (string-match x y) (or (and (eq ':pred (car y)) (funcall (cadr y) x)) (if (eq ':+ (car y)) (member x (cdr y) :test #'string-match) (member x y :test #'string-match)))))) ;;; GENERAL-READ-NUMBERP token -> Bool ;;; is a token an integer? ;;; (defun general-read-numberp (str) (declare (type simple-string str) (values (or null t))) (let ((p 0) (len (length str))) (declare (type fixnum p len)) (when (member (char str p) '(#\+ #\-)) (incf p) (when (= 1 len) (return-from general-read-numberp nil))) (loop (when (= len p) (return t)) (when (not (digit-char-p (char str p))) (return nil)) (incf p) ))) ;;; GENERAL-READ ;;; the workhorse general read routine ;;; it dispatches to routines to handle the various cases ;;; op general-read : {*standard-input*} schema context -> ;;; {*standard-input*} parse-tree (defun general-read (schema context &optional (allow-other nil)) (declare (type list schema context) (type (or null t) allow-other) (values t)) ;; (let ((*reader-current-schema* schema) (*reader-current-context* context) (*reader-starting-position* (if (at-top-level) nil (file-position *standard-input*))) (result nil)) (setq result (catch :aborting-read (cond ((null schema) nil) (t (let ((elt (car schema)) (rest (cdr schema))) (let ((restcontext (if rest rest context))) (cond ((symbolp elt) (case elt (:unread (read-continue (unread-token) rest context)) (:optional (read-optional rest context)) (:if-present (read-if-present rest context)) (:one-of (read-one-of rest context)) (:one-of-default (read-one-of-default rest context)) (:many-of ;like one-of but with repetitions (read-many-of rest context)) (:seq-of (read-seq-of rest context)) (:symbol (read-continue (!read-sym) rest context)) (:symbols (read-continue (read-seq-of '(:symbol) restcontext) rest context)) (:int (let ((val (!read-sym))) (cond ((general-read-numberp val) (read-continue val rest context)) (t (with-output-chaos-error ('reader-error) (princ "was expecting an integer not ") (princ val) (print-next) (general-read-show-context) (clear-input) ))))) (:top-term (read-continue (read-term-at-top restcontext) rest context)) (:term (read-continue (read-term restcontext) rest context)) ;; (:term-to (read-continue (read-term-to restcontext) ;; rest context)) (:top-opname (read-continue (read-opname-at-top restcontext) rest context)) (:opname (read-continue (read-opname restcontext) rest context)) (:sort (read-continue (read-sort restcontext) rest context)) (:sorts (read-continue (read-sorts restcontext) rest context)) (:chars (read-continue (read-chars restcontext) rest context)) (:optattr (read-continue (read-opattr restcontext) rest context)) (:comment (read-continue (read-comment-line) rest context)) (:commentlong (read-continue (general-read-commentlong) rest context)) (:+ (read-any-one rest)) (:! ; use named description (read-named (car rest) context)) (:call (eval (car rest))) (:append (let* ((rr (cdr rest)) (rc (if rr rr context))) (read-continue-append (general-read (car rest) rc) rr context))) (:rdr (let ((cur (!set-single-reader (car rest)))) (prog1 (general-read (cdr rest) context) (!set-reader cur)))) (:modexp (read-continue (read-module-exp (car restcontext)) rest context)) (:super (read-continue (read-super-exp (car restcontext)) rest context)) (:chaos-item (!read-discard) (let ((val (lex-read))) (let ((a (if (null (cdr val)) (car val) val))) (read-continue a rest context)))) (:args (read-args rest context)) (otherwise (if allow-other ;; we read input as a seq-of term (general-read '(:seq-of :term) '(void)) (progn (!read-in) (cond ((string-match *reader-input* elt) (let ((inp *reader-input*)) (!read-discard) (read-continue inp rest context))) (t (with-output-chaos-error ('reader-error) (princ "was expecting the symbol ") (princ "`") (princ elt) (if (or (equal *reader-input* *lex-eof*) (equal *reader-input* control-d-string)) (format t "', premature end of input.") (format t "' not `~a'." *reader-input*)) (print-next) (general-read-show-context) (clear-input) )))))) )) ((member (car elt) '(:! :rdr)) (let ((val (general-read elt restcontext))) (cond ((eq *reader-void* val) (general-read rest context)) (t (append val (general-read rest context)))))) ((eq :upto (car elt)) (append (general-read (cddr elt) (list (cadr elt))) (general-read rest context))) (t (read-continue (general-read elt restcontext) rest context) )))))) )) (if (eq :aborting-read result) (general-read-abort) result) )) ;;; PATTERN HANDLERS ;;; ;;; READ-NAMED name context ;;; (defun read-named (name context &optional allow-other) (declare (type symbol name) (type list context) (type (or null t) allow-other)) (let ((val (assoc name *reader-schema-env* :test #'eq))) (cond (val (general-read (cadr val) context allow-other)) (t (error "Undefined name in general reader ~a" name))))) ;;; READ-OPTIONAL ;;; (defun read-optional (s c) (!read-in) (when (at-eof-or-control-d) (general-read-eof-error)) (cond ((general-read-string-matches *reader-input* (car c)) *reader-void*) (t (general-read s c))) ) ;;; READ-IF-PRESENT ;;; (defun read-if-present (s c) (declare (type list s c) (values t)) (!read-in) (when (at-eof-or-control-d) (general-read-eof-error)) (cond ((general-read-string-matches *reader-input* (car s)) (general-read s c)) (t *reader-void*))) ;;; READ-ONE-OF ;;; (defun read-one-of (s c) (declare (type list s c) (values t)) (let ((inp (!read-sym))) (when (and c (at-eof-or-control-d)) (general-read-eof-error)) (let ((val (assoc inp s :test #'general-read-string-matches))) (cond (val (cons inp (general-read (cdr val) c))) ((and (consp inp) (eq (caar inp) '|String|)) (read-one-of s c)) ((and (eq *lex-eof* inp) (assoc 'eof s)) (cons 'eof (general-read (cdr (assoc 'eof s)) c))) ((eq *lex-eof* inp) (general-read-eof-error)) (*allow-general-term-input* (unread-token) (read-term '(|.|))) (t (let ((top-level (assoc 'eof s))) (when (equal inp ".") (chaos-error 'reader-error)) (with-output-chaos-error ('reader-error) (princ "expecting one of followings:") (print-next) (let ((*print-indent-contin* t)) (general-read-print-schema (mapcar #'car s) :short)) (print-next) (princ "* NOT: ") (princ inp) (general-read-show-context) (when top-level (setq *chaos-print-errors* nil)) (clear-input) ))) )))) ;;; READ-ONE-OF-DEFAULT ;;; first alternative is a default ;;; (defun read-one-of-default (s c) (declare (type list s c) (values t)) (!read-in) (let ((val (assoc *reader-input* (cdr s) :test #'general-read-string-matches))) (cond (val (let ((inp *reader-input*)) (!read-discard) (cons inp (general-read (cdr val) c)))) ((and (reader-is-at-eof) (assoc 'eof s)) (cons 'eof (general-read (cdr (assoc 'eof s)) c))) ((reader-is-at-eof) ; !!! (general-read-eof-error)) (t (general-read (car s) c))))) ;;; READ-MANY-OF ;;; (defun read-many-of (s c) (declare (type list s c) (values t)) (let ((res nil) (close (car c))) (loop (!read-in) (when (at-eof-or-control-d) (general-read-eof-error)) (when (general-read-string-matches *reader-input* close) (return (if (null res) *reader-void* (nreverse res)))) (if (and (consp *reader-input*) (eq (caar *reader-input*) '|String|)) (setq *reader-input* *reader-void*) (setq res (cons (read-one-of s c) res)))))) ;;; READ-SEQ-OF ;;; (defun read-seq-of (s c) (declare (type list s c) (values t)) (cond ((equal '(:term) s) (read-seq-of-term c)) ((equal '(:opname) s) (read-seq-of-opname c)) ((equal '(:top-term) s) (read-seq-of-term-at-top c)) ((equal '(:top-opname) s) (read-seq-of-opname-at-top c)) (t (let ((res nil) (close (car c))) (loop (!read-in) (when (at-eof-or-control-d) (general-read-eof-error)) (when (general-read-string-matches *reader-input* close) (return (if (null res) *reader-void* res))) (setq res (append res (general-read s c))) ))))) ;;; READ-ANY-ONE ;;; (defun read-any-one (s) (declare (type list s) (values t)) (!read-in) (cond ((member *reader-input* s :test #'string-match) (!read-sym)) ((at-eof-or-control-d) (general-read-eof-error)) (t (with-output-chaos-error ('reader-error) (princ "expecting one of") (print-next) (let ((*print-indent-contin* t)) (general-read-print-schema s :short)) (print-next) (format t "NOT ") (princ *reader-input*) (general-read-show-context) (clear-input) )))) ;;; READ-CONTINUE : {*standard-input*} value schema context -> ;;; {*standard-input*} parse-tree ;;; continues the matching process ;;; the value is returned as the first component of the resulting tree ;;; (defun read-continue (v s c) (declare (type t v) (type list s c) (values t)) (cond ((eq *reader-void* v) (general-read s c)) ((equal v control-d-string) (general-read-eof-error)) (t (cons v (general-read s c))))) ;;; READ-CONTINUE-APPEND : {*standard-input*} value schema context -> ;;; {*standard-input*} parse-tree ;;; continues the matching process; appending the value given ;;; the value is returned as the first component of the resulting tree ;;; (defun read-continue-append (v s c) (declare (type t v) (type list s c) (values t)) (cond ((eq *reader-void* v) (general-read s c)) ((equal v control-d-string) (general-read-eof-error)) (t (append v (general-read s c))))) (defun general-read-show-context () (declare (values t)) (when (and *chaos-verbose* *reader-current-context* (not (eq *reader-void* *reader-current-context*))) (terpri) (princ "-- Expecting context is: ") (print-simple-princ-open *reader-current-context*) (unless *chaos-input-source* (terpri))) (when *chaos-input-source* ; nil means may be from terminal (terpri) (princ "-- file: ") (princ (namestring *chaos-input-source*)) (when (file-position *standard-input*) (princ " at character position: ") (prin1 (file-position *standard-input*))) (terpri) (when (and *reader-current-schema* (general-read-is-simple-schema *reader-current-schema*)) (princ " expecting: ") (general-read-print-schema-1 *reader-current-schema* :short) (terpri)) (when (and *reader-starting-position* (not (equal *reader-starting-position* (file-position *standard-input*)))) (princ " starting character position was: ") (prin1 *reader-starting-position*) (terpri)) (princ "-- Context:") (unless (eq *reader-void* *reader-input*) (princ *reader-input*)) (if (reader-is-at-eof) (princ " ... at end of file") (dotimes (i 20) (print-check) (princ #\space) (let ((val (read-sym))) (when (at-eof) (princ " [end of file]") (return)) (princ val) (when (equal "eof" val) (return))))) (terpri))) #|| (defun general-read-is-simple-schema (sch) (declare (type t sch) (values (or null t))) (or (atom sch) (and (consp sch) (every #'atom sch))) ) ||# (defun general-read-is-simple-schema (sch) (declare (ignore sch)) t) ;;; modify print to certain depth and length transliterating notations ;;; (defun general-read-display-schema (sch &optional (short nil)) (declare (type list sch) (values t)) (let ((limit (if short 10 most-positive-fixnum)) (count 0) (*print-level* (if short 2 nil))) (declare (type fixnum limit count)) (if (> (length sch) 1) (dolist (i (firstn sch 3)) (when (>= count limit) (princ " ...") (return)) (incf count) (print-check) (princ #\space) (prin1 i)) (dolist (i sch) (print-check) (princ #\space) (prin1 i))))) (defun general-read-print-schema-1 (s &optional (short nil)) (declare (type t s) (values t)) (if (atom s) (princ s) (let ((flag nil)) (declare (ignore flag)) (general-read-print-schema (car s) short)))) (defun general-read-print-schema (s &optional (short nil)) (declare (type t s) (values t)) (let ((limit (if short 10 most-positive-fixnum)) (count 0)) (declare (type fixnum limit count)) (if (atom s) (princ s) (let ((flag nil)) (dolist (i s) (when (>= count limit) (princ " ...") (return)) (incf count) (if (< *print-line-limit* (filecol *standard-output*)) (progn (print-next) (when *print-indent-contin* (princ " ") (setq flag t))) (if flag (princ " ") (setq flag t))) (if (atom i) (unless (eql control-d i) (prin1 i)) (if (eq ':+ (car i)) (dolist (e (cdr i)) (if (< *print-line-limit* (filecol *standard-output*)) (progn (print-next) (when *print-indent-contin* (princ " ") (setq flag t))) (if flag (princ " ") (setq flag t))) (prin1 e)) (prin1 i)))))))) (defun read-comment-line () (let ((ch (peek-char nil *standard-input* nil nil))) (unless ch (return-from read-comment-line " ")) (if (eq .reader-ch. 'return) (return-from read-comment-line (string #\linefeed)) (if (member ch '(#\linefeed #\page #\return #\newline)) (progn (read-char) (return-from read-comment-line (string #\linefeed))) (read-line))))) ;;; an ignored comment (value is "") ;;; has provision for long case: ** ( ) ;;; (defun general-read-commentlong () (declare (values simple-string)) (let (ch) (unless (eql '\( .reader-ch.) (loop (setq ch (read-char *standard-input* nil *lex-eof*)) (unless (or (eql #\Space ch) (eql #\Tab ch)) (return))) (setq .reader-ch. (if (eq ch *lex-eof*) *lex-eof* (let ((val (reader-get-syntax ch))) (if val val ch))))) (if (eq '\( .reader-ch.) (lex-read) (unless (or (eql #\Newline ch) (eql #\Return ch)) (read-line)) )) (setq .reader-ch. 'space) "" ) ;;;============================================================================= ;;; SPECIAL READERS ;;; readers specific to external representations of Chaos expressions. ;;;============================================================================= ;;; READ-TERM-FROM-STRING : string -> List(Token) ;;; ;;; (declaim (function read-term-from-string (string) list)) (declaim (inline read-term-from-string)) ; (eval-when (:execute :compile-toplevel :load-toplevel) ; (defparameter .term-delimiting-chars. ; '("[" "]" "{" "}" ";" "@" "%" "~" ))) (eval-when (:execute :compile-toplevel :load-toplevel) (defparameter .term-delimiting-chars. '("[" "]" "{" "}"))) (defun !set-term-delim-chars () (!set-single-reader .term-delimiting-chars.)) (defun read-term-from-string (string) (declare (type simple-string string)) (with-input-from-string (*standard-input* string) (let ((cur (!set-term-delim-chars))) (let ((res nil) (inp nil) (inv nil)) (loop (setq inp (lex-read)) (when #+:CCL-3 (equal *lex-eof* inp) #-:CCL-3 (eq *lex-eof* inp) (setq *reader-input* inv) (return)) (cond ((= 1 (length (the list inp))) (setq inv (car inp))) (t (setq inv *reader-void*))) (setq res (append res inp)) ) (!set-reader cur) (clear-input) (setq *reader-input* *reader-void*) res )))) (defun read-seq-of-term-from-string (string) (declare (type simple-string string) (values list)) (with-input-from-string (*standard-input* string) (let ((cur (!set-term-delim-chars))) (let ((res nil)) (block exit ;; read in one token. (if (eq *reader-input* *reader-void*) (setq *reader-input* (lex-read)) (when (equal "(" *reader-input*) (setq *reader-input* (lex-read-rest-of-list)))) (when (reader-is-at-eof) (return-from exit)) (when (atom *reader-input*) (setq *reader-input* (list *reader-input*))) (loop (setq res (append res *reader-input*)) (setq *reader-input* (lex-read)) (when (reader-is-at-eof) (return-from exit))) ) ;; restore read table. (!set-reader cur) (clear-input) (setq *reader-input* *reader-void*) res )))) ;;; READ-TERM-AT-TOP ;;; (defun read-term-at-top (&rest ignore) (declare (ignore ignore)) (let ((lines (read-lines))) (if (eq lines *lex-eof*) *lex-eof* (read-term-from-string lines)))) (defun read-seq-of-term-at-top (&rest ignore) (declare (ignore ignore)) (let ((lines (read-lines))) (if #+:MCL (equal lines *lex-eof*) #-:MCL (eq lines *lex-eof*) *lex-eof* (read-seq-of-term-from-string lines)))) ;;; READ-TERM ;;; (defun read-term (context) (declare (type list context) (values list)) (let ((cur (!set-term-delim-chars))) (let ((res nil) inp inv) (loop (setq inp (lex-read)) (when #-:ccl-3(eq *lex-eof* inp) #+:ccl-3(equal *lex-eof* inp) (return-from read-term *lex-eof*)) (cond ((= 1 (length (the list inp))) (setq inv (car (the list inp)))) (t (setq inv *reader-void*))) (when (lex-string-match inv (car context)) (setq *reader-input* inv) (return)) (setq res (append res inp)) ) (!set-reader cur) res ))) ;;; READ-SEQ-OF-TERM ;;; (defun read-seq-of-term (context) (declare (type list context) (values list)) (let ((cur (!set-term-delim-chars))) (let ((res nil)) ;; read in one token. (if (eq *reader-input* *reader-void*) (setq *reader-input* (lex-read)) (when (equal "(" *reader-input*) (setq *reader-input* (lex-read-rest-of-list)))) (when (at-eof-or-control-d) ; was reader-is-at-eof (return-from read-seq-of-term *lex-eof*)) (when (atom *reader-input*) (setq *reader-input* (list *reader-input*))) (loop (when (and (null (cdr *reader-input*)) (stringp (car *reader-input*)) (lex-string-match (car *reader-input*) (car context))) (setq *reader-input* (car *reader-input*)) (return)) (setq res (append res *reader-input*)) (setq *reader-input* (lex-read)) (when (at-eof-or-control-d) ; was reader-is-at-eof (return-from read-seq-of-term *lex-eof*)) ) ;; restore read table. (!set-reader cur) res ))) ;;; READ-ARGS ;;; (defun read-args (&rest context) (declare (ignore context)) (let ((*live-newline* t)) (let ((res nil) (inv nil) inp) (loop (setq inp (lex-read)) (when #-:ccl-3(eq *lex-eof* inp) #+:ccl-3(equal *lex-eof* inp) (return-from read-args *lex-eof*)) (cond ((= 1 (length (the list inp))) (setq inv (car (the list inp)))) (t (setq inv *reader-void*))) (when (and (consp inv) (eq (car inv) .String-token.)) (setq res (append res inp)) (setq *reader-input* *reader-void*) (return)) (when (lex-string-match inv 'return) (setq *reader-input* *reader-void*) (return)) (setq res (append res inp))) res))) ;;; READ-SEQ-OF-OPNAME ;;; ; (defparameter .op-name-delimiting-chars. ; '("[" "]" "{" "}" "_" ";" "@" "%" "~")) (defparameter .op-name-delimiting-chars. '("[" "]" "{" "}" "_")) (defun read-seq-of-opname (context) (declare (type list context) (values list)) (let ((cur (!set-single-reader .op-name-delimiting-chars.))) (let ((res nil)) (if (eq *reader-input* *reader-void*) (setq *reader-input* (lex-read)) (when (equal "(" *reader-input*) (setq *reader-input* (lex-read-rest-of-list)))) (when ; (reader-is-at-eof) (at-eof-or-control-d) (return-from read-seq-of-opname *lex-eof*)) (when (atom *reader-input*) (setq *reader-input* (list *reader-input*))) (loop (when (and (null (cdr *reader-input*)) (stringp (car *reader-input*)) (lex-string-match (car *reader-input*) (car context))) (setq *reader-input* (car *reader-input*)) (return)) (setq res (append res *reader-input*)) (setq *reader-input* (lex-read)) (when (at-eof-or-control-d) ; (reader-is-at-eof) (return-from read-seq-of-opname *lex-eof*)) ) (!set-reader cur) res ))) ;;; READ-OPNAME context ;;; (defun read-opname (context) (declare (type list context) (values list)) (let ((cur (!set-single-reader .op-name-delimiting-chars.))) (let ((res nil) inp inv) (loop (setq inp (lex-read)) (when (eq *lex-eof* inp) (return-from read-opname *lex-eof*)) (cond ((= 1 (length (the list inp))) (setq inv (car inp))) (t (setq inv *reader-void*))) (when (lex-string-match inv (car context)) (setq *reader-input* inv) (return)) (setq res (append res inp)) ) (!set-reader cur) res ))) (defun read-opname-at-top (&rest ignore) (declare (ignore ignore)) (let ((line (read-lines))) (if (eq line *lex-eof*) *lex-eof* (read-opname-from-string line)))) (defun read-seq-of-opname-at-top (&rest ignore) (declare (ignore ignore)) (let ((line (read-lines))) (if (eq line *lex-eof*) *lex-eof* (read-seq-of-opname-from-string line)))) (defun read-opname-from-string (string) (declare (type simple-string string)) (with-input-from-string (*standard-input* string) (let ((cur (!set-single-reader .op-name-delimiting-chars.))) (let ((res nil) (inp nil) (inv nil)) (loop (setq inp (lex-read)) (when (eq *lex-eof* inp) (setq *reader-input* inv) (return)) (cond ((= 1 (length (the list inp))) (setq inv (car inp))) (t (setq inv *reader-void*))) (setq res (append res inp)) ) (!set-reader cur) (clear-input) (setq *reader-input* *reader-void*) res )))) (defun read-seq-of-opname-from-string (string) (declare (type simple-string string) (values list)) (with-input-from-string (*standard-input* string) (let ((cur (!set-single-reader .op-name-delimiting-chars.))) (let ((res nil)) (block exit ;; read in one token. (if (eq *reader-input* *reader-void*) (setq *reader-input* (lex-read)) (when (equal "(" *reader-input*) (setq *reader-input* (lex-read-rest-of-list)))) (when (reader-is-at-eof) (return-from exit)) (when (atom *reader-input*) (setq *reader-input* (list *reader-input*))) (loop (setq res (append res *reader-input*)) (setq *reader-input* (lex-read)) (when (reader-is-at-eof) (return-from exit))) ) ;; restore read table. (!set-reader cur) (clear-input) (setq *reader-input* *reader-void*) res )))) ;;; READ-SORT ;;; (defun read-sort (c) (declare (ignore c)) (let ((old-syntax (reader-get-syntax #\!))) (unwind-protect (let ((inp nil)) (!set-syntax #\! nil) (setq inp (!read-sym)) (cond ((and (stringp inp) (eql #\. (char (the simple-string inp) (1- (length (the simple-string inp)))))) (loop (unless (eq 'space .reader-ch.) (return)) ;a bit ugly (setq .reader-ch. (reader-get-char *standard-input*))) (when (eq .reader-ch. *lex-eof*) (return-from read-sort *lex-eof*)) (if (equal '\( .reader-ch.) (let ((rest (lex-read))) (if (eq rest *lex-eof*) *lex-eof* (list* inp (lex-read)))) inp)) (t inp) )) (!set-syntax #\! old-syntax)))) ;;; READ-SORTS ;;; (defun read-sorts (context) (let ((res nil) (old-syntax (reader-get-syntax #\!))) (unwind-protect (progn (!set-syntax #\! nil) (loop (!read-in) (when (at-eof-or-control-d) (return-from read-sorts *lex-eof*)) (when (lex-string-match *reader-input* (car context)) (return (nreverse res))) (push (read-sort context) res))) (!set-syntax #\! old-syntax)))) ;;; READ-CHARS ;;; (defun read-chars (context) (let ((res nil)) (loop (!read-in) (when (at-eof-or-control-d) (return-from read-chars *lex-eof*)) (when (lex-string-match *reader-input* (car context)) (return-from read-chars (nreverse res))) (let ((c (!read-sym))) ;;(format t "~%- read-chars: sym=~s, res=~s" c res) (if (consp c) (push (car c) res) (push c res)))))) ;;; SPECIAL READERS NOT Spported by Chaos General Reader ;;; (defun read-opattr (c) (declare (type list c) (values list)) (!read-in) (when (at-eof-or-control-d) (return-from read-opattr *lex-eof*)) (if (lex-string-match *reader-input* #\[) ;; () ;; (progn (reader-suppress-ch c) nil))) ;;; (defun read-super-exp (c) (declare (type list c) (values list)) (let ((cur (!set-single-reader '(#\( #\))))) (prog1 (read-superexp c) (!set-reader cur)))) (defun read-superexp (c) (declare (type list c) (values list)) (let ((res nil)) (loop (!read-in) (when (at-eof-or-control-d) (general-read-eof-error)) (when (general-read-string-matches *reader-input* c) (return res)) (setq res (nconc res (read-superexpr-delimited)))) res)) (defun read-superexpr-delimited () (declare (values list)) (!read-in) (when (at-eof-or-control-d) (general-read-eof-error)) (let ((pr (assoc *reader-input* '(("(" ")")) :test #'general-read-string-matches))) (cond ((null pr) (prog1 (cons *reader-input* nil) (!read-discard))) (t (let ((sym *reader-input*)) (!read-discard) (let ((lst (read-superexp (cdr pr)))) (prog1 (cons sym (append lst (cons *reader-input* nil))) (!read-discard))))) ))) ;;; ;;; Module Expression Reader ;;; ;;; *modexp-parse-input* -- binds module expression input (list of tokens). ;;; (defvar *modexp-parse-input* 'undef) ;;; MODEXP-SKIP : {*modexp-parse-input*} -> {*modexp-parse-input*} ;;; skip input one. ;;; (defmacro modexp-skip () `(setq *modexp-parse-input* (cdr *modexp-parse-input*))) ;;;************ ;;; Some utils__________________________________________________________________ ;;;************ ;;; SCAN-PRENTHESIZED-UNIT : tokens -> LIST[tokens], signal 'unbalanced ;;; ;;; (scan-parenthesized-unit '( "(" "aho" "(" "baka" "tako" ")" "manuke" ")" "baba")) ;;; ==> ("aho" "(" "baka" "tako" ")" "manuke") ;;; ("baba") ;;; (scan-parenthesized-unit '( "(" "aho" "(" "baka" "tako" ")" "manuke" "baba")) ;;; ==> UNBALANCED ;;; ("(" "aho" "(" "baka" "tako" ")" "manuke" "baba") ;;; (defun scan-parenthesized-unit (tokens) (declare (type list tokens) (values (or symbol list) list)) (if (equal "(" (car tokens)) (let ((count 1) (lst (cdr tokens)) (res nil) tok) (declare (type fixnum count)) (loop (when (null lst) (return (values 'unbalanced tokens))) (setf tok (car lst) lst (cdr lst)) (when (and (= 1 count) (equal ")" tok)) (return (values (nreverse res) lst))) (setf res (cons tok res)) (if (equal "(" tok) (incf count) (if (equal ")" tok) (decf count))) )) (values (list (car tokens)) (cdr tokens)))) (defun group-paren-units (tokens) (declare (type list tokens) (values list)) (let ((res nil) (lst tokens) unit) (loop (multiple-value-setq (unit lst) (scan-parenthesized-unit lst)) (when (eq 'unbalanced unit) (return tokens)) (setq res (cons unit res)) (when (null lst) (return (nreverse res))) ))) (defun check-enclosing-parens (tokens) (declare (type t tokens) (values (or null t))) (and (consp tokens) (equal "(" (car tokens)) (multiple-value-bind (par rst) (scan-parenthesized-unit tokens) (declare (ignore par)) (null rst)))) ;;; READ-MODULE-EXP (defun read-module-exp (context) (let ((cur (!set-single-reader '(#\[ #\])))) (prog1 (read-modexp context) (!set-reader cur)))) ;;; read term with balanced: (/) [/] terminated by c context ;;; (defun read-modexp (c) (let ((cur (!set-single-reader '("_")))) (let ((res nil)) (loop (!read-in) (when (at-eof-or-control-d) (general-read-eof-error)) (when (general-read-string-matches *reader-input* c) (return res)) (setq res (nconc res (read-modexp-delimited)))) (!set-reader cur) res ))) ;;; also used for CafeOBJ view declaration. (defun read-modexp-delimited () (declare (values list)) (!read-in) ;; (when (at-eof-or-control-d) (general-read-eof-error)) (let ((pr (assoc *reader-input* '(("view" "}") ("[" "]") ("(" ")") ) :test #'general-read-string-matches))) ;; (format t "~&*reader-input* ~s" *reader-input*) (cond ((null pr) (prog1 (cons *reader-input* nil) (!read-discard))) (t (let ((sym *reader-input*)) (!read-discard) (let ((lst (read-modexp (cdr pr)))) (prog1 (cons sym (append lst (cons *reader-input* nil))) (!read-discard))))) ))) ;;; READ-MODEXP-FROM-STRING (defun read-modexp-from-string (string) (declare (type simple-string string) (values list)) (let ((*live-newline* nil)) (with-input-from-string (*standard-input* string) (let ((cur (!set-single-reader '(#\[ #\] #\_ #\{ #\}))) (res nil)) (loop (!read-in) (when (at-eof-or-control-d) (return)) (setq res (nconc res (read-modexp-delimited)))) (!set-reader cur) (clear-input) (setq *reader-input* *reader-void*) res)))) #|| (defun module-print-top-level-choices () (let ((flag nil)) (dolist (i '( "module" "mod" "view" "reduce" "red" "make" "test" "input" "in" "-->" "**>" "--" "**" "parse" "match" "ev" "lisp" "show" "sh" "set" "do" "select" "open" "close" "eof" "let" "choose" "quit" "q" "start" "apply" "cd" "ls" "pwd" )) (if (< *print-line-limit* (filecol *standard-output*)) (progn (terpri) (when *print-indent-contin* (princ " ") (setq flag t))) (if flag (princ " ") (setq flag t))) (princ i)))) ||# ;;; (defvar *interactive-session* nil) (defun set-interactive () (setf *interactive-session* t)) (defun off-interactive () (setf *interactive-session* nil)) (defun wait-until-non-white (stream) (declare (type stream) (values t)) (if (at-top-level) (loop (when (not (or (eq 'space .reader-ch.) (eq 'return .reader-ch.))) (setf *sub-prompt* t) (return)) (if (eq 'return .reader-ch.) (progn (when *sub-prompt* (princ "> ") (force-output)) (reader-get-char stream) (when (eq #\? .reader-ch.) (let ((*chaos-verbose* t)) (general-read-show-context) (clear-input) (force-output)) (setf .reader-ch. 'space))) (reader-get-char stream))) (loop (when (not (or (eq 'space .reader-ch.) (eq 'return .reader-ch.))) (return)) (reader-get-char stream)))) ;;; EOF cafeobj-1.6.0/comlib/message.lisp0000644000000000000000000002006113373141170015507 0ustar rootwheel;;;-*- Mode:LISP; Package:CHAOS; Base:10; Syntax:Common-lisp -*- ;;; ;;; Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. ;;; ;;; Redistribution and use in source and binary forms, with or without ;;; modification, are permitted provided that the following conditions ;;; are met: ;;; ;;; * Redistributions of source code must retain the above copyright ;;; notice, this list of conditions and the following disclaimer. ;;; ;;; * Redistributions in binary form must reproduce the above ;;; copyright notice, this list of conditions and the following ;;; disclaimer in the documentation and/or other materials ;;; provided with the distribution. ;;; ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ;;; (in-package :chaos) #|============================================================================== System: CHAOS Module: comlib File: message.lisp ==============================================================================|# #-:chaos-debug (declaim (optimize (speed 3) (safety 0) #-GCL (debug 0))) #+:chaos-debug (declaim (optimize (speed 1) (safety 3) #-GCL (debug 3))) (defun flush-all () (finish-output *standard-output*) (finish-output *error-output*) ) (defun fresh-all () (fresh-line *standard-output*) (fresh-line *error-output*)) ;;; ;;; Message DB ;;; (defvar *Message-DB* (make-hash-table)) ;;; (defun get-msg-type (id) (first (gethash id *Message-DB*))) (defun get-msg-level (id) (second (gethash id *Message-DB*))) (defun get-msg-fmt (id) (third (gethash id *Message-DB*))) (defun get-msg-description (id) (fourth (gethash id *Message-DB*))) (defun register-message (type msg) (setf (gethash (car msg) *Message-DB*) (cons type (cdr msg)))) #+:Allegro (defun read-message-db (path) (clrhash *Message-DB*) (flet ((regme (type msgs) (dolist (msg msgs) (register-message type msg)))) (with-open-file (strm path :if-does-not-exist :error :external-format :utf-8) (loop for type = (read strm nil :eof) while (not (eq type :eof)) do (case type ((:panic :panics) (regme :panic (read strm nil))) ((:error :errors) (regme :error (read strm nil))) ((:warning :warnings) (regme :warning (read strm nil))) ((:message :messages) (regme :message (read strm nil))) ((:smessage :smessages) (regme :smessage (read strm nil))) (otherwise (error "Internal error, invalid message type ~s" type))))))) #+:Allegro (defun setup-message-db () (let ((fname (chaos-probe-file "messagesDB" *chaos-libpath* '(".msg")))) (unless fname (error "Internal error, can't find messagesDB.")) (read-message-db fname))) ;;; ;;; OUTPUT-MSG ;;; ;;; message level ;;; 0 : always ;;; 1 : standard ;;; 2 : only under verbose mode ;;; (defvar *msg-lvl* 1) (defvar *old-msg-lvl* *msg-lvl*) (defun set-verbose-lvl (lvl) (if (<= lvl 3) (setf *msg-lvl* lvl) (error "Internal error, invalid verbose level ~d" lvl))) (defun set-verbose-on () (setf *old-msg-lvl* *msg-lvl*) (set-verbose-lvl 0) (setq *chaos-verbose* t)) (defun set-verbose-off () (when (zerop *msg-lvl*) (set-verbose-lvl *old-msg-lvl*)) (setq *chaos-verbose* nil)) (defun set-expert-on () (setf *old-msg-lvl* *msg-lvl*) (set-verbose-lvl 2)) (defun set-export-off () (when (= *msg-lvl* 2) (set-verbose-lvl *old-msg-lvl*))) (defun set-quiet-on () (setf *old-msg-lvl* *msg-lvl*) (set-verbose-lvl 3)) (defun set-quiet-off () (when (= *msg-lvl* 3) (set-verbose-lvl *old-msg-lvl*))) (defun output-msg (id prefix args) (when (>= (get-msg-level id) *msg-lvl*) (apply #'format t (concatenate 'string prefix "(:" (string id) ") " (get-msg-fmt id)) args))) (defmacro with-output-chaos-error-n ((msg-id args &optional (tag 'to-top tag-p)) &body body) ` (progn (let ((*standard-output* *error-output*) (*print-indent* 4)) (output-msg ',msg-id "~%[Error]" ,args) ,@body) ,(if (and tag-p (eq tag 'to-top)) `(chaos-to-top) `(chaos-error ,tag) ))) (defmacro with-output-chaos-warning-n ((msg-id args) &body body) ` (unless *chaos-quiet* (let ((*standard-output* *error-output*) (*print-indent* 4)) (output-msg ',msg-id "~%[Warning]" ,args) ,@body) (flush-all))) (defmacro with-output-panic-message-n ((msg-id args) &body body) ` (progn (let ((*standard-output* *error-output*)) (output-msg ',msg-id "~%[!! PANIC !!]" ,args) ,@body) (chaos-to-top))) (defmacro with-output-msg-n ((msg-id args &optional (stream '*error-output*)) &body body) ` (unless *chaos-quiet* (let ((*standard-output* ,stream) (*print-indent* 3)) (output-msg ',msg-id "~%-- " ,args) ,@body) (flush-all))) (defmacro with-output-simple-msg-n ((msg-id args &optional (stream '*error-output*)) &body body) ` (unless *chaos-quiet* (let ((*standard-output* ,stream) (*print-indent* 2)) (output-msg ',msg-id "~%" ,args) ,@body) (flush-all))) ;;; older versions (defmacro with-output-chaos-error ((&optional (tag 'to-top)) &body body) ` (progn ;; (flush-all) ;; (fresh-all) (let ((*standard-output* *error-output*) (*print-indent* 4)) (format t "~%[Error]: ") ,@body) ,(if (eq tag 'to-top) `(chaos-to-top) `(chaos-error ,tag) ))) (defmacro with-output-chaos-warning ((&optional (stream '*error-output*)) &body body) ` (unless *chaos-quiet* (let ((*standard-output* ,stream) (*print-indent* 4)) (format t "~%[Warning]: ") ,@body) (flush-all))) (defmacro with-output-panic-message ((&optional (stream '*error-output*)) &body body) ` (progn ;; (fresh-all) ;; (flush-all) (let ((*standard-output* ,stream)) (print-next) (princ "!! PANIC !!: ") ,@body) (chaos-to-top))) ;;; (defmacro with-output-msg ((&optional (stream '*standard-output*)) &body body) ` (unless *chaos-quiet* (let ((*standard-output* ,stream) (*print-indent* 3)) (format t "~%-- ") ,@body) (flush-all))) (defmacro with-output-simple-msg ((&optional (stream '*standard-output*)) &body body) ` (unless *chaos-quiet* ;; (fresh-all) ;; (flush-all) (let ((*standard-output* ,stream) (*print-indent* 2)) (format t "~%") ,@body) (flush-all))) ;;; #|| (defun print-in-progress (str) (unless *chaos-quiet* (princ str *error-output*) (finish-output *error-output*))) ||# (defun print-in-progress (str) (declare (ignore str)) nil) ;;; I-miss-current-module me ;;; Checks if the *current-module* is bound, returns nil with an error mesage if ;;; *current-mdoule* is not bound to non-nil value. ;;; - me must a name (symbol) of a block. ;;; (defmacro I-miss-current-module (me) ` (unless *current-module* (fresh-all) (flush-all) (with-output-panic-message () (format t "in ~a : no current module is specified!" ',me) (force-output) (finish-output) (return-from ,me nil)))) ;;; EOF cafeobj-1.6.0/comlib/msg-test.lisp0000644000000000000000000001143413373141170015632 0ustar rootwheel;;;-*- Mode:LISP; Package:CHAOS; Base:10; Syntax:Common-lisp -*- ;;; ;;; Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. ;;; ;;; Redistribution and use in source and binary forms, with or without ;;; modification, are permitted provided that the following conditions ;;; are met: ;;; ;;; * Redistributions of source code must retain the above copyright ;;; notice, this list of conditions and the following disclaimer. ;;; ;;; * Redistributions in binary form must reproduce the above ;;; copyright notice, this list of conditions and the following ;;; disclaimer in the documentation and/or other materials ;;; provided with the distribution. ;;; ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ;;; ;;; (in-package :chaos) #|============================================================================== System: CHAOS Module: comlib File: message.lisp ==============================================================================|# #-:chaos-debug (declaim (optimize (speed 3) (safety 0) #-GCL (debug 0))) #+:chaos-debug (declaim (optimize (speed 1) (safety 3) #-GCL (debug 3))) (defvar *Panic-messages* (make-hash-table)) (defvar *Error-messages* (make-hash-table)) (defvar *Warning-messages* (make-hash-table)) (defvar *Simple-messages* (make-hash-table)) (defvar *Messages* (make-hash-table)) (defun flush-all () (finish-output *standard-output*) (finish-output *error-output*) ) (defun fresh-all () (fresh-line *standard-output*) (fresh-line *error-output*)) (defun get-msg-fmt (type id) (case type (:panic (gethash id *Panic-messages*)) (:error (gethash id *Error-messages*)) (:warning (gethash id *Warning-messages*)) (:smessage (gethash id *Simple-messages*)) (:message (gethash id *Messages*)) (otherwise (error "Internal error: unknown message type ~a" type)) )) (defun output-msg (type id prefix &rest args) (apply #'format t (concatenate 'string prefix (get-msg-fmt type id)) args)) (defmacro with-output-chaos-error-n ((msg-id args &optional (tag 'to-top tag-p)) &body body) ` (progn (let ((*standard-output* *error-output*) (*print-indent* 4)) (output-msg :error ',msg-id "~%[Error]:" ,args) ,@body) ,(if (and tag-p (eq tag 'to-top)) `(chaos-to-top) `(chaos-error ,tag) ))) (defmacro with-output-chaos-warning-n ((msg-id args) &body body) ` (unless *chaos-quiet* (let ((*standard-output* *error-output*) (*print-indent* 4)) (output-msg :warning ',msg-id "~&[Warning]: " ,args) ,@body) (flush-all))) (defmacro with-output-panic-message-n ((msg-id args) &body body) ` (progn (let ((*standard-output* *error-output*)) (output-msg :panic ',msg-id "~&!! PANIC !!: " ,args) ,@body) (chaos-to-top))) ;;; (defmacro with-output-msg-n ((msg-id args &optional (stream '*error-output*)) &body body) ` (unless *chaos-quiet* (let ((*standard-output* ,stream) (*print-indent* 3)) (output-msg :message ',msg-id "~&-- " ,args) ,@body) (flush-all))) (defmacro with-output-simple-msg-n ((msg-id args &optional (stream '*error-output*)) &body body) ` (unless *chaos-quiet* (let ((*standard-output* ,stream) (*print-indent* 2)) (output-msg :smessage "~&" ',msg-id ,args) ,@body) (flush-all))) ;;; (defun print-in-progress (str) (unless *chaos-quiet* (princ str *error-output*) (finish-output *error-output*))) ;;; I-miss-current-module me ;;; Checks if the *current-module* is bound, returns nil with an error mesage if ;;; *current-mdoule* is not bound to non-nil value. ;;; - me must a name (symbol) of a block. ;;; (defmacro I-miss-current-module (me) ` (unless *current-module* (fresh-all) (flush-all) (with-output-panic-message (:p-no-module '(,me)) ;; (format t "in ~a : no current module is specified!" ',me) (force-output) (finish-output) (return-from ,me nil)))) ;;; EOF cafeobj-1.6.0/comlib/dag.lisp0000644000000000000000000001211713373141170014621 0ustar rootwheel;;;-*- Mode:Lisp; Syntax:Common-Lisp; Package:CHAOS -*- ;;; ;;; Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. ;;; ;;; Redistribution and use in source and binary forms, with or without ;;; modification, are permitted provided that the following conditions ;;; are met: ;;; ;;; * Redistributions of source code must retain the above copyright ;;; notice, this list of conditions and the following disclaimer. ;;; ;;; * Redistributions in binary form must reproduce the above ;;; copyright notice, this list of conditions and the following ;;; disclaimer in the documentation and/or other materials ;;; provided with the distribution. ;;; ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ;;; (in-package :CHAOS) #|============================================================================== System: Chaos Module: comlib File: dag.lisp ==============================================================================|# #-:chaos-debug (declaim (optimize (speed 3) (safety 0) #-GCL (debug 0))) #+:chaos-debug (declaim (optimize (speed 1) (safety 3) #-GCL (debug 3))) ;;; dag node = ( datum List[node] . flag ) ;;; flag is used for dag traverse, i.e. marked=already visited. (defstruct dag-node (datum nil :type t) (subnodes nil :type list) (flag nil :type (or null t))) ;;; basic constructor (defmacro create-dag-node (datum subnodes) `(make-dag-node :datum ,datum :subnodes ,subnodes)) ;;; adding sub node (defmacro add-subnodes (dag datums) (once-only (dag) `(setf (dag-node-subnodes ,dag) (nconc (dag-node-subnodes ,dag) (mapcar #'(lambda (d) (create-dag-node d nil)) ,datums))))) (defmacro push-sub-node (dag datum) `(push (create-dag-node ,datum nil) (dag-node-subnodes ,dag))) ;;; (defmacro dag-node-is-marked? (node) `(dag-node-flag ,node)) (defmacro mark-dag-node (node) `(setf (dag-node-flag ,node) t)) (defmacro unmark-dag-node (node) `(setf (dag-node-flag ,node) nil)) (defun unmark-all-dag-nodes (dag) (declare (type dag-node dag)) (unmark-dag-node dag) (dolist (sub (dag-node-subnodes dag)) (declare (type dag-node sub)) (unmark-all-dag-nodes sub))) ;;; dag-dfs : dag function ;;; traversing dag by depth first manner, apply function to each node. ;;; (defun dag-dfs (dag &optional (function #'identity)) (declare (type dag-node dag) (type function function)) (labels ((do-dag-dfs (d) (unless (dag-node-is-marked? d) (dolist (sub (dag-node-subnodes d)) (unless (dag-node-is-marked? sub) (do-dag-dfs sub))) (funcall function d) (mark-dag-node d)))) (unmark-all-dag-nodes dag) (do-dag-dfs dag))) ;;; dag-wfs : dag function ;;; traversing dag by width first manner, apply function to each node. ;;; (defun dag-wfs (dag &optional (function #'identity)) (declare (type dag-node dag) (type function function)) (labels ((do-dag-wfs (ld) (dolist (d ld) (unless (dag-node-is-marked? d) (funcall function d) (mark-dag-node d))) (dolist (d ld) (do-dag-wfs (dag-node-subnodes d))))) (unmark-all-dag-nodes dag) (do-dag-wfs (list dag)))) ;;; bi-directional graph ;;; (defstruct (bdag (:include dag-node)) (parent nil)) (defmacro create-bdag-node (datum subnodes) (once-only (subnodes datum) `(let ((bdag (make-bdag :datum ,datum :subnodes ,subnodes :parent nil))) (dolist (s ,subnodes) (setf (bdag-parent s) bdag)) bdag))) (defmacro add-bdag-subnodes (bdag datums) (once-only (bdag datums) `(setf (dag-node-subnodes ,bdag) (nconc (dag-node-subnodes ,bdag) (mapcar #'(lambda (d) (let ((sub (create-bdag-node d nil))) (setf (bdag-parent sub) ,bdag) sub)) ,datums))))) (defmacro push-bdag-node (dag datum) (once-only (dag) `(push (let ((s (create-bdag-node ,datum nil))) (setf (bdag-parent s) ,dag) s) (dag-node-subnodes ,dag)))) (defun get-bdag-parents (bdag) (declare (type bdag bdag)) (let ((res nil) (parent (bdag-parent bdag))) (while parent (push parent res) (setq parent (bdag-parent parent))) res)) ;;; EOF cafeobj-1.6.0/comlib/lex.lisp0000644000000000000000000007131413373141170014662 0ustar rootwheel;;;-*- Mode:LISP; Package:CHAOS; Base:10; Syntax:Common-lisp -*- ;;; ;;; Copyright (c) 2000-2017, Toshimi Sawada. All rights reserved. ;;; ;;; Redistribution and use in source and binary forms, with or without ;;; modification, are permitted provided that the following conditions ;;; are met: ;;; ;;; * Redistributions of source code must retain the above copyright ;;; notice, this list of conditions and the following disclaimer. ;;; ;;; * Redistributions in binary form must reproduce the above ;;; copyright notice, this list of conditions and the following ;;; disclaimer in the documentation and/or other materials ;;; provided with the distribution. ;;; ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ;;; (in-package :chaos) #|============================================================================== System:Chaos Module:comlib File: lex.lisp ==============================================================================|# #-:chaos-debug (declaim (optimize (speed 3) (safety 0) #-GCL (debug 0))) #+:chaos-debug (declaim (optimize (speed 1) (safety 3) #-GCL (debug 3))) ;;; ************ ;;; TOKEN READER________________________________________________________________ ;;; ************ ;;; ** NOTES ON GENERAL ASSUMPTIONS AND LIMITATIONS.**************************** ;;; ;;; ;;;============================================================================= ;;; *** CHAOS BUILTIN LEXICAL CATEGORIES *** ;;;============================================================================= (eval-when (:execute :compile-toplevel :load-toplevel) (defvar *builtin-cats* (make-hash-table :test #'eq :size 50)) (defmacro define-builtin-token (token-name id-value) ` (eval-when (:execute :compile-toplevel :load-toplevel) (defparameter ,token-name ,id-value) (setf (gethash ,id-value *builtin-cats*) t))) ) ;;; Chaos BUILTIN LEXICAL CATEGORIES. ;;;----------------------------------------------------------------------------- (defmacro declare-bi-token (sym) `(setf (get ,sym ':bi-token) t)) ;;; The followings are builtin lexical units of Chaos system. ;;; Lisp expression. (defparameter *lisp-escape-char* '|!|) (defparameter .lisp-simple-sexpr. '%SLisp) (defparameter .lisp-general-sexpr. '%GLisp) ;;; Chaos Value (defparameter *chaos-escape-char* '|%|) (defparameter .chaos-value-sexpr. '|%Chaos|) ;;; String&Character (defparameter .String-token. '|String|) ;; (defparameter .Char-token. '|Character|) (eval-when (:execute :load-toplevel) (declare-bi-token '%SLisp) (declare-bi-token '%GLisp) (declare-bi-token '|String|) (declare-bi-token '|%Chaos|) (declare-bi-token '|#\||) (declare-bi-token '|\|#|) ) ;;;============================================================================= ;;; LOW LEVEL READER ;;;============================================================================= ;;; Syntactic properties of characters:_________________________________________ ;;; At the lowest level, each input character has a syntactic property which is ;;; one of the followings: ;;; - 'space : means white space, i.e., normaly the chars chars except ;;; cr/newline have this property. ;;; - 'return : cr & newline. ;;; ** 'white and 'return are always treated as token separators. ;;; There are some chars which are treated as they stand, i.e., each of which ;;; construct a token by itself. it is a resposibility of higher procs to treate ;;; these chars in different ways. In such case, the value of the syntactic ;;; property is set to a symbol other than 'space, 'return, or 'nil. ;;; The property 'nil means that a sequnce of these char construct a token. ;;; The global *reader-read-table* holds the above infos, `!init-read-table' ;;; sets the property for each chars according to its arguments. ;;; (declaim (type (integer 0 256) .reader-char-code-limit.)) (defparameter .reader-char-code-limit. 255) #-GCL (declaim (type simple-vector *reader-read-table*)) #+GCL (declaim (type vector *reader-read-table*)) (defvar *reader-read-table*) (eval-when (:execute :load-toplevel) (setf *reader-read-table* (make-array (list .reader-char-code-limit.) :initial-element nil))) (defmacro !set-syntax (ch val) `(setf (aref *reader-read-table* (the fixnum (char-code ,ch))) ,val)) (defun lex-show-delimiters (stream) (dotimes (x .reader-char-code-limit.) (let ((syntax (aref *reader-read-table* x))) (when syntax (format stream "~%~S : ~S" (code-char x) syntax))))) ;;; !INIT-READ-TABLE : List[Char] List[Char] List[Char] -> Void ;;; initialize Chaos read table. ;;; space : list of `space' characters ;;; return : list of `return' characters ;;; single : list of self terminatig characters ;;; (defun !init-read-table (space return single) (declare (type list space return single) (values t)) #|| (do ((i 0 (1+ i))) ((= i .reader-char-code-limit.)) (declare (type (integer 0 256) i)) (setf (aref *reader-read-table* i) nil)) ||# (dolist (char space) (!set-syntax char 'space)) (dolist (char return) (!set-syntax char 'return)) (dolist (c-c single) (!set-syntax (car c-c) (cdr c-c)))) (defmacro reader-get-syntax (ch) `(if (< (char-code ,ch) .reader-char-code-limit.) (aref *reader-read-table* (the fixnum (char-code ,ch))) nil)) (defmacro reader-valid-char-code (n) (once-only (n) `(and (<= 0 ,n) (<= ,n .reader-char-code-limit.)))) ;;; !SET-SINGLE-READER list-of-chars ;;; make a list of characters be single character symbols (self terminating) ;;; in the reader. ;;; returns list of original status. the return valu can be used for an argument ;;; of `!set-reader' for recovering the modifications. ;;; (defun !set-single-reader (l) (declare (type list l) (values t)) (mapcar #'(lambda (x) (declare (type (or simple-string character) x)) (let ((chr (if (and (stringp x) (= (length x) 1)) (char (the string x) 0) (if (characterp x) x (with-output-chaos-error ('invalid-str) (format t "delimiter must be a single character, but ~a is given" x)))))) (prog1 (cons chr (reader-get-syntax chr)) ;; (print chr) (!set-syntax chr (intern (string x)))))) l)) ;;; !SET-READER list-of-chars ;;; modify a sequence of characters for syntax as given by associated values. ;;; useful for restoring the old properties of chars modified by !set-single-reader. ;;; (defun !set-reader (l) (declare (type list l) (values t)) (mapc #'(lambda (x) (declare (type list x)) (let ((s (car x))) (declare (type (or simple-string character) s)) (!set-syntax (if (stringp s) (char (the string s) 0) s) (cdr x)))) l)) ;;; !READ-IN ;;; read a token iff the last input is not processed yet, ;;; i.e. *reader-input* == *reader-void*. ;;; the token is set to *reader-input*. ;;; ;;; *reader-input* : token buffer. ;;; (defvar *reader-input* nil) ;;; *reder-void* is the marker that indicates the buffered token is ;;; consumed, thus we should read a token. ;;; (defparameter *reader-void* '(void)) (defvar *token-buf* nil) (defvar *last-token* *reader-void*) ;;; The eof value. (eval-when (:execute :compile-toplevel :load-toplevel) (defparameter *lex-eof* (cons nil nil)) ) ;;; (defmacro !read-in () ` (when (eq *reader-input* *reader-void*) (setq *reader-input* (read-sym)))) ;;; !READ-DISCARD ;;; discard the last input token. ;;; (defmacro !read-discard () `(progn ;; (clear-input) ;; (setq *token-buf* nil) (setq *reader-input* *reader-void*))) ;;; !READ-SYM ;;; read a token. ;;; (defun !read-sym () (cond ((eq *reader-input* *reader-void*) (read-sym)) (t (prog1 *reader-input* (!read-discard))))) ;;; (defun test-lex (file) (!lex-read-init) (with-open-file (str file :direction :input) (let ((tok nil) (*standard-input* str)) (while-not (eq tok *lex-eof*) (setf tok (!read-sym)) (print tok))))) ;;; SIMPLE READER_______________________________________________________________ ;;; ;;; READ-LINES (stream) ;;; (defparameter newline-string (string #\newline)) (defparameter line-continue-char #\;) (defparameter .read-line-eof. "") (declaim (special *live-newline*)) (defvar *live-newline* nil) (defmacro add-new-line (str) `(concatenate 'string ,str newline-string)) (defun read-lines (&optional (stream *standard-input*)) (declare (type stream stream) (values simple-string fixnum)) (let (res line (ll 0) l-char (l-total 0)) (declare (type fixnum l-total ll)) (loop (setq line (read-line stream nil .read-line-eof.)) (when (eq line .read-line-eof.) (return)) (when (<= (setq ll (length (the simple-string line))) 0) (return)) (incf l-total ll) (decf ll) (setq l-char (char line ll)) (if (char= line-continue-char (the character l-char)) (progn (setq res (concatenate 'string res (setq line (subseq (the simple-string line) 0 ll)) newline-string )) ;; (decf l-total) (when (at-top-level) (princ "> ") (force-output))) (progn (setq res (concatenate 'string res (if (char= #\. (the character l-char)) (progn ;; (decf l-total) (subseq line 0 ll)) line))) (return)))) (if (eq line .read-line-eof.) (values *lex-eof* 0) (let ((str (if res (if *live-newline* (add-new-line res) res) ""))) (values str (length str)))))) ;;; the global .reader-ch. holds the last char read. ;;; if the character has a property other than 'nil, the property value is set, ;;; otherwise the character itself is set. ;;; (defvar .reader-ch. 'space) ;;; the special .escape-char. holds a character which is used as escape ;;; character, i.e., the preceding char is treated as is. ;;; (declaim (special .escape-char.)) (defvar .default-escape-char. #\\) ;;; (defparameter control-d #\Eot) (defparameter control-d-string "") (defparameter input-escape #\esc) (defparameter input-escape-string "") (defmacro see-ctrl-d () `(eq .reader-ch. control-d)) (defmacro reader-is-at-eof () `(eq *lex-eof* *reader-input*)) (defmacro at-eof () `(or (see-ctrl-d) (eq *lex-eof* .reader-ch.))) (defmacro at-eof-or-control-d () `(or (at-eof) (equal *reader-input* control-d-string))) (defmacro see-input-escape () `(eq .reader-ch. input-escape)) (defun str-match? (x y) (declare (type t x) (type (or symbol simple-string) y) (values (or null t))) (or (eq x y) (and (stringp x) (string= (the simple-string x) (if (stringp y) (the simple-string y) (string-downcase (string (the symbol y)))))))) (defun lex-string-match(x y) (declare (type t x) (type (or atom list) y) (values (or null t))) (if (atom y) (str-match? x y) (member x y :test #'str-match?))) ;;; READER-GET-CHAR : STREAM ;;; reads a one character from stream, set .reader-ch. handling ESCAPE sequence. ;;; (declaim (special .reader-escape.)) (defvar .reader-escape. nil) ; flags indicating we are now in `escaped' ; status. ;; (defvar .read-buffer. nil) ;; (defvar .read-pos. 0) (defvar .newline-count. 0) (defvar *last-newline* nil) (defparameter eof-char control-d) (defun reader-get-char (stream) (declare (type stream stream) (values t)) (let ((inch (read-char stream nil *lex-eof*))) (cond ((eq inch *lex-eof*) (setf .reader-ch. *lex-eof*)) #|| (.reader-escape. (setf .reader-ch. inch)) ((char= .escape-char. inch) (let ((.reader-escape. t)) (setf .reader-ch. 'space) (reader-get-char stream))) ||# (t (unless *chaos-input-source* ;; interactive session (if (and (char= inch #\newline) *last-newline*) (incf .newline-count.) (if (char= inch #\newline) (setq *last-newline* t) (setf .newline-count. 0 *last-newline* nil))) (when (> .newline-count. 2) (!read-discard) (clear-input) (setq *last-newline* nil) (setq .newline-count. 0) (throw :aborting-read :aborting-read))) ;; (let ((val (reader-get-syntax inch))) (setf .reader-ch. (if val val inch))))))) ; (defun reader-get-char (stream) ; (declare (type stream stream) ; (values t)) ; (let ((inch (read-char stream nil *lex-eof*))) ; (cond ((eq inch *lex-eof*) ; (setf .reader-ch. *lex-eof*)) ; #|| ; (.reader-escape. ; (setf .reader-ch. inch)) ; ((char= .escape-char. inch) ; (let ((.reader-escape. t)) ; (setf .reader-ch. 'space) ; (reader-get-char stream))) ; ||# ; (t (let ((val (reader-get-syntax inch))) ; (setf .reader-ch. (if val val inch))))))) ;;; READ-LEXICON : STREAM -> TOKEN ;;; read a lexicon. ;;; ;;; implementation limit: a lexicon must be of length less than or equal to 256. ;;; (declaim (type simple-string .reader-buf.)) (defvar .reader-buf. (make-string 256)) (defparameter .chaos-simple-LISP-keyword. "#!") (defparameter .chaos-general-LISP-keyword. "#!!") (defparameter .chaos-value-keyword. "#%") (defparameter .ml-begin-char. #\#) (defparameter .ml-end-char. #\|) (defvar .lex-inner-multi-comment. nil) (defun read-lexicon (&optional (stream *standard-input*)) (declare (type stream stream)) (let ((p -1) res) (declare (type fixnum p) (type (or symbol list simple-string) res)) (setq res (loop (cond ((member .reader-ch. '(#\Rubout #\Backspace)) (if (<= 0 p) (decf p 1))) ((characterp .reader-ch.) (incf p) (setf (aref .reader-buf. p) .reader-ch.)) (t (let ((c (string .reader-ch.))) (setq .reader-ch. 'space) (return c)))) (reader-get-char stream) (when (at-eof) (if (<= 0 p) (progn (setq .reader-ch. 'space) (return (subseq .reader-buf. 0 (1+ p)))) (return *lex-eof*))) (when (symbolp .reader-ch.) (return (subseq .reader-buf. 0 (1+ p)))) )) ;; (lex-consider-token res))) (defun lex-consider-token (tok) (declare (type t tok)) (if (equal .chaos-simple-LISP-keyword. tok) (progn (reader-suppress-ch tok) (list .lisp-simple-sexpr. (read))) (if (equal .chaos-general-lisp-keyword. tok) (progn (reader-suppress-ch tok) (list .lisp-general-sexpr. (read))) (if (equal .chaos-value-keyword. tok) (progn (reader-suppress-ch tok) (list .chaos-value-sexpr. (read))) tok)))) (defun reader-suppress-ch (context &optional (stream *standard-input*)) (declare (ignore context) (type stream stream) (values t)) (unless (at-eof) (unless (memq .reader-ch. '(space return)) (unread-char (if (characterp .reader-ch.) .reader-ch. (char (the simple-string (string .reader-ch.)) 0)) stream) (setq .reader-ch. 'space)))) (defun reader-unread (ch stream) (declare (type (or symbol character) ch) (type stream stream) (values t)) (unless (memq ch '(space return)) (unread-char (if (characterp ch) ch (char (the simple-string (string (the symbol ch))) 0)) stream) ch)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun skip-multi-comment (stream) (loop (reader-get-char stream) (cond ((at-eof) (setf .reader-ch. 'space) (!read-discard) (return-from skip-multi-comment *lex-eof*)) (t (case .reader-ch. (#\| (reader-get-char stream) (when (equal .reader-ch. #\#) (!read-discard) (setq .reader-ch. 'space) (return-from skip-multi-comment nil)) (when (at-eof) (setf .reader-ch. 'space) (!read-discard) (return-from skip-multi-comment *lex-eof*)) (reader-unread .reader-ch. stream))))))) ;;; READ-SYM : STREAM -> TOKEN ;;; read characters considered to be constructs of a token, returns ;;; the token recognized. ;;; The followings are treated specially: ;;; (...) : read a parenthesized unit. ;;; "..." : read as string constant. ;;; 'c : read as character constant. ;;; (defun unread-token (&rest ignore) (declare (ignore ignore)) (unless (eq *last-token* *reader-void*) (push *last-token* *token-buf*) (setq *last-token* *reader-void*))) (defun read-sym (&optional (stream *standard-input*) (parse-list nil)) (declare (type stream stream) (type (or null t) parse-list)) (flet ((skip-whites () ;; skip white chars. (while (memq .reader-ch. (if *live-newline* '(space) '(space return))) (reader-get-char stream)))) (when *token-buf* (return-from read-sym (pop *token-buf*))) ;; skip white chars. (skip-whites) ;; get token ;; (setq *last-token* nil) (tagbody retry (cond ((at-eof) (setf .reader-ch. 'space) (!read-discard) (return-from read-sym (progn (setq *last-token* *reader-void*) *lex-eof*))) ((see-input-escape) ;; user forces aborting reading process. (setq .reader-ch. 'space) (!read-discard) (clear-input) (throw :aborting-read :aborting-read)) (t (case .reader-ch. (\( (if parse-list (setq *last-token* (lex-read-list stream)) (progn (setq .reader-ch. 'space) (setq *last-token* "("))) (return-from read-sym *last-token*)) (return (setq .reader-ch. 'space) (setq *last-token* (if *live-newline* '(return) *reader-void*)) (return-from read-sym *last-token*)) (#\" ; string (return-from read-sym (setq *last-token* (list (lex-read-string stream))))) (#\# ; #! or #!! (reader-get-char stream) (cond ((memq .reader-ch. '(space return)) (return-from read-sym (setq *last-token* '("#")))) ((eq .reader-ch. *lisp-escape-char*) (return-from read-sym (setq *last-token* (lex-read-lisp-escape stream)))) ((eq .reader-ch. *chaos-escape-char*) (return-from read-sym (setq *last-token* (lex-read-chaos-value stream)))) ((equal .reader-ch. #\|) ; begin multi comment (skip-multi-comment stream) (skip-whites) (go retry)) (t (reader-unread .reader-ch. stream) (setq .reader-ch. #\#) (let ((tok (read-lexicon stream))) (if (equal tok *lex-eof*) (return-from read-sym (progn (setq *last-token* *reader-void*) *lex-eof*)) (return-from read-sym (setq *last-token* tok)))))))) ;; (if (symbolp .reader-ch.) (let ((str (string .reader-ch.))) (setq .reader-ch. 'space) (return-from read-sym (setq *last-token* (lex-consider-token str)))) (let ((tok (read-lexicon stream))) (if (eq tok *lex-eof*) (return-from read-sym (progn (setq *last-token* *reader-void*) *lex-eof*)) (return-from read-sym (setq *last-token* tok)))))))))) ;;; builtin string reader (defun lex-read-string (stream) (declare (type stream stream) (values t)) (reader-unread .reader-ch. stream) (let ((str (read stream nil *lex-eof*))) (if (eq str *lex-eof*) *lex-eof* (prog1 (list .String-token. str) (setf .reader-ch. 'space))))) ;; builtin lisp expression (defun lex-read-lisp-escape (stream) (declare (type stream stream) (values list)) (let ((nx nil)) (setq nx (reader-get-char stream)) (while (memq .reader-ch. '(space return)) (setq nx (reader-get-char stream))) (case nx ((*lisp-escape-char* *chaos-escape-char*) ;; #!! (let ((expr (read stream nil *lex-eof*))) (setq .reader-ch. 'space) (if (equal expr *lex-eof*) (progn (setq *last-token* *reader-void*) (setq .reader-ch. 'space) *lex-eof*) (list .lisp-general-sexpr. expr)))) (otherwise ;; #! (let ((expr nil)) (setq .reader-ch. 'space) (reader-unread nx stream) (setq expr (read stream nil *lex-eof*)) (if (equal expr *lex-eof*) (progn (setq *last-token* *reader-void*) *lex-eof*) (list .lisp-simple-sexpr. expr)))))) ) (defun lex-read-chaos-value (stream) (declare (type stream stream) (values list)) (let ((expr (read stream nil *lex-eof*))) (setq .reader-ch. 'space) (if (equal expr *lex-eof*) (progn (setq *last-token* *reader-void*) *lex-eof*) (list .chaos-value-sexpr. expr)))) ;;; builtin character reader : obsolate #|| (defun lex-read-character (stream) (let ((char (read-char stream nil *lex-eof*))) (if (eq char *lex-eof*) *lex-eof* (progn (when (eql char #\\) ; escape char (let ((echar (read-char stream nil *lex-eof*))) (if (eq echar *lex-eof*) (return-from lex-read-character *lex-eof*) (setf char (case echar (#\n #\Newline) (#\r #\Return) (#\t #\Tab) (#\s #\Space) (#\l #\LineFeed) (#\p #\Page) (otherwise echar)))))) (setf .reader-ch. 'space) (list .Char-token. char))))) ||# ;;; read up to matching close parenthesis ;;; (defun lex-read-list (&optional (stream *standard-input*)) (declare (type stream stream)) (reader-get-char stream) (lex-read-rest-of-list stream)) (defun lex-read-rest-of-list (&optional (stream *standard-input*)) (declare (type stream stream) (values list)) (while (memq .reader-ch. '(space return)) (reader-get-char stream)) (if (at-eof) *lex-eof* (if (eq '\) .reader-ch.) (progn (reader-get-char stream) (list "(" ")")) (let ((res (list "(")) x) (loop (setq x (lex-read stream)) (when (eq *lex-eof* x) (return *lex-eof*)) (setq res (append res x)) ;; (wait-until-non-white stream) (while (memq .reader-ch. '(space return)) (reader-get-char stream)) (when (eq '|)| .reader-ch.) (reader-get-char stream) (return (nconc res (list ")")))) (when (at-eof) (return *lex-eof*))) )))) ;;; LEX-READ : STREAM -> List[Token] ;;; standard routine to get token from stream. ;;; (defun bi-token? (tok) (declare (type t tok) (values (or null t))) (and (consp tok) (let ((tm (car tok))) (and (symbolp tm) (get tm ':bi-token))))) (defun lex-read (&optional (stream *standard-input*)) (declare (type stream stream) (values t)) (let ((tok (read-sym stream t))) (if (eq *lex-eof* tok) *lex-eof* (cond ((atom tok) (if tok (list tok) nil)) (t (if (bi-token? tok) (list tok) tok)))))) ;;; returns t iff the characters in the string are all digit char. (defmacro all-digit? (string start end) (once-only (string) ` (the (or null t) (do ((s (the fixnum ,start) (1+ s))) ((>= s ,end) t) (declare (type fixnum s end)) (if (not (digit-char-p (schar ,string s))) (return nil)))))) ;;; BUFFERED-INPUT______________________________________________________________ ;;; one token is bufferd. ;;; Input Buffering for general reader ;;; the following routines create a single token buffer, which ;;; allows look-ahead. ;;; ;;; !LEX-READ-INIT ;;; initialize read table, .escape-char., and .reader-ch.. ;;; (defparameter .default-space-chars. '(#\Space #\Tab #\Page #\Linefeed)) (defparameter .default-return-chars. '(#\Return #\Newline)) (defparameter .default-single-chars. `((#\( . \() (#\) . \)) (#\, . |,|) (#\[ . |[|) (#\] . |]|) (#\{ . |{|) (#\} . |}|) (#\; . \;) ;; (#\_ . |_|) ;; (#\% . "%") ;; (#\! . |!|) (,control-d . ,control-d) )) (defun !force-single-reader (l) (declare (type list l) (values t)) (dolist (x l) (let* ((chr (if (and (stringp x) (= (length x) 1)) (char (the string x) 0) (if (characterp x) x (with-output-chaos-error ('invalid-str) (format t "delimiter must be a single character, but ~a is given" x))))) (sym (intern (string x)))) (format t "~&setting delimiters ~S : ~S" chr sym) (!set-syntax chr sym)))) (defun !unset-single-reader (l) (declare (type list l) (values t)) (dolist (x l) (let ((chr (if (and (stringp x) (= (length x) 1)) (char (the string x) 0) (if (characterp x) x (with-output-chaos-error ('invalid-str) (format t "Delimiter must be a single character, but ~a is given" x)))))) (if (assoc chr .default-single-chars.) (warn "Character '~A' is a hardwired self delimiting charcter, ignored." chr) (progn (format t "~&unsetting delimiters ~S" chr) (!set-syntax chr nil)))))) ;;; ;;; ;;; (defun !lex-read-init (&key (space .default-space-chars.) (return .default-return-chars.) (single .default-single-chars.) (escape .default-escape-char.)) (!init-read-table space return single) (setq .escape-char. escape) (setq .reader-ch. 'space) (setq *reader-input* *reader-void* *last-token* *reader-void* *token-buf* nil)) ;;; EOF cafeobj-1.6.0/comlib/process.lisp0000644000000000000000000001702313373141170015545 0ustar rootwheel;;;-*- Mode:Lisp; Syntax:Common-Lisp; Package:CHAOS -*- ;;; ;;; Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. ;;; ;;; Redistribution and use in source and binary forms, with or without ;;; modification, are permitted provided that the following conditions ;;; are met: ;;; ;;; * Redistributions of source code must retain the above copyright ;;; notice, this list of conditions and the following disclaimer. ;;; ;;; * Redistributions in binary form must reproduce the above ;;; copyright notice, this list of conditions and the following ;;; disclaimer in the documentation and/or other materials ;;; provided with the distribution. ;;; ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ;;; (in-package :CHAOS) #|============================================================================== System: Chaos Module: comlib File: process.lisp ==============================================================================|# #-:chaos-debug (declaim (optimize (speed 3) (safety 0) #-GCL (debug 0))) #+:chaos-debug (declaim (optimize (speed 1) (safety 3) #-GCL (debug 3))) ;;; *NOTE* GCL Specific ;;; ************************************ ;;; SPAWNING PROCESS WITH TOW-WAY STREAM ;;; ************************************ ;;; ;;; The following C codes are borrowed from GCL run_process.c ;;; with some minor bug fixes including enhancements by ishisone@sra.co.jp. ;;; (Clines " #undef PAGESIZE #include /* errno global, error codes for UNIX IO */ #include /* Data types definitions */ #include /* Socket definitions with out this forget it */ #include /* Internet address definition AF_INET etc... */ #include /* UNIX Signal codes */ #include /* IO control standard UNIx fair */ #include #include /* Function to set socket aync/interrupt */ #include /* Time for select time out */ #include /* Data Base interface for network files */ /* patch by ishisone@sra.co.jp */ #include /* Wait system call options */ /* patch end */ #include static char *lisp_to_string(string) object string; { int i, len; char *sself; char *cstr; len = string->st.st_fillp; cstr = (char *) malloc (len+1); sself = &(string->st.st_self[0]); for (i=0; ism.sm_mode = smm_input; stream_in->sm.sm_fp = fp1; stream_in->sm.sm_int0 = sockets_in[1]; stream_in->sm.sm_int1 = 0; /* patch by sawada@sra.co.jp -- repairing printing problem */ stream_in->sm.sm_object0 = sLstring_char; stream_in->sm.sm_object1 = Cnil; /* end patch */ stream_out = (object) alloc_object(t_stream); stream_out->sm.sm_mode = smm_output; stream_out->sm.sm_fp = fp2; setup_stream_buffer(stream_in); setup_stream_buffer(stream_out); stream_out->sm.sm_int0 = sockets_out[1]; stream_out->sm.sm_int1 = 0; /* patch by sawada@sra.co.jp -- ditto */ stream_out->sm.sm_object0 = sLstring_char; stream_out->sm.sm_object1 = Cnil; /* patch end */ stream = make_two_way_stream(stream_in, stream_out); return(stream); } /* the routines for spawning off a process with streams * * Assumes that istream and ostream are both associated * with \"C\" type streams. */ static spawn_child(istream, ostream, pname, argv) object istream; object ostream; char *pname; char **argv; { int fdin; int fdout; if (istream->sm.sm_fp == NULL || ostream->sm.sm_fp == NULL) FEerror(\"Cannot spawn process with given stream\", 0); fdin = istream->sm.sm_int0; fdout = ostream->sm.sm_int0; if (fork() == 0) { /* the child --- replace standard in and out with descriptors given */ /* patch by ishisone@sra.co.jp */ setsid(); /* in order to get rid of job control */ fclose(istream->sm.sm_fp); /* close parent-side file desc. */ fclose(ostream->sm.sm_fp); /* ditto */ /* end patch */ close(0); dup(fdin); close(1); dup(fdout); if (execvp(pname, argv) == -1) { fprintf(stderr, \"\\n***** Error in process spawning *******\"); fflush(stderr); exit(1); } } /* patch by ishisone@sra.co.jp */ else { /* the parent */ close(fdin); /* close child-side file descriptor */ close(fdout); /* ditto */ } /* end patch */ } /* #if defined(NeXT) # define WAITPID(pid, statusp, options) \ wait3((union wait*)statusp, options, (struct rusage*)0) #else # define WAITPID(pid, statusp, options) \ waitpid(pid, statusp, options) #endif */ /* patch by ishisone@sra.co.jp */ static reap_child() { /* int dummy; while (WAITPID(-1, &dummy, WNOHANG) > 0) ; */ } /* end patch */ static run_child(file, arglist) object file; object arglist; { char *filename = object_to_string(file); char *argv[100]; object stream; int i; /* patch by ishisone@sra.co.jp */ signal(SIGCHLD, reap_child); /* end patch */ argv[0] = \"\"; for(i = 1; arglist != Cnil; i++) { argv[i] = lisp_to_string(arglist->c.c_car); arglist = arglist->c.c_cdr; } argv[i] = (char *)0; stream = make_pipe(); spawn_child(stream->sm.sm_object1, stream->sm.sm_object0, filename, argv); return(stream); } " ) (defentry run-child (object object) (object run_child)) (defentry make-pipe () (object make_pipe)) ;;; ;;; (defstruct process (name "" :type string :read-only t) (in-stream) (out-stream)) ;;; (defun run-process (program &optional args) (let ((stream (run-child program args))) (make-process :name program :in-stream (si::fp-input-stream stream) :out-stream (si::fp-output-stream stream)))) (defmacro with-write-to-process ((process) &body body) ` (let ((*standard-output* (process-out-stream ,process))) ,@body (finish-output))) (defmacro with-read-from-process ((process) &body body) ` (let ((*standard-input* (process-in-stream ,process))) ,@body )) cafeobj-1.6.0/comlib/tree-display.lisp0000644000000000000000000004575613373141170016507 0ustar rootwheel;;;-*- Mode:LISP; Package:CHAOS; Base:10; Syntax:Common-lisp -*- ;;; ;;; Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. ;;; ;;; Redistribution and use in source and binary forms, with or without ;;; modification, are permitted provided that the following conditions ;;; are met: ;;; ;;; * Redistributions of source code must retain the above copyright ;;; notice, this list of conditions and the following disclaimer. ;;; ;;; * Redistributions in binary form must reproduce the above ;;; copyright notice, this list of conditions and the following ;;; disclaimer in the documentation and/or other materials ;;; provided with the distribution. ;;; ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ;;; (in-package :chaos) #|============================================================================== System: CHAOS Module: comlib File: tree-display.lisp ==============================================================================|# #-:chaos-debug (declaim (optimize (speed 3) (safety 0) #-GCL (debug 0))) #+:chaos-debug (declaim (optimize (speed 1) (safety 3) #-GCL (debug 3))) ;;;----------------------------------------------------------------------------- ;;; customisable parameters ;;;----------------------------------------------------------------------------- ;;; how many space characters between trees (defparameter tree-spacing 2) ;;; print tree with leaves at bottom? (defparameter leaves-at-bottom? nil) ;;; USERS MUST BIND THESE FUNCTIONS ;;; which define what a tree is (leaf & internal node) and ;;; how to get its components. ;;; (declaim (special leaf? leaf-name leaf-info int-node-name int-node-children)) (defvar leaf? nil) (defvar leaf-name nil) (defvar leaf-info nil) (defvar int-node-name nil) (defvar int-node-children nil) (defun make-augm-leaf (width root name info) (declare (type t width root name info)) (list 'leaf width root name info)) (defun make-augm-pad (width) (declare (type t width)) (list 'pad width)) (defun make-augm-int-node (width root name lpad rpad children) (declare (type t width root name lpad rpad children)) (list nil width root name lpad rpad children)) (defun augm-tree-int-node? (x) (declare (type list x) (values (or null t))) (null (car x))) (defun augm-tree-pad? (x) (declare (type list x)) (eq (car x) 'pad)) (defun augm-tree-width (x) (declare (type list x) (values fixnum)) (nth 1 x)) (defun augm-tree-root (x) (declare (type list x) (values t)) (nth 2 x)) (defun augm-tree-name (x) (declare (type list x)) (nth 3 x)) (defun augm-leaf-info (x) (declare (type list x)) (nth 4 x)) (defun augm-int-node-lpad (x) (declare (type list x)) (nth 4 x)) (defun augm-int-node-rpad (x) (declare (type list x)) (nth 5 x)) (defun augm-int-node-children (x) (declare (type list x)) (nth 6 x)) (defun pad (width l) (declare (type fixnum width) (type list l) (values list)) (if (> width 0) (cons (make-augm-pad width) l) l)) (defun field-width (x) (declare (type t x) (values fixnum)) " return number of chars in the written repr of x" (labels ((l-length (l w) (declare (type list l) (type fixnum w) (values fixnum)) (cond ((null l) w) (t (l-length (cdr l) (+ w (field-width (car l)) 1))) )) #|| not used now (s-length (i w) (if (>= i 0) (let ((c (elt x i))) (s-length (- i 1) (+ w (case c ((#\: #\") 2) (otherwise 1))))) w)) ||# ) ;; (typecase x (symbol (length (symbol-name (the symbol x)))) (character (case x ((#\space) 7) ((#\newline) 9) (otherwise 3))) (number (length (format nil "~S" x))) (list (+ (l-length (cdr x) (+ (field-width (car x)) 2)) 1)) (string (length (the simple-string x)) ;;(s-length (- (length x) 1) 2) ) (t 0)))) (defun augment-tree (tree) (declare (type list tree)) (if (funcall leaf? tree) (let* ((name (funcall leaf-name tree)) (info (funcall leaf-info tree)) (name-width (field-width name)) (info-width (field-width info)) (tree-width (max name-width info-width))) (declare (type fixnum name-width info-width tree-width)) (make-augm-leaf tree-width (truncate tree-width 2) name info)) (let* ((children (mapcar #'augment-tree (funcall int-node-children tree))) (name (funcall int-node-name tree)) (name-width (field-width name)) (name-left (truncate name-width 2)) (name-right (- name-width name-left))) (declare (type fixnum name-width name-left name-right) (type list children)) (if (null children) (make-augm-int-node name-width name-left name 0 0 '()) (let* ((first-child (car children)) (last-child (nth (- (length children) 1) children)) (width (+ (* (- (the fixnum (length (the list children))) 1) tree-spacing) (the fixnum (apply #'+ (mapcar #'augm-tree-width children))))) (left (truncate (+ (- width (the fixnum (augm-tree-width last-child))) (+ (the fixnum (augm-tree-root first-child)) (the fixnum (augm-tree-root last-child)))) 2.0)) (right (- width left)) (max-left (max name-left left)) (max-right (max name-right right))) (declare (type fixnum width left right max-left max-right)) ;; (make-augm-int-node (+ max-left max-right) max-left name (- max-left left) (- max-right right) children)))))) ;;; ;;; (declaim (type hash-table _dup-hash_) (type fixnum _ref-num-counter_) (type list _dup-infos_)) (defvar _dup-hash_ (make-hash-table :test #'equal)) (defvar _ref-num-counter_ -1) (defvar _dup-infos_ nil) (defun augment-tree-as-graph (tree) (clrhash _dup-hash_) (setq _dup-infos_ nil) (setq _ref-num-counter_ -1) (traverse-tree-checking-dups tree) (augment-tree-as-graph-aux tree)) (defstruct grph-info (visited 0 :type fixnum) name ref-name) (defstruct (grph-int-node-info (:include grph-info)) ) (defstruct (grph-leaf-info (:include grph-info)) info ) (defun traverse-tree-checking-dups (tree) (let ((info (gethash tree _dup-hash_))) (cond (info ; duplicates (incf (grph-info-visited info)) (when (= 1 (grph-info-visited info)) ;; this is the second time (setf (grph-info-ref-name info) (format nil "#~d" (incf _ref-num-counter_))) )) (t ; the first time (cond ((funcall leaf? tree) ;; leaf tree (let ((name (funcall leaf-name tree)) (info (funcall leaf-info tree))) (let ((leaf-info (make-grph-leaf-info :name name :info info))) (setf (gethash tree _dup-hash_) leaf-info)))) (t ;; internal node (let ((name (funcall int-node-name tree))) (let ((int-info (make-grph-int-node-info :name name))) (setf (gethash tree _dup-hash_) int-info)) (mapc #'traverse-tree-checking-dups (funcall int-node-children tree))))))))) (defun augment-tree-as-graph-aux (tree) (let* ((info (gethash tree _dup-hash_)) (ref-num (decf (grph-info-visited info))) (ref-name (grph-info-ref-name info)) (name (cond ((< ref-num 0) (if ref-name (format nil "~a=~a" ref-name (grph-info-name info)) (grph-info-name info))) (t ref-name)))) (declare (type fixnum ref-num)) (cond ((grph-leaf-info-p info) ; leaf (let* ((leaf-info (grph-leaf-info-info info)) (name-width (field-width name)) (info-width (field-width leaf-info)) (tree-width (max name-width info-width))) (declare (type fixnum name-width info-width tree-width)) (make-augm-leaf tree-width (truncate tree-width 2) name leaf-info))) (t ; int node (let* ((children (if (and (>= ref-num 0) ref-name) nil (mapcar #'augment-tree-as-graph-aux (funcall int-node-children tree)))) (name-width (field-width name)) (name-left (truncate name-width 2)) (name-right (- name-width name-left))) (declare (type list children) (type fixnum name-width name-left name-right)) (if (null children) ;; (make-augm-int-node name-width name-left name 0 0 '()) (make-augm-leaf name-width (truncate name-width 2) name nil) (let* ((first-child (car children)) (last-child (nth (- (the fixnum (length children)) 1) children)) (width (+ (* (- (the fixnum (length children)) 1) tree-spacing) (the fixnum (apply #'+ (mapcar #'augm-tree-width children))))) (left (truncate (+ (- width (the fixnum (augm-tree-width last-child))) (+ (the fixnum (augm-tree-root first-child)) (the fixnum (augm-tree-root last-child)))) 2.0)) (right (- width left)) (max-left (max name-left left)) (max-right (max name-right right))) (declare (type fixnum width left right max-left max-right)) (make-augm-int-node (+ max-left max-right) max-left name (- max-left left) (- max-right right) children)))))))) (defun any-int-nodes? (trees) (if (null trees) nil (or (augm-tree-int-node? (car trees)) (any-int-nodes? (cdr trees))))) (defun all-done? (trees) (if (null trees) t (and (augm-tree-pad? (car trees)) (all-done? (cdr trees))))) (defun print-seq (c n stream) (declare (type fixnum n) (type (or null t) c) (type stream stream)) (when n (dotimes (x n) (princ c stream)))) (defun print-loop1 (l delay-leaves? stream) (declare (type list l) (type (or null t) delay-leaves?) (type stream stream)) (when (consp l) (let* ((tree (car l)) (tree-width (augm-tree-width tree))) (declare (type fixnum tree-width)) (if (augm-tree-pad? tree) (progn (print-seq #\space tree-width stream) (print-loop1 (cdr l) delay-leaves? stream)) (let* ((root (augm-tree-root tree)) (name (augm-tree-name tree)) (name-width (field-width name)) (name-left (truncate name-width 2)) (name-right (- name-width name-left))) (declare (type fixnum root name-width name-left name-right)) (if (or (not delay-leaves?) (augm-tree-int-node? tree)) (progn (print-seq #\space (- root name-left) stream) (princ name stream) (print-seq #\space (- tree-width root name-right) stream) (print-loop1 (cdr l) delay-leaves? stream)) (progn (print-seq #\space root stream) (princ #\| stream) (print-seq #\space (- tree-width root 1) stream) (print-loop1 (cdr l) delay-leaves? stream)))))))) (defun print-loop2 (l new-trees delay-leaves? stream) (if (consp l) (let* ((tree (car l)) (tree-width (augm-tree-width tree))) (declare (type fixnum tree-width)) (if (augm-tree-pad? tree) (progn (print-seq #\space tree-width stream) (print-loop2 (cdr l) (append new-trees (list tree)) delay-leaves? stream)) (let* ((root (augm-tree-root tree)) (name (augm-tree-name tree)) (name-width (field-width name)) (name-left (truncate name-width 2)) (name-right (- name-width name-left))) (declare (type fixnum root name-width name-left name-right)) (if (augm-tree-int-node? tree) (let ((children (augm-int-node-children tree))) (declare (type list children)) (if (null children) (progn (print-seq #\space (- root name-left) stream) (princ name stream) (print-seq #\space (- tree-width root name-right) stream) (print-loop2 (cdr l) (append new-trees (pad tree-width '())) delay-leaves? stream)) (let* ((child1 (car children)) (root1 (augm-tree-root child1)) (width1 (augm-tree-width child1)) (lpad (augm-int-node-lpad tree)) (rpad (augm-int-node-rpad tree))) (declare (type fixnum root1 width1)) (labels ((print-loop3 (l1 l2 right) (if (consp l1) (let* ((child (car l1)) (root (augm-tree-root child)) (width (augm-tree-width child))) (print-seq #\space (+ root tree-spacing right) stream) (if (cdr l1) (princ #\| stream) (princ #\\ stream) ;;(princ "\\ " stream) ) (print-loop3 (cdr l1) (cons child (pad tree-spacing l2)) (- width (+ root 1)))) (progn (print-seq #\space (+ right rpad) stream) (print-loop2 (cdr l) (append new-trees (reverse (pad rpad l2))) delay-leaves? stream))))) (print-seq #\space (+ lpad root1) stream) (if (cdr children) (princ #\/ stream) (princ #\|)) (print-loop3 (cdr children) (cons child1 (pad lpad '())) (- width1 (+ root1 1)) ))))) (if delay-leaves? (progn (print-seq #\space root stream) (princ #\| stream) (print-seq #\space (- tree-width root 1) stream) (print-loop2 (cdr l) (append new-trees (list tree)) delay-leaves? stream)) (let* ((info (augm-leaf-info tree)) (info-width (field-width info)) (info-left (truncate info-width 2)) (info-right (- info-width info-left))) (print-seq #\space (- root info-left) stream) (print-seq #\space info-width stream);(princ info stream) (print-seq #\space (- tree-width root info-right) stream) (print-loop2 (cdr l) (append new-trees (pad tree-width '())) delay-leaves? stream))))))) (when new-trees (princ " " stream) (print-next nil *print-indent* stream) (print-trees new-trees stream)))) (defun print-trees (trees stream) (if (not (all-done? trees)) (let ((delay-leaves? (and leaves-at-bottom? (any-int-nodes? trees)))) (print-loop1 trees delay-leaves? stream) ;; (terpri stream) (print-next nil *print-indent* stream) (print-loop2 trees '() delay-leaves? stream)))) #|| (defun show-tree (inp &optional (show-sort nil) (stream *standard-output*)) (let ((tree (if (term? inp) inp (setf $$term (simple-parse inp *current-module* *universal-sort*))))) (tree-display tree show-sort stream))) ||# ;;; EOF cafeobj-1.6.0/comlib/globals.lisp0000644000000000000000000005600213420023427015507 0ustar rootwheel;;;-*- Mode:LISP; Package:CHAOS; Base:10; Syntax:Common-lisp -*- ;;; ;;; Copyright (c) 2000-2018, Toshimi Sawada. All rights reserved. ;;; ;;; Redistribution and use in source and binary forms, with or without ;;; modification, are permitted provided that the following conditions ;;; are met: ;;; ;;; * Redistributions of source code must retain the above copyright ;;; notice, this list of conditions and the following disclaimer. ;;; ;;; * Redistributions in binary form must reproduce the above ;;; copyright notice, this list of conditions and the following ;;; disclaimer in the documentation and/or other materials ;;; provided with the distribution. ;;; ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ;;; (in-package :chaos) #|============================================================================== System: CHAOS Module: comlib File: globals.lisp ==============================================================================|# #-:chaos-debug (declaim (optimize (speed 3) (safety 0) #-GCL (debug 0))) #+:chaos-debug (declaim (optimize (speed 1) (safety 3) #-GCL (debug 3))) ;;; == DESCRIPTION ============================================================= ;;; This file gathers the declaration of global/special variables of CHAOS ;;; system. ;;; ;;;******************** ;;; RUNTIME ENVIRONMENT_________________________________________________________ ;;;******************** ;;; ;;; In Chaos, all of the works are done in a `context'. ;;; A context is a dag of modules with importation relation as arrows, ;;; the top node (module) is called `current module'. ;;; ;;; The current module and its some frequently accessed informations are ;;; bound to global variables providing run time environment. ;;; ;;; *current-module* : the current-module ;;; *current-sort-order* : transitive closure of sort relations of ;;; current-mdoule. ;;; *current-opinfo-table* : operator information table of the current-module. ;;; *current-ext-rule-table* : extented rules for A, and AC ;;; (declaim (special *current-module* ; the module currently the target of ; operations. *current-sort-order* ; closure of sort relations of current ; module. *current-opinfo-table* ; operator information table of the ; current module. *current-ext-rule-table* *top-level-definition-in-progress* *on-preparing-for-parsing* ; parsing preparation in progress )) (defvar *top-level-definition-in-progress* nil) ;;; *open-module* bounds the 'opening' module. ;;; (declaim (special *open-module* ; the module crrently opened. *last-before-open* ; the module which was *last* before the ; currently opened module. )) (defvar *current-module* nil) (defvar *current-sort-order* nil) (defvar *current-opinfo-table* nil) (defvar *current-ext-rule-table* nil) (defvar *open-module* nil) (defvar *last-before-open* nil) ;;; Feature for require & provide ;;; (defvar *chaos-features* nil) ;;; Some top level flags & variables.-------------------------------------------- (declaim (special *chaos-verbose* *chaos-quiet* *chaos-input-source*)) (defvar *chaos-verbose* nil) (defvar *chaos-quiet* nil) (defvar *chaos-input-source* nil) ; binds a file name when processing ; input from the file. (declaim (special *chaos-input-level*) (type fixnum *chaos-input-level* *chaos-input-nesting-limit*)) (defvar *chaos-input-level* 0) (defvar *chaos-input-nesting-limit* 10) (declaim (special *auto-context-change*)) (defvar *auto-context-change* nil) (defvar *system-prelude-dir* nil) (defvar *system-lib-dir* nil) (defvar *system-ex-dir* nil) ;;; *********************************** ;;; CONTROLL FLAGS OF REWRITING PROCESS_________________________________________ ;;; *********************************** (declaim (special *trace-level*)) (declaim (type (integer 0 256) *trace-level*)) (defvar *trace-level* 0) (declaim (special *self*)) (defvar *self* nil) (defvar $$cond nil) (defvar $$trace-rewrite nil) ; flag, non-nil -> trace. (defvar $$trace-rewrite-whole nil) ; flag, non-nil -> trace whole. (defvar $$trace-proof nil) ; flag, non-nil -> trace CITP proof. ;;; *proof-tree* binds current proof tree structure (defvar *proof-tree* nil) (defvar *next-default-proof-node* nil) (defvar *citp-verbose* nil) (defvar *citp-normalize-instance* t) (defvar *rewrite-stepping* nil) ; flag, non-nil -> under stepping. (declaim (type fixnum *rewrite-count-limit*)) (defvar *rewrite-count-limit* most-positive-fixnum) ; flag, non-nil(integer) -> limitation ; for rewriting steps. (defvar *rewrite-stop-pattern* nil) ; flag, non-nil(term) -> stop rewriting ; iff matches to the pattern. (defvar *steps-to-be-done* nil) ; remaining steps before stop (defvar $$mod 'void) ;;; (defvar *old-context* nil) (declaim (special *old-context*)) (declaim (special *allow-$$term*)) (defvar *allow-$$term* t) (defvar $$term 'void) ; current target term, destructively ; modified (defvar $$subterm nil) ; subterm of $$term selected (defvar $$term-context nil) ; context module of $$term (defvar $$selection-stack nil) (defvar $$action-stack nil) ;;; (defvar $$norm 'void) (defvar $$show-red nil) (defvar *perform-on-demand-reduction* t) (declaim (special *rewrite-exec-mode*)) (defvar *rewrite-exec-mode* nil) (declaim (special *cexec-target*)) (defvar *cexec-target* nil) (declaim (special *rewrite-exec-condition*)) (defvar *rewrite-exec-condition* nil) (declaim (special *rewrite-semantic-reduce*) (type (or null (not null)) *rewrite-semantic-reduce)) (defvar *rewrite-semantic-reduce* nil) (declaim (special *beh-rewrite*) (type (or null (not null)) *beh-rewrite*)) (defvar *beh-rewrite* nil) (declaim (type fixnum *rule-count*) (special *rule-count*)) (defvar *rule-count* 0) (defvar *show-stats* t) (defvar *try-try* nil) (defvar *reduce-conditions* nil) (declaim (type fixnum $$trials)) (defvar $$trials 1) (declaim (type fixnum $$matches) (special $$matches)) (defvar $$matches 0) (defvar *on-reduction* t) (defvar *reduce-builtin-eager* nil) (declaim (type fixnum *condition-trial-limit*)) (defparameter .condition-trial-limit-default. #+GCL 240 #-GCL 5500) (defvar *condition-trial-limit* .condition-trial-limit-default.) ;;; MEL support (defvar *mel-sort* nil) (defvar *mel-always* nil) ;;; (defvar *mel-reduce* nil) ;;; := (defvar *m-pattern-subst* nil) ;; memoization (defvar *memo-rewrite* t) ; use memo mechanism (defvar *clean-memo-in-normalize* t) (defvar *always-memo* nil) (declaim (special *term-memo-hash-hit*) (type fixnum *hash-hit*)) (defvar *term-memo-hash-hit* 0) (declaim (special .hash-size.) (type fixnum .hash-size.)) (defvar .hash-size. 0) (defvar *allow-illegal-beh-axiom* t) ;;;********************* ;;; REGULARIZING CONTROL_______________________________________________________ ;;;********************* (declaim (special *regularize-signature*)) (defvar *regularize-signature* nil) (defvar *check-regularity* nil) ;;;******************** ;;; COMPATIBILITY CHECK________________________________________________________ ;;;******************** (declaim (special *check-compatibility*)) (defvar *check-compatibility* nil) ;;;*************** ;;; SENSIBLE CHECK_____________________________________________________________ ;;;*************** (declaim (special *check-sensibleness*)) (defvar *check-sensibleness* nil) ;;;********** ;;; COHERENCY__________________________________________________________________ ;;;********** (declaim (special *check-rwl-coherency*)) (defvar *check-rwl-coherency* nil) ;;;************************** ;;; BUILTIN OVERLOADING CHECK__________________________________________________ ;;;************************** (declaim (special *builtin-overloading-check*)) (defvar *builtin-overloading-check* t) ;;; Flags for printer control._________________________________________________ ;;;*************************** (declaim (special *print-indent*)) (declaim (type fixnum *chaos-print-level* *print-line-limit* *chaos-print-length* *print-indent* *print-indent-increment*)) (defvar *module-all-rules-every* nil) (defvar *fancy-print* t) (defvar *print-term-struct* nil) (defvar *print-xmode* :normal) (defvar *show-mode* :cafeobj) ; one of :chaos or :cafeobj (defvar *print-indent* 0) (defparameter *print-indent-increment* 1) (defvar *print-explicit* nil) ;if t then give more detail on sorts, etc. (defvar *print-abbrev-mod* nil) ; abbreviate module names (defvar *print-abbrev-num* 0) (defvar *print-abbrev-table* nil) (defvar *print-abbrev-quals* nil) (defvar *print-with-sort* nil) (defvar *print-operator-table* nil) (defvar *print-flag-module-values* nil) (defvar *print-indent-contin* nil) (defvar *print-line-limit* 2000) (defvar *print-mode* nil) (defvar *print-all-eqns* nil) (defvar *print-exec-rule* nil) (defvar *print-every-exec-finding* nil) (defvar *print-ignore-mods* nil) (defvar *chaos-print-level* 5) (defvar *chaos-print-length* 100) (defvar *chaos-print-errors* nil) (defvar *chaos-input-quiet* nil) (defvar *print-variables* nil) (defvar *grind-bool-term* nil) (declaim (special .file-col.) (type fixnum .file-col.)) (defvar .file-col. 0) (declaim (type (or null fixnum) *term-print-depth*)) (defvar *term-print-depth* nil) (defvar *show-tree-horizontal* nil) ;;; CafeOBJ variables (defvar *cafeobj-batch* nil) (defvar *cafeobj-input-quiet* nil) (defvar $) (defvar -cafeobj-load-time- nil) (defvar *cafeobj-standard-prelude-path* nil) ;;; NOT USED ;;; GRAMMAR ;;; ;;; *GRM.CURRENT* is a grammar to which the following operations are to be applied. ;;; define.grm-rule ;;; grm.clear-rule ;;; set by 'in.grammar' operation. ;;; ;;;(defvar *grm.current* nil) ;;; *CHAOS.CURRENT-GRAMMAR* is a list of grammar with which the `grm.parse' works. ;;; set by 'use.grammar' operation. (see "term-parser.lisp") ;;; ;;; (defvar *chaos.current-grammar* nil) ;;; ERROR TAGS ---------------------------------------------------------------- ;;; (defvar *module-not-found-error* 'Module-Not-found) ;;; (defvar *sort-not-found-error* 'sort-not-found) ;;; (defvar *operator-not-found-error* 'operator-not-found) ;;; ;;;============================================================================= ;;; BUILTIN SORTS ;;;============================================================================= ;; NAMES of Builtin sort. (defconstant $name-sort '|*Sort*|) (defconstant $name-gen-sort '|_ GeneralSort _|) (defconstant $name-bi-sort '|*BuiltinSort*|) (defconstant $name-identifier '|*Identifier*|) (defconstant $name-cosmos '|*Cosmos*|) (defconstant $name-universal '|*Universal*|) (defconstant $name-huniversal '|*HUniversal*|) (defconstant $name-term '|*Term*|) (defconstant $name-bottom '|_ Bottom _|) (defconstant $name-hbottom '|_ HBottom _|) (defconstant $name-record '|_ Record _|) (defconstant $name-class '|_ Class _|) (defconstant $name-and-sort '|_ ^-Sort _|) (defconstant $name-or-sort '|_ \|-Sort _|) (defconstant $name-err-sort '|_ ?-Sort _|) (defconstant $name-operator '|*Operator*|) (defconstant $name-optheory '|*OpTheory*|) (defconstant $name-module '|*Module*|) (defconstant $name-signature '|*Signature*|) (defconstant $name-axiomset '|*AxiomSet*|) (defconstant $name-trs '|*Trs*|) (defconstant $name-axiom '|*Axiom*|) (defconstant $name-chaos-object '|*ChaosObject*|) (defconstant $name-chaos-expr '|*CafeExpr*|) (defconstant $name-term-type '|*TermType*|) (defconstant $name-chaos-list '|*CafeList*|) (defconstant $name-void '|*Void*|) (defconstant $name-import '|*Import*|) (defconstant $name-subst '|*Substitution*|) (defconstant $name-parameter '|*Parameter*|) ;;; builtin sorts (defvar *cosmos* 'void) ; the whole (defvar *chaos-object* 'void) (defvar *chaos-expr-sort* 'void) (defvar *term-sort* 'void) (defvar *universal-sort* 'void) ; visible universe (defvar *huniversal-sort* 'void) ; hidden universe (defvar *bottom-sort* 'void) ; visible bottom sort (defvar *hbottom-sort* 'void) ; hidden bottom sort (defvar *sort-sort* 'void) (defvar *general-sort* 'void) (defvar *builtin-sort* 'void) (defvar *identifier-sort* 'void) (defvar *id-sort* 'void) (defvar *qid-sort* 'void) (defvar *syntax-err-sort* 'void) (defvar *type-err-sort* 'void) (defvar *op-err-sort* 'void) (defvar *and-sort* 'void) (defvar *or-sort* 'void) (defvar *err-sort* 'void) (defvar *sort-error* 'none) (defvar *record-sort* 'void) (defvar *class-sort* 'void) (defvar *operator-sort* 'void) (defvar *optheory-sort* 'void) (defvar *module-sort* 'void) (defvar *import-sort* 'void) (defvar *signature-sort* 'void) (defvar *axiomset-sort* 'void) (defvar *trs-sort* 'void) (defvar *variable-sort* 'void) (defvar *appl-form-sort* 'void) (defvar *pvariable-sort* 'void) (defvar *lisp-term-sort* 'void) (defvar *slisp-term-sort* 'void) (defvar *glisp-term-sort* 'void) (defvar *bconst-term-sort* 'void) (defvar *modexpr-sort* 'void) (defvar *chaos-list-sort* 'void) (defvar *chaos-void-sort* 'void) (defvar *bool-sort* 'void) (defvar *sort-id-sort* 'void) (defvar *string-sort* 'void) (defvar *chaos-value-sort* 'void) (defvar *character-sort* 'void) (defvar *axiom-sort* 'void) (defvar *object-identifier-sort* 'void) (defvar *object-sort* 'void) (defvar *record-instance-sort* 'void) (defvar *class-id-sort* 'void) (defvar *record-id-sort* 'void) (defvar *attribute-id-sort* 'void) (defvar *attribute-sort* 'void) (defvar *attribute-list-sort* 'void) (defvar *attr-value-sort* 'void) (defvar *message-sort* 'void) (defvar *configuration-sort* 'void) (defvar *acz-configuration-sort* 'void) (defvar *subst-sort* 'void) (defvar *sort_builtin* 'void) (defvar *parameter-sort* 'void) (defvar *condition-sort* 'void) (defvar sup-universal-sort-name nil) (defvar sup-huniversal-sort-name nil) ;;;============================================================================= ;;; Builtin modules & operations. ;;; Operations in some builtin modules. ;;;============================================================================= (defvar *system-standard-prelude* nil) (defvar *system-soft-wired* nil) (defvar *kernel-hard-wired-builtin-modules* nil) ;;; *SYSTEM-MODULE* (defvar *system-module* nil) ;;; *CHAOS-MODULE* ;;; bounds built in module CHAOS. (defvar *chaos-meta* nil) (defvar *chaos-module* nil) (defvar *chaos-object-module* nil) (defvar *builtin-metalevel-sort* (make-hash-table)) ;;; (defvar *string-not-found* nil) ;;; *CHAOS-SORT-ORDER* holds the transitive closure of sort relations between ;;; builtin sorts. This is a value of slot 'sort-order' of builtin module ;;; CHAOS (buoud to global *chaos-module*). ;;; (defvar *chaos-sort-order* 'void) ;;; *PARSER-SORT-ORDER* (defvar *parser-sort-order* 'void) ;;; HARD-WIRED CHAOS MODULE (defvar *system-object-module* nil) (defvar *identifier-module* nil) (defvar *universal-module* nil) (defvar *parser-module* nil) (defvar *qid-module* nil) (defvar *id-module* nil) (defvar .int-module. nil) ;;; Some operators & methods of CHAOS module. ;;; these are used for representing builtin constant and ill-formed terms ;;; at parsing time. ;;; (defvar *builtin-method* nil) (defvar *builtin-op* nil) (defvar *partial-op* nil) (defvar *void-op* nil) (defvar *partial-method* nil) (defvar *void-method* nil) (defvar *type-err-op* nil) (defvar *type-err-method* nil) (defvar *op-err-op* nil) (defvar *op-err-method* nil) (defvar *op-term* nil) ;;; TRUTH, BOOL & IDENTICAL Module ;;;----------------------------------------------------------------------------- (defvar *TRUTH-VALUE-module* 'void) (defvar *TRUTH-module* 'void) (defvar *BOOL-module* 'void) (defvar *IDENTICAL-module* nil) (defvar *EQL-module* nil) (defvar *bootstrapping-bool* nil) ;;; basic operations in TRUTH & BOOL ;;;----------------------------------------------------------------------------- (defvar *bool-true* 'void) (defvar *bool-true-meth* 'void) (defvar *bool-false* 'void) (defvar *bool-false-meth* 'void) (defvar *bool-and* 'void) (defvar *bool-or* 'void) (defvar *bool-not* 'void) (defvar *sort-membership* 'void) (defvar *bool-if* 'void) (defvar *bool-imply* 'void) (defvar *bool-xor* 'void) (defvar *bool-equal* 'void) (defvar *bool-match* 'void) (defvar *beh-equal* 'void) (defvar *bool-nonequal* 'void) (defvar *beh-eq-pred* 'void) (defvar *bool-and-also* 'void) (defvar *bool-or-else* 'void) (defvar *bool-iff* 'void) (defvar *bool-cond-op* 'void) (defvar *eql-op* 'void) (defvar *m-and-op* nil) (defvar *m-or-op* nil) ;;; RWL ;;;----------------------------------------------------------------------------- (defvar *rwl-module* 'void) (defvar *rwl-nat-star-sort* 'void) (defvar *rwl-predicate* 'void) (defvar *rwl-predicate2* 'void) ;;; search command related (defvar .rwl-sch-context. nil) (defvar .rwl-context-stack. nil) (declaim (type fixnum .rwl-states-so-far.)) (defvar .rwl-states-so-far. 0) (defvar *rwl-search-no-state-report* nil) ;;; basic operations in IDENTICAL. ;;;----------------------------------------------------------------------------- (defvar *identical* 'void) (defvar *nonidentical* 'void) ;;; constructors for record, object, attribute list. ;;;----------------------------------------------------------------------------- (defvar *attribute-constructor* nil) (defvar *attribute-list-constructor* nil) (defvar *attribute-list-aux-variable* nil) (defvar *object-reference-method* nil) (defvar *object-constructor-method* nil) (defvar *object-constructor-op* nil) (defvar *record-constructor-method* nil) (defvar *record-constructor-op* nil) (defvar *void-object* nil) (defvar *void-record* nil) ;;; *************** ;;; READER & PARSER_____________________________________________________________ ;;; *************** (declaim (special *parse-variables* *fill-rc-attribute* *lhs-attrid-vars* *parsing-axiom-lhs* *parse-lhs-attr-vars*)) ; binds variables during a parsing ; process. (declaim (special *reader-schema-env* ; current schema. *reader-input* ; current token sequence. )) (declaim (special *macroexpand*)) ; expand macro if t (defvar *fill-rc-attribute* nil) ; a flag, t if requires generalizing the ; pattern of record/object terms. (defvar *parsing-axiom-lhs* nil) (defvar *parse-lhs-attr-vars* nil) (defvar *lhs-attrid-vars* nil) ;;; (defparameter .lisp-start-symbol. #\#) (defvar *parse-variables* nil) (defconstant parser-min-precedence 0) (defconstant parser-max-precedence 127) (defvar *reader-schema-env* nil) (defvar *reader-current-schema* nil) (defvar *reader-current-context* nil) (defvar *reader-starting-position* nil) (defvar *builtin-ast-dict* (make-hash-table :test #'equal)) ;;; (defvar *parse-normalize* nil) ;;; if t, expand macros at parsing time. ;;; (defvar *macroexpand* t) ;;; ********* ;;; MISC VARS___________________________________________________________________ ;;; ********* ;;; *INCLUDE-BOOL* (defvar *include-bool* t) (defvar *include-bool-save*) ;;; *INCLUDE-RWTL" (defvar *include-rwl* t) ;;; *INCLUDE-FOPL* (defvar *include-fopl* t) ;;; (defvar *compile-lisp-rhs* t) (defvar *running-with-tk* nil) (defvar *sub-prompt* nil) (defvar *no-prompt* nil) (defvar *consider-object* nil) (defvar *auto-reconstruct* nil) ;;; *SAVE-DEFINITION* (defvar *save-definition* t) ;;; *MODMORPH-NEW-MODULE* (declaim (special *modmorph-new-module*)) (defvar *modmorph-new-module* nil) ;;; TIMEZOE (defvar *time-zone* -9) ;;; if true, top level command interpreter accept terms in current context ;;; and evaluate (reduce) it. (defvar *allow-general-term-input* t) ;;; LIBRARY PATH (defvar *chaos-libpath* nil) ;;; (declaim (special *beh-proof-in-progress*)) (defvar *beh-proof-in-progress* nil) ;;; USER DEFINED BOOL (defvar *user-bool* nil) ;;; TRAM (defvar *tram-path* "tram") (defvar *tram-options* "") (defvar *tram-builtin-modules*) (defvar *tram-bool-modules*) ;;; EXEC (declaim (type fixnum *cexec-limit*)) (defvar *cexec-limit* most-positive-fixnum) (declaim (type (or null (not null)) *cexec-trace* *cexec-normalize*)) (defvar *cexec-trace* nil) (defvar *cexec-normalize* t) (defvar *cexec-find-all-solutions* t) ;;; BUTILTIN (defvar *compile-builtin-axiom* nil) (defvar *bi-universal-operators* nil) ;;; OPEN/CLOSE WORLD -- not used. ;;; (declaim (special *closed-world*)) ;; (defvar *closed-world* nil) ;;; ALLOW-UNIVERSAL-SORT ;;; t iff user refers to universal sorts, ;;; i.e., Universal, HUniversal, and Cosmos ;;; (defvar *allow-universal-sort* nil) ;;; AUTOLOAD (defvar *autoload-alist* nil) ;;; PARSER SETTINGS (defvar *select-ambig-term* nil) ;;; if true accept system's congruency proof of operator =*= (defvar *accept-system-proof* nil) ;;; find command control (defvar *find-all-rules* nil) ;;; DEVELOPMENT MODE (defvar *development-mode* nil) ;;; NO ID COMPLETION (defvar *no-id-completion* nil) ;;; DEBUG FLAGS (defvar *rewrite-debug* nil) (defvar *on-term-hash-debug* nil) (defvar *on-axiom-debug* nil) (defvar *beh-debug* nil) (defvar *gen-rule-debug* nil) (defvar *on-change-debug* nil) (defvar *on-operator-debug* nil) (defvar *on-sort-debug* nil) (defvar *on-trs-debug* nil) (defvar *on-import-debug* nil) (defvar *on-modexp-debug* nil) (defvar *on-view-debug* nil) (defvar *match-debug* nil) (defvar *module-dep-debug* nil) (defvar *term-debug* nil) (defvar *on-parse-debug* nil) (defvar *regularize-debug* nil) (defvar *on-tram-debug* nil) (defvar *mel-debug* nil) (defvar *check-import-mode* nil) (defvar *cexec-debug* nil) (defvar *debug-meta* nil) (defvar *debug-citp* nil) (defvar *debug-print* nil) (defvar *debug-bterm* nil) ;;; ;;; ** TO DO for other platforms #+SBCL (proclaim '(SB-EXT:DISABLE-PACKAGE-LOCKS 'SB-INT:TOPLEVEL-CATCHER)) (defvar *top-level-tag* #+KCL si::*quit-tag* #+CMU 'common-lisp::top-level-catcher #+EXCL 'top-level::top-level-break-loop #+(or LUCID :CCL) '(*quit-tag*) #+CLISP 'system::debug #+SBCL 'SB-INT:TOPLEVEL-CATCHER) ;;; EOF cafeobj-1.6.0/comlib/error.lisp0000644000000000000000000001220613373141170015216 0ustar rootwheel;;;-*- Mode:LISP; Package:CHAOS; Base:10; Syntax:Common-lisp -*- ;;; ;;; Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. ;;; ;;; Redistribution and use in source and binary forms, with or without ;;; modification, are permitted provided that the following conditions ;;; are met: ;;; ;;; * Redistributions of source code must retain the above copyright ;;; notice, this list of conditions and the following disclaimer. ;;; ;;; * Redistributions in binary form must reproduce the above ;;; copyright notice, this list of conditions and the following ;;; disclaimer in the documentation and/or other materials ;;; provided with the distribution. ;;; ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ;;; (in-package :chaos) #|============================================================================== System: CHAOS Module: comlib File: error.lisp ==============================================================================|# #-:chaos-debug (declaim (optimize (speed 3) (safety 0) #-GCL (debug 0))) #+:chaos-debug (declaim (optimize (speed 1) (safety 3) #-GCL (debug 3))) ;;; ********************* ;;; STANDRD ERROR HANDLER ;;; ********************* ;;; - catches tag 'chaos-main-error ;;; ;;; << IMPORTANT ASSUMPTION >> ;;; - every chaos AST evaluators report errors by themselves ;;; and then call 'chaos-error with non-nil value. ;;; << SHOULD >> ;;; - users should do anything with-in a body of `with-chaos-error' or ;;; catch 'chaos-main-error by themselves. ;;; (declaim (special *suppress-err-handler-msg*)) (defvar *suppress-err-handler-msg* nil) ;;; SIGNAL STANDRD ERROR ;;; (defun chaos-error (err-value) (flush-all) (throw 'chaos-main-error err-value)) ;;; HANDLER ;;; (defun chaos-exit-with-error-code (value) (let ((exit-status 1)) (if (symbolp value) (format t "~%** Exiting CafeOBJ due to ~s~%" value) (setq exit-status 2)) #+:sbcl (sb-ext:exit :code exit-status) #+:allegro (excl:exit exit-status) #-(or :sbcl :allegro) (bye-bye-bye) )) (defun get-chaos-error-proc (val) (if *cafeobj-batch* 'chaos-exit-with-error-code (if (symbolp val) (get val ':chaos-error-handler) nil))) (defmacro with-chaos-error ((&optional error-proc) &body body) (if error-proc `(let ((ret-val nil)) (let ((val (catch 'chaos-main-error (setq ret-val (progn ,@body)) nil))) (if val (funcall ,error-proc val) ret-val))) `(let ((ret-val nil)) (let ((val (catch 'chaos-main-error (setq ret-val (progn ,@body)) nil))) (if val (let ((std-proc (get-chaos-error-proc val))) (if std-proc (funcall std-proc val) (chaos-to-top))) ret-val))))) (defun chaos-indicate-position () (unless *suppress-err-handler-msg* (when *chaos-input-source* ; nil means may be from terminal (format t "~%filename: ~a" (namestring *chaos-input-source*)) (when (file-position *standard-input*) (format t " in top-level form ending at character position: ~d" (file-position *standard-input*))) (terpri)))) (defun chaos-to-top (&rest ignore) (declare (ignore ignore)) (fresh-line) (chaos-indicate-position) (unless *suppress-err-handler-msg* (format t "~%** returning to top level~%")) (throw 'chaos-top-level-error t)) (defmacro with-chaos-top-error ((&optional error-proc) &body body) (if error-proc `(let ((ret-val nil)) (let ((val (catch 'chaos-top-level-error (setq ret-val (progn ,@body)) nil))) (if val (funcall ,error-proc val) ret-val))) `(let ((ret-val nil)) (let ((val (catch 'chaos-top-level-error (setq ret-val (progn ,@body)) nil))) (if val (let ((std-proc (get-chaos-error-proc val))) (if std-proc (funcall std-proc val) ;; we assume no more error handlers. nil)) ret-val))))) (defmacro ignoring-chaos-error (&body body) ` (catch 'chaos-top-level-error (catch 'chaos-main-error ,@body))) ;;; EOF cafeobj-1.6.0/comlib/print-utils.lisp0000644000000000000000000002113213373141170016355 0ustar rootwheel;;;-*- Mode:LISP; Package:CHAOS; Base:10; Syntax:Common-lisp -*- ;;; ;;; Copyright (c) 2000-2018, Toshimi Sawada. All rights reserved. ;;; ;;; Redistribution and use in source and binary forms, with or without ;;; modification, are permitted provided that the following conditions ;;; are met: ;;; ;;; * Redistributions of source code must retain the above copyright ;;; notice, this list of conditions and the following disclaimer. ;;; ;;; * Redistributions in binary form must reproduce the above ;;; copyright notice, this list of conditions and the following ;;; disclaimer in the documentation and/or other materials ;;; provided with the distribution. ;;; ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ;;; (in-package :chaos) #|============================================================================== System: CHAOS Module: comlib File: print-utils.lisp =============================================================================|# #-:chaos-debug (declaim (optimize (speed 3) (safety 0) #-GCL (debug 0))) #+:chaos-debug (declaim (optimize (speed 1) (safety 3) #-GCL (debug 3))) ;;;----------------------------------------------------------------------------- ;;; Utilities for printing ;;;----------------------------------------------------------------------------- ;;; PRINT CONTROL VARIABLES 00-------------------------------------------------- ;;; *print-line-limit* : the limit of length of a line ;;; *print-indent* : current indent level. ;;; *print-indent-increment* : number of spaces per one indentation. ;;; ;;; FILECOL -- output column position ;;; (declaim (inline filecol) (ftype (function (t) fixnum) filecol)) #+GCL (Clines "static object filecol(x) object x; {return(make_fixnum(file_column(x)));}") #+GCL (defentry filecol (object) (object filecol)) #+LUCID (defun filecol (x) (declare (values fixnum)) (lucid::calculate-output-column x)) #+CMU (defun filecol (x) (declare (values fixnum)) (let ((val (lisp::charpos x))) (if val val 0))) #+EXCL (defun filecol (x) (declare (values fixnum)) (let ((val (excl::charpos x))) (if val val 0))) #+:openmcl (defun filecol (x) (declare (values fixnum)) (stream-line-column x)) #+:SBCL (defun filecol (x) (declare (values fixnum)) (let ((val (sb-kernel::charpos x))) (if val val 0))) #-(or GCL KCL LUCID CMU EXCL :openmcl SBCL) (defun filecol (x) (declare (ignore x)) 0) ; use this if you cannot define as (declaim (ftype (function (stream) fixnum) file-column)) (defun file-column (strm) (declare (type stream strm) (inline filecol) (values fixnum)) (filecol strm)) ;;; print-check ;;; checks the current column exceeds the line limit, if so ;;; newline and indent. ;;; (defun print-check (&optional (indent 0) (fwd 0) (stream *standard-output*)) (declare (type fixnum indent fwd)) (if (<= *print-line-limit* (+ (file-column stream) fwd)) (progn (print-next) (when (>= (1+ indent) *print-line-limit*) (setq .file-col. (* *print-indent* *print-indent-increment*))) t) nil)) ;;; print-indent ;;; indentation. ;;; (defun print-indent (indent-char &optional (n *print-indent*) (stream *standard-output*)) (declare (type fixnum n)) (dotimes (i (the fixnum (* n *print-indent-increment*))) (declare (type fixnum i)) (princ indent-char stream))) ;;; print-centering ;;; print the given string centering ;;; (defconstant .terminal-width. 70) (defun print-centering (string &optional (fill-char " ") (stream *standard-output*)) (declare (type simple-string string)) (let ((fill-col (truncate (+ (/ (- .terminal-width. (the fixnum (length string))) 2.0) 0.5)))) (declare (type fixnum fill-col)) (dotimes (x fill-col) (declare (type fixnum x)) (princ fill-char stream)) (princ string stream) (unless (equal fill-char " ") (dotimes (x fill-col) (declare (type fixnum x)) (princ fill-char stream))))) ;;; print-to-right ;;; print the given string ;;; (defun print-to-right (string &optional (fill-char " ") (stream *standard-output*)) (declare (type simple-string string) (type (or character simple-string) fill-char) (type stream stream)) (dotimes (x (- (1- .terminal-width.) (filecol stream) *print-indent* (the fixnum (length string)))) (declare (type fixnum x)) (princ fill-char stream)) (princ " " stream) (princ string stream)) ;;; print-to-left ;;; print the given string ;;; (defun print-to-left (string &optional (fill-char nil) (stream *standard-output*)) (declare (type simple-string string) (type (or null character simple-string) fill-char) (type stream stream)) (let ((*print-line-limit* .terminal-width.)) (princ string stream) (princ " " stream) (if fill-char (dotimes (x (- (1- *print-line-limit*) *print-indent* (filecol stream) (length string))) (declare (type fixnum x)) (princ fill-char stream))))) ;;; print-next ;;; print new-line iff the current column is not at the beggining of line ;;; and then indent. given prefix is printed afer the indentation if any. ;;; (defun print-next (&optional (prefix nil) (n *print-indent*) (stream *standard-output*)) (declare (type fixnum n) (type stream stream)) #+SBCL (progn (terpri stream) (print-indent #\space n stream)) #-SBCL (when (fresh-line stream) (print-indent #\space n stream)) (when prefix (princ prefix stream))) (defun print-next-prefix (prefix-char &optional (prefix nil) (n *print-indent*) (stream *standard-output*)) (declare (type fixnum n) (type stream stream) (type character prefix-char)) (when (fresh-line stream) (print-indent prefix-char n stream)) (when prefix (princ prefix stream))) ;;; print-simple ;;; (defun print-simple (x &optional (stream *standard-output*)) (declare (type stream stream)) (cond ((atom x) (prin1 x stream)) (t (let ((flag nil) (tail x)) (princ "(" stream) (loop (when (not (consp tail)) (return)) (if flag (princ " " stream) (setq flag t)) (print-simple (car tail) stream) (setq tail (cdr tail))) (when tail (princ " . " stream) (prin1 tail stream)) (princ ")" stream))))) ;;; print-simple-princ ;;; (defun print-simple-princ (x &optional (stream *standard-output*)) (declare (type stream stream)) (let ((.file-col. .file-col.)) (cond ((atom x) (princ x stream)) (t (let ((flag nil) (tail x)) (princ "(" stream) (setq .file-col. (1+ (file-column stream))) (loop (when (not (consp tail)) (return)) (if flag (princ " " stream) (setq flag t)) (print-simple-princ (car tail) stream) (setq tail (cdr tail))) (when tail (princ " . " stream) (prin1 tail stream)) (princ ")" stream)))))) ;;; print-simple-princ-open ;;; (defun print-simple-princ-open (x &optional (stream *standard-output*)) (declare (type stream stream)) (let ((.file-col. .file-col.)) (print-check .file-col. 0 stream) (cond ((atom x) (princ x stream)) (t (let ((flag nil) (tail x)) (loop (when (not (consp tail)) (return)) (if flag (princ #\space stream) (setq flag t)) (print-simple-princ (car tail) stream) (setq tail (cdr tail))) (when tail (princ " ... " stream) (prin1 tail stream))))))) ;;; EOF cafeobj-1.6.0/comlib/fsys.lisp0000755000000000000000000004632513373141170015065 0ustar rootwheel;;;-*- Mode:Lisp; Syntax:Common-Lisp; Package:CHAOS -*- ;;; ;;; Copyright (c) 2000-2018, Toshimi Sawada. All rights reserved. ;;; ;;; Redistribution and use in source and binary forms, with or without ;;; modification, are permitted provided that the following conditions ;;; are met: ;;; ;;; * Redistributions of source code must retain the above copyright ;;; notice, this list of conditions and the following disclaimer. ;;; ;;; * Redistributions in binary form must reproduce the above ;;; copyright notice, this list of conditions and the following ;;; disclaimer in the documentation and/or other materials ;;; provided with the distribution. ;;; ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ;;; (in-package :CHAOS) #|============================================================================== System: Chaos Module: comlib File: fsys.lisp ==============================================================================|# #-:chaos-debug (declaim (optimize (speed 3) (safety 0) #-GCL (debug 0))) #+:chaos-debug (declaim (optimize (speed 1) (safety 3) #-GCL (debug 3))) #+:SBCL (eval-when (:compile-toplevel :load-toplevel :execute) (require 'sb-posix)) ;;; ***************** ;;; FILE SYSTEM UTILS___________________________________________________________ ;;; ***************** ;;; LOAD-FILE : filename ;;; UNIX dependent. (defun load-file (fname) (declare (type simple-string fname) (values t)) (when (and (eql #\~ (char fname 0)) (eql #\/ (char fname 1))) (setq fname (concatenate 'string (namestring (user-homedir-pathname)) (subseq fname 2)))) (load fname)) #-GCL (declaim (ftype (function ((or simple-string pathname)) simple-string) expand-file-name)) (defun expand-file-name (fname) (declare (type (or simple-string pathname) fname) (values simple-string)) (if (pathnamep fname) (namestring fname) (progn (setq fname (namestring fname)) (if (equal "~" fname) (namestring (user-homedir-pathname)) (if (and (eql #\~ (char fname 0)) (eql #\/ (char fname 1))) (concatenate 'string (namestring (user-homedir-pathname)) (subseq fname 2)) fname))))) ;;; DOFILE ;;; Opens the specified file for input, reads successive lines ;;; from the file, setting the specified variable to ;;; each line. When end of file is reached, the value of ;;; is returned. (defmacro dofile ((var filename &optional return-form) &body body) (let ((eof (gensym "EOF")) (stream (gensym "STREAM"))) `(with-open-file (,stream ,filename :direction :input) (do ((,var (read-line ,stream nil ,eof) (read-line ,stream nil ,eof))) ((eq ,var ,eof) ,return-form) ,@body)))) ;;; ;;; IS-DIRECTORY? path -> (or null pathname) ;;; (defun is-directory? (path) (declare (type (or pathname simple-string) path)) (let ((dpath (expand-file-name path))) #+(or GCL CMU :openmcl) (probe-file (concatenate 'string dpath "/")) #+:SBCL (let* ((p (probe-file dpath)) (nstr (if p (namestring p) ""))) (declare (type simple-string nstr)) (if (and p (string-equal (subseq nstr (1- (length nstr))) ;; sbcl uses "/" on all platforms. "/")) p nil)) #+:Allegro (if (excl:file-directory-p dpath) #-:mswindows (pathname (concatenate 'string dpath "/")) #+:mswindows (pathname dpath) nil) #+(and :CCL (not :openmcl)) (if (directoryp dpath) dpath nil) #+:CLISP (let ((p (concatenate 'string dpath "/"))) (if (directory p) ;; (ext:probe-directory path) p nil)))) (defun is-relative-file-name? (path) (declare (type (or simple-string pathname) path)) (let ((pn (if (pathnamep path) path (pathname path)))) (declare (type pathname pn)) (or (null (pathname-directory pn)) (member ':relative (pathname-directory pn) :test #'equal)))) (defun supply-suffixes (path suffixes) (declare (type (or simple-string pathname) path) (type list suffixes)) #+:SBCL (let ((pn (if (pathnamep path) (pathname-name path) path))) (declare (type simple-string pn)) (when (position #\. pn :from-end t) (return-from supply-suffixes (list path)))) (mapcar #'pathname (mapcar #'(lambda (x) (concatenate 'string (namestring path) (namestring x))) suffixes))) (defun chaos-get-relative-path (f-name) (declare (type simple-string f-name) (values pathname)) (flet ((chaos-relative-pathname? () (let ((fdp (pathname-directory (pathname f-name)))) (or (null fdp) (and fdp ; not simple file name. (not (eq (car (pathname-directory (pathname f-name))) :root)))))) (chaos-get-directory (file-path) (declare (type (or simple-string pathname))) (unless (pathnamep file-path) (setq file-path (pathname file-path))) (let ((dir-path (make-pathname :host (pathname-host file-path) :device (pathname-device file-path) :directory (pathname-directory file-path)))) dir-path))) (if (null *chaos-input-source*) (pathname f-name) (if (chaos-relative-pathname?) (let ((f-path nil)) (unwind-protect (let ((host (pathname-host (pathname f-name))) (device (pathname-device (pathname f-name))) (fd (pathname-directory (pathname f-name))) (f (file-namestring (pathname f-name)))) (chaos-pushd (chaos-get-directory *chaos-input-source*)) #+GCL (setq f-path (truename (make-pathname :directory fd :name f))) #+:CLISP (setq f-path (make-pathname :host host :device device :directory fd ;; (pathname fd) :name f)) #-(or GCL :CLISP) (progn (setq f-path (make-pathname :host host :device device :directory fd :name f)))) (chaos-popd)) f-path) ;; absolute path or simple filename. (pathname f-name))))) (defun chaos-probe-file (file load-path suffixes) (declare (type (or simple-string pathname) file) (type list load-path suffixes)) (when (pathnamep file) (if (is-directory? file) (return-from chaos-probe-file nil) (return-from chaos-probe-file (probe-file file)))) (let ((fp (expand-file-name file))) (declare (type simple-string fp)) (cond ((is-relative-file-name? fp) (let ((file-path (chaos-get-relative-path (concatenate 'string "./" fp))) (res nil)) (declare (type pathname file-path)) (setq res (probe-file file-path)) (when (and res (is-directory? res)) (setq res nil)) (unless res (dolist (fx (supply-suffixes file-path suffixes)) (when (and (probe-file fx) (not (is-directory? fx))) (setq res fx) (return))) ;; search through load paths (unless res (dolist (lpath load-path) (declare (type pathname lpath)) (let ((libdir (is-directory? lpath))) (declare (type (or null pathname) libdir)) (when libdir (let ((f (make-pathname :host (pathname-host libdir) :device (pathname-device libdir) :directory #+:CLISP libdir #-:CLISP (pathname-directory libdir) :name (namestring file)))) (declare (type pathname f)) (if (and (probe-file f) (not (is-directory? f))) (progn (setq res f) (return)) (let ((x (supply-suffixes f suffixes))) (dolist (fx x) (when (and (probe-file fx) (not (is-directory? fx))) (setq res fx) (return))))))))))) res)) (t (let ((file-path (chaos-get-relative-path file))) (declare (type pathname file-path)) (if (and (probe-file file-path) (not (is-directory? file-path))) file-path (dolist (fx (supply-suffixes file-path suffixes)) (when (and (probe-file fx) (not (is-directory? fx))) (return-from chaos-probe-file fx))))))))) (defun bare-chaos-pwd () #+GCL (probe-file ".") #+EXCL (excl::current-directory) #+CMU (ext:default-directory) #+:SBCL (car (directory "./")) #+:CCL (mac-default-directory) #+:CLISP (car (lisp:directory "./"))) (defun chaos-pwd () (declare (values simple-string)) (namestring (bare-chaos-pwd))) #+(or (and CCL (not :openmcl)) :microsoft) (defun chaos-ls (&optional (dir "**")) (pprint (mapcar #'(lambda (x) (file-namestring x)) (directory dir)))) #+(or GCL LUCID (and EXCL (not :microsoft)) CLISP :openmcl SBCL) (defun chaos-ls (&optional dir) (let ((comm '("ls")) (args (if (and dir (atom dir)) (list dir) dir))) (setq comm (reduce #'(lambda (x y) (concatenate 'string x " " y)) (append comm args))) #+GCL (system comm) #+EXCL (excl:shell comm) #+SBCL (apply #'sb-ext:run-program #+win32 "CMD" #-win32 "/bin/sh" #+win32 (list "/c" "dir") #-win32 (list "-c" comm) :input nil :output *terminal-io* #+win32 '(:search t) #-win32 nil) #+LUCID (lucid::%execute-system-command comm) #+CLISP (ext::shell comm))) #+(or CMU :openmcl) (defun chaos-ls (&optional args) (if (and args (atom args)) #+CMU (ext::run-program "ls" (list args) :output t) #+:openmcl (ccl::run-program "ls" (list args) :output t) #+CMU (if args (ext::run-program "ls" args :output t) (ext::run-program "ls" nil :output t) ) #+:penmcl (if args (ccl::run-program "ls" args :output t) (ccl::run-program "ls" nil :output t)))) (defvar *chaos-directory-stack* nil) (defun chaos-print-directory-stack (&optional (stream *standard-output*)) (format stream "~%~a" *chaos-directory-stack*)) (defun fsys-parse-number (tok) (declare (type (or simple-string pathname) tok)) (if (stringp tok) (let ((minusp nil)) (if (char= (char tok 0) #\-) (setq minusp t) (unless (char= (char tok 0) #\+) (return-from fsys-parse-number (values tok nil)))) (let ((num (read-from-string tok))) (if (numberp num) (values num minusp) (values tok nil)))) (values tok nil))) (defun chaos-pushd (arg &optional (always-return nil)) (let ((path arg)) (cond (arg (multiple-value-bind (num minusp) (fsys-parse-number arg) (cond ((numberp num) (let ((new-stack (rotate-list *chaos-directory-stack* num minusp))) (if new-stack (setq *chaos-directory-stack* new-stack) (with-output-chaos-warning () (format t "directory stack is not so deep.") (return-from chaos-pushd nil))) (setq path (car *chaos-directory-stack*)))) (t (push :dymmy *chaos-directory-stack*))) (if (chaos-cd path always-return) t (progn (pop *chaos-directory-stack*) nil)))) (t (if (<= (length *chaos-directory-stack*) 1) (with-output-chaos-warning () (format t "No other directory.") (return-from chaos-pushd nil)) (chaos-pushd "+1")))))) (defun chaos-popd (&optional num) (declare (ignore num)) (if (cdr *chaos-directory-stack*) (let ((xd nil)) (pop *chaos-directory-stack*) (setq xd (car *chaos-directory-stack*)) (chaos-cd xd)) ;; do nothing )) (defun chaos-cd (path &optional (always-return nil)) (let ((directory-path nil) (ng nil)) (unless path (setq path (user-homedir-pathname))) #+GCL (let ((si::*break-enable* nil)) (if (setq directory-path (is-directory? path)) (system:chdir directory-path) (setq ng t))) #+CMU (if (setq directory-path (is-directory? path)) (progn (lisp::%set-default-directory directory-path)) (setq ng t)) #+EXCL (if (setq directory-path (is-directory? path)) (excl::chdir directory-path) (setq ng t)) #+:openmcl (if (setq directory-path (is-directory? path)) (progn (ccl::%chdir (namestring directory-path))) (setq ng t)) #+SBCL (if (setq directory-path (is-directory? path)) (progn (setq *default-pathname-defaults* directory-path) (sb-posix:chdir directory-path)) (setq ng t)) #+(and :CCL (not :openmcl)) (if (setq directory-path (is-directory? path)) (set-mac-default-directory directory-path) (setq ng t)) #+:CLISP (if (setq directory-path (is-directory? path)) (setq *default-pathname-defaults* (ext:cd directory-path)) (setq ng t)) ;; (cond (ng (with-output-chaos-warning () (format t "directory \"~a\" not found." path)) (if always-return (return-from chaos-cd nil) (chaos-error 'no-such-directory))) (t (let ((cwd (chaos-pwd))) #|| #-CLISP (setq *default-pathname-defaults* cwd) #+CLISP ||# (setq *default-pathname-defaults* (pathname cwd)) (if *chaos-directory-stack* (setf (car *chaos-directory-stack*) *default-pathname-defaults*) (setf *chaos-directory-stack* (list *default-pathname-defaults*)))))) *default-pathname-defaults*)) (defparameter *chaos-binary-magic* ";CHAOS_BINS_____") (defun chaos-binary-file? (file) (with-open-file (*standard-input* file :direction :input) (let ((magic (read-line))) (equal magic *chaos-binary-magic*)))) (defparameter *chaos-bin-suffix* '(".bin")) (defun chaos-input-file (&key file ; input file name proc ; procedure load-path ; list of pathnames (suffix '(".cafe" ".mod")) args ; args to be passed to proc (errorp t) ; ) (let ((fname (chaos-probe-file file load-path suffix)) (bin-fname (chaos-probe-file file load-path *chaos-bin-suffix*))) (when (and fname (is-directory? fname)) (with-output-chaos-error ('invalid-file) (format t "~a is not a proper file." (namestring file))) (return-from chaos-input-file nil)) (unless (or fname bin-fname) (if errorp (with-output-chaos-error ('no-such-file) (format t "No such file: ~a" (namestring file))) (return-from chaos-input-file nil))) (when (and bin-fname fname (>= (file-write-date bin-fname) (file-write-date fname))) (setq fname bin-fname)) (unless fname (setq fname bin-fname)) (when (equal *chaos-input-source* fname) (return-from chaos-input-file t)) (let ((*chaos-input-source* fname) (*chaos-input-level* (1+ *chaos-input-level*))) (if (chaos-binary-file? fname) (progn (load fname) fname) (with-open-file (*standard-input* fname :direction :input) (when (< *chaos-input-nesting-limit* *chaos-input-level*) (with-output-chaos-warning () (format t "input nesting is ~d~%" *chaos-input-level*) (print-next) (princ "probable input loop (can increase *chaos-input-nesting-limit*)"))) (apply proc args) fname))))) ;;; (defun set-search-path (paths) (when (consp paths) (setq paths (car paths))) (let ((path nil)) (dolist (p (parse-with-delimiter paths #\:)) (push p path)) (setq *chaos-libpath* (nreverse path)))) (defun set-search-path-plus (paths) (when (consp paths) (setq paths (car paths))) (let ((path nil)) (dolist (p (parse-with-delimiter paths #\:)) (push p path)) (setq *chaos-libpath* (append (nreverse path) *chaos-libpath*)))) (defun set-search-path-minus (paths) (when (consp paths) (setq paths (car paths))) (let ((path nil)) (dolist (p (parse-with-delimiter paths #\:)) (push p path)) (dolist (p path) (if (not (member p *chaos-libpath* :test #'equal)) (with-output-chaos-warning () (format t "The path ~s is not in 'libpath'." p)) (setq *chaos-libpath* (remove p *chaos-libpath* :test #'equal)))) *chaos-libpath*)) (defun pr-search-path (&optional (stream *standard-output*)) (format stream "libpath = ~{~a~^:~}" *chaos-libpath*)) ;;; ;;; INITIALIZATION ;;; (defun chaos-initialize-fsys () ;; any other? (setq *chaos-directory-stack* nil) (push (setq *default-pathname-defaults* (bare-chaos-pwd)) *chaos-directory-stack*) ;; very old stuff #+(and :ccl (not :openmcl)) (progn (setq *default-pathname-defaults* (full-pathname (mac-default-directory))) (set-mac-default-directory *default-pathname-defaults*))) ;;; EOF cafeobj-1.6.0/comlib/let-over-lambda.lisp0000644000000000000000000003642713373141170017053 0ustar rootwheel;;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: LET-OVER-LAMBDA; Base: 10 -*- file: let-over-lambda.lisp ;; (in-package #:let-over-lambda) (in-package :chaos) ;; Antiweb (C) Doug Hoyte ;; This is a "production" version of LOL with bug-fixes ;; and new features in the spirit of the book. ;; See http://letoverlambda.com ;; This is the source code for the book ;; _Let_Over_Lambda_ by Doug Hoyte. ;; This code is (C) 2002-2008, Doug Hoyte. ;; ;; You are free to use, modify, and re-distribute ;; this code however you want, except that any ;; modifications must be clearly indicated before ;; re-distribution. There is no warranty, ;; expressed nor implied. ;; ;; Attribution of this code to me, Doug Hoyte, is ;; appreciated but not necessary. If you find the ;; code useful, or would like documentation, ;; please consider buying the book! ;; Safety feature for SBCL>=v1.2.2 #+sbcl (if (string-lessp (lisp-implementation-version) "1.2.2") (pushnew :safe-sbcl *features*) (setq *features* (remove :safe-sbcl *features*))) (defun group (source n) (if (zerop n) (error "zero length")) (labels ((rec (source acc) (let ((rest (nthcdr n source))) (if (consp rest) (rec rest (cons (subseq source 0 n) acc)) (nreverse (cons source acc)))))) (if source (rec source nil) nil))) (eval-when (:compile-toplevel :execute :load-toplevel) (defun mkstr (&rest args) (with-output-to-string (s) (dolist (a args) (princ a s)))) (defun symb (&rest args) (values (intern (apply #'mkstr args)))) (defun flatten (x) (labels ((rec (x acc) (cond ((null x) acc) #+(and sbcl (not safe-sbcl)) ((typep x 'sb-impl::comma) (rec (sb-impl::comma-expr x) acc)) ((atom x) (cons x acc)) (t (rec (car x) (rec (cdr x) acc)))))) (rec x nil))) (defun g!-symbol-p (s) (and (symbolp s) (> (length (symbol-name s)) 2) (string= (symbol-name s) "G!" :start1 0 :end1 2))) (defun o!-symbol-p (s) (and (symbolp s) (> (length (symbol-name s)) 2) (string= (symbol-name s) "O!" :start1 0 :end1 2))) (defun o!-symbol-to-g!-symbol (s) (symb "G!" (subseq (symbol-name s) 2)))) (defmacro defmacro/g! (name args &rest body) (let ((syms (remove-duplicates (remove-if-not #'g!-symbol-p (flatten body))))) `(defmacro ,name ,args (let ,(mapcar (lambda (s) `(,s (gensym ,(subseq (symbol-name s) 2)))) syms) ,@body)))) (defmacro defmacro! (name args &rest body) (let* ((os (remove-if-not #'o!-symbol-p args)) (gs (mapcar #'o!-symbol-to-g!-symbol os))) `(defmacro/g! ,name ,args `(let ,(mapcar #'list (list ,@gs) (list ,@os)) ,(progn ,@body))))) ;; Nestable suggestion from Daniel Herring (defun |#"-reader| (stream sub-char numarg) (declare (ignore sub-char numarg)) (let (chars (state 'normal) (depth 1)) (loop do (let ((curr (read-char stream))) (cond ((eq state 'normal) (cond ((char= curr #\#) (push #\# chars) (setq state 'read-sharp)) ((char= curr #\") (setq state 'read-quote)) (t (push curr chars)))) ((eq state 'read-sharp) (cond ((char= curr #\") (push #\" chars) (incf depth) (setq state 'normal)) (t (push curr chars) (setq state 'normal)))) ((eq state 'read-quote) (cond ((char= curr #\#) (decf depth) (if (zerop depth) (return)) (push #\" chars) (push #\# chars) (setq state 'normal)) (t (push #\" chars) (if (char= curr #\") (setq state 'read-quote) (progn (push curr chars) (setq state 'normal))))))))) (coerce (nreverse chars) 'string))) (set-dispatch-macro-character #\# #\" #'|#"-reader|) ; This version is from Martin Dirichs (defun |#>-reader| (stream sub-char numarg) (declare (ignore sub-char numarg)) (let (chars) (do ((curr (read-char stream) (read-char stream))) ((char= #\newline curr)) (push curr chars)) (let ((pattern (nreverse chars)) output) (labels ((match (pos chars) (if (null chars) pos (if (char= (nth pos pattern) (car chars)) (match (1+ pos) (cdr chars)) (match 0 (cdr (append (subseq pattern 0 pos) chars))))))) (do (curr (pos 0)) ((= pos (length pattern))) (setf curr (read-char stream) pos (match pos (list curr))) (push curr output)) (coerce (nreverse (nthcdr (length pattern) output)) 'string))))) (set-dispatch-macro-character #\# #\> #'|#>-reader|) (defun segment-reader (stream ch n) (if (> n 0) (let ((chars)) (do ((curr (read-char stream) (read-char stream))) ((char= ch curr)) (push curr chars)) (cons (coerce (nreverse chars) 'string) (segment-reader stream ch (- n 1)))))) #+cl-ppcre (defmacro! match-mode-ppcre-lambda-form (o!args o!mods) ``(lambda (,',g!str) (cl-ppcre:scan ,(if (zerop (length ,g!mods)) (car ,g!args) (format nil "(?~a)~a" ,g!mods (car ,g!args))) ,',g!str))) #+cl-ppcre (defmacro! subst-mode-ppcre-lambda-form (o!args) ``(lambda (,',g!str) (cl-ppcre:regex-replace-all ,(car ,g!args) ,',g!str ,(cadr ,g!args)))) #+cl-ppcre (defun |#~-reader| (stream sub-char numarg) (declare (ignore sub-char numarg)) (let ((mode-char (read-char stream))) (cond ((char= mode-char #\m) (match-mode-ppcre-lambda-form (segment-reader stream (read-char stream) 1) (coerce (loop for c = (read-char stream) while (alpha-char-p c) collect c finally (unread-char c stream)) 'string))) ((char= mode-char #\s) (subst-mode-ppcre-lambda-form (segment-reader stream (read-char stream) 2))) (t (error "Unknown #~~ mode character"))))) #+cl-ppcre (set-dispatch-macro-character #\# #\~ #'|#~-reader|) (defmacro! dlambda (&rest ds) `(lambda (&rest ,g!args) (case (car ,g!args) ,@(mapcar (lambda (d) `(,(if (eq t (car d)) t (list (car d))) (apply (lambda ,@(cdr d)) ,(if (eq t (car d)) g!args `(cdr ,g!args))))) ds)))) ;; Graham's alambda (defmacro alambda (parms &body body) `(labels ((self ,parms ,@body)) #'self)) ;; Graham's aif (defmacro aif (test then &optional else) `(let ((it ,test)) (if it ,then ,else))) (eval-when (:compile-toplevel :execute :load-toplevel) (defun |#`-reader| (stream sub-char numarg) (declare (ignore sub-char)) (unless numarg (setq numarg 1)) `(lambda ,(loop for i from 1 to numarg collect (symb 'a i)) ,(funcall (get-macro-character #\`) stream nil))) (set-dispatch-macro-character #\# #\` #'|#`-reader|)) (defmacro alet% (letargs &rest body) `(let ((this) ,@letargs) (setq this ,@(last body)) ,@(butlast body) this)) (defmacro alet (letargs &rest body) `(let ((this) ,@letargs) (setq this ,@(last body)) ,@(butlast body) (lambda (&rest params) (apply this params)))) (defun let-binding-transform (bs) (if bs (cons (cond ((symbolp (car bs)) (list (car bs))) ((consp (car bs)) (car bs)) (t (error "Bad let bindings"))) (let-binding-transform (cdr bs))))) (defmacro pandoriclet (letargs &rest body) (let ((letargs (cons '(this) (let-binding-transform letargs)))) `(let (,@letargs) (setq this ,@(last body)) ,@(butlast body) (dlambda (:pandoric-get (sym) ,(pandoriclet-get letargs)) (:pandoric-set (sym val) ,(pandoriclet-set letargs)) (t (&rest args) (apply this args)))))) (defun pandoriclet-get (letargs) `(case sym ,@(mapcar #`((,(car a1)) ,(car a1)) letargs) (t (error "Unknown pandoric get: ~a" sym)))) (defun pandoriclet-set (letargs) `(case sym ,@(mapcar #`((,(car a1)) (setq ,(car a1) val)) letargs) (t (error "Unknown pandoric set: ~a" sym)))) (declaim (inline get-pandoric)) (defun get-pandoric (box sym) (funcall box :pandoric-get sym)) (defsetf get-pandoric (box sym) (val) `(progn (funcall ,box :pandoric-set ,sym ,val) ,val)) (defmacro with-pandoric (syms box &rest body) (let ((g!box (gensym "box"))) `(let ((,g!box ,box)) (declare (ignorable ,g!box)) (symbol-macrolet (,@(mapcar #`(,a1 (get-pandoric ,g!box ',a1)) syms)) ,@body)))) (defun pandoric-hotpatch (box new) (with-pandoric (this) box (setq this new))) (defmacro pandoric-recode (vars box new) `(with-pandoric (this ,@vars) ,box (setq this ,new))) (defmacro plambda (largs pargs &rest body) (let ((pargs (mapcar #'list pargs))) `(let (this self) (setq this (lambda ,largs ,@body) self (dlambda (:pandoric-get (sym) ,(pandoriclet-get pargs)) (:pandoric-set (sym val) ,(pandoriclet-set pargs)) (t (&rest args) (apply this args))))))) (defvar pandoric-eval-tunnel) (defmacro pandoric-eval (vars expr) `(let ((pandoric-eval-tunnel (plambda () ,vars t))) (eval `(with-pandoric ,',vars pandoric-eval-tunnel ,,expr)))) ;; Chapter 7 (eval-when (:compile-toplevel :execute :load-toplevel) (set-dispatch-macro-character #\# #\f (lambda (stream sub-char numarg) (declare (ignore stream sub-char)) (setq numarg (or numarg 3)) (unless (<= numarg 3) (error "Bad value for #f: ~a" numarg)) `(declare (optimize (speed ,numarg) (safety ,(- 3 numarg))))))) (defmacro fast-progn (&rest body) `(locally #f ,@body)) (defmacro safe-progn (&rest body) `(locally #0f ,@body)) (defun fformat (&rest all) (apply #'format all)) (define-compiler-macro fformat (&whole form stream fmt &rest args) (if (constantp fmt) (if stream `(funcall (formatter ,fmt) ,stream ,@args) (let ((g!stream (gensym "stream"))) `(with-output-to-string (,g!stream) (funcall (formatter ,fmt) ,g!stream ,@args)))) form)) (declaim (inline make-tlist tlist-left tlist-right tlist-empty-p)) (defun make-tlist () (cons nil nil)) (defun tlist-left (tl) (caar tl)) (defun tlist-right (tl) (cadr tl)) (defun tlist-empty-p (tl) (null (car tl))) (declaim (inline tlist-add-left tlist-add-right)) (defun tlist-add-left (tl it) (let ((x (cons it (car tl)))) (if (tlist-empty-p tl) (setf (cdr tl) x)) (setf (car tl) x))) (defun tlist-add-right (tl it) (let ((x (cons it nil))) (if (tlist-empty-p tl) (setf (car tl) x) (setf (cddr tl) x)) (setf (cdr tl) x))) (declaim (inline tlist-rem-left)) (defun tlist-rem-left (tl) (if (tlist-empty-p tl) (error "Remove from empty tlist") (let ((x (car tl))) (setf (car tl) (cdar tl)) (if (tlist-empty-p tl) (setf (cdr tl) nil)) ;; For gc (car x)))) (declaim (inline tlist-update)) (defun tlist-update (tl) (setf (cdr tl) (last (car tl)))) (defun build-batcher-sn (n) (let* (network (tee (ceiling (log n 2))) (p (ash 1 (- tee 1)))) (loop while (> p 0) do (let ((q (ash 1 (- tee 1))) (r 0) (d p)) (loop while (> d 0) do (loop for i from 0 to (- n d 1) do (if (= (logand i p) r) (push (list i (+ i d)) network))) (setf d (- q p) q (ash q -1) r p))) (setf p (ash p -1))) (nreverse network))) (defmacro! sortf (comparator &rest places) (if places `(tagbody ,@(mapcar #`(let ((,g!a #1=,(nth (car a1) places)) (,g!b #2=,(nth (cadr a1) places))) (if (,comparator ,g!b ,g!a) (setf #1# ,g!b #2# ,g!a))) (build-batcher-sn (length places)))))) ;;;;;; NEW CODE FOR ANTIWEB #+cl-ppcre (defun dollar-symbol-p (s) (and (symbolp s) (> (length (symbol-name s)) 1) (string= (symbol-name s) "$" :start1 0 :end1 1) (ignore-errors (parse-integer (subseq (symbol-name s) 1))))) (defun prune-if-match-bodies-from-sub-lexical-scope (tree) (if (consp tree) (if (or (eq (car tree) 'if-match) (eq (car tree) 'when-match)) (cddr tree) (cons (prune-if-match-bodies-from-sub-lexical-scope (car tree)) (prune-if-match-bodies-from-sub-lexical-scope (cdr tree)))) tree)) ;; WARNING: Not %100 correct. Removes forms like (... if-match ...) from the ;; sub-lexical scope even though this isn't an invocation of the macro. #+cl-ppcre (defmacro! if-match ((test str) conseq &optional altern) (let ((dollars (remove-duplicates (remove-if-not #'dollar-symbol-p (flatten (prune-if-match-bodies-from-sub-lexical-scope conseq)))))) (let ((top (or (car (sort (mapcar #'dollar-symbol-p dollars) #'>)) 0))) `(let ((,g!str ,str)) (multiple-value-bind (,g!s ,g!e ,g!ms ,g!me) (,test ,g!str) (declare (ignorable ,g!e ,g!me)) (if ,g!s (if (< (length ,g!ms) ,top) (error "ifmatch: too few matches") (let ,(mapcar #`(,(symb "$" a1) (subseq ,g!str (aref ,g!ms ,(1- a1)) (aref ,g!me ,(1- a1)))) (loop for i from 1 to top collect i)) ,conseq)) ,altern)))))) (defmacro when-match ((test str) conseq &rest more-conseq) `(if-match (,test ,str) (progn ,conseq ,@more-conseq))) ;; EOF cafeobj-1.6.0/comlib/misc.lisp0000644000000000000000000005500613373141170015025 0ustar rootwheel;;;-*- Mode:Lisp; Syntax:Common-Lisp; Package:CHAOS -*- ;;; ;;; Copyright (c) 2000-2018, Toshimi Sawada. All rights reserved. ;;; ;;; Redistribution and use in source and binary forms, with or without ;;; modification, are permitted provided that the following conditions ;;; are met: ;;; ;;; * Redistributions of source code must retain the above copyright ;;; notice, this list of conditions and the following disclaimer. ;;; ;;; * Redistributions in binary form must reproduce the above ;;; copyright notice, this list of conditions and the following ;;; disclaimer in the documentation and/or other materials ;;; provided with the distribution. ;;; ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ;;; (in-package :CHAOS) #|============================================================================== System: Chaos Module: comlib File: misc.lisp ==============================================================================|# #-:chaos-debug (declaim (optimize (speed 3) (safety 0) #-GCL (debug 0))) #+:chaos-debug (declaim (optimize (speed 1) (safety 3) #-GCL (debug 3))) ;;;== DESCTIPTION ;;;============================================================== A ;;;collection of misc utility functions and macros. ;;; ** NOTE ******************************************************************** ;;; Many of the codes in this file are cllected from articles posted to ;;; some news groups (comp.lang.lisp, comp.lang.mcl, etc) or some mailing list ;;; long ago. And some were from my personal libraries. ;;; I have no infos codes other than the codes themselves. ;;; Please let me know if you find codes which are copyrighted, or you know the ;;; author. Email: sawada@sra.co.jp. ;;; **************************************************************************** ;;; ******* ;;; KEYWORD_____________________________________________________________________ ;;; ******* (defvar *keyword-package* (find-package :keyword)) (defun make-keyword (name) (declare (type (or symbol simple-string) name) (values symbol)) (if (stringp name) (intern name *keyword-package*) ;; name must be a symbol (intern (symbol-name name) *keyword-package*))) ;;; ***************** ;;; OBJECT ALLOCATION____________________________________________________________ ;;; ***************** ;;; Allocating simple vector ; (defmacro alloc-svec (size) `(the simple-vector (make-array ,size :initial-element nil))) (defmacro alloc-svec-fixnum (size) `(the simple-vector (make-array ,size :initial-element 0))) ;;; GCL doesn't hadle simple-vector properly! #-(or GCL EXCL) (defmacro %svref (vector index) `(svref ,vector (the fixnum ,index))) #+EXCL (defmacro %svref (vector index) `(aref (the vector ,vector) (the fixnum ,index))) #+GCL (defmacro %svref (vector index) `(aref (the vector ,vector) (the fixnum ,index))) ;;; AT-TOP-LEVEL : -> Bool ;;; determins whether we are at top level or not. ;;; *NOTE* : the top-level must maintain the following two ;;; variables properly: ;;; *chaos-input-source* : buind file (or stream?) during input ;;; from files. ;;; *chaos-input-level* : buind fixnum indicating nested file ;;; inputs levels. ;;; (defun at-top-level () (and (null *chaos-input-source*) (<= *chaos-input-level* 0))) ;;; ******************** ;;; ENVIRONMENT-VARIABLE________________________________________________________ ;;; ******************** ;;; ** TO DO for other platforms. (defun get-environment-variable (x) #+(or :CCL CMU) (declare (ignore x)) #+(or KCL GCL) (si:getenv x) #+LUCID (environment-variable x) #+CMU nil #+:CCL nil #+:Allegro (sys:getenv x) #+:CLISP (ext:getenv x) #+:SBCL (sb-ext:posix-getenv x) ) ;;; ***** ;;; DEBUG_______________________________________________________________________ ;;; ***** (defvar *on-debug* nil) (defvar *debug-level* 0) (defmacro debug-msg ((msg &key (level 0)) &rest args) `(if (and *on-debug* (<= ,level *debug-level*)) (funcall #'format *debug-io* ,msg ,@args))) (defmacro debug-form (level &body body) `(if (and *on-debug* (<= ,level *debug-level*)) (progn ,@body))) (defun on-debug (&optional (level 1)) (setf *on-debug* t) (setf *debug-level* level)) (defun off-debug () (setf *on-debug* nil) (setf *debug-level* 0)) ;;; *************** ;;; OBJECT ORDERING_____________________________________________________________ ;;; *************** ;;; ordering some Common Lisp object ;;; symbol < cons < number < character < string < sequence ;;; integer < symbol < cons < othernumber (defun ob< (x y) (declare (type t x y)) (eq :lt (ob-compare x y))) (defun ob-compare (x y) (declare (type t x y)) (typecase x (integer (typecase y (integer (if (< (the integer x) (the integer y)) :lt (if (< (the integer y) (the integer x)) :gt :eq))) (otherwise :lt))) (symbol (typecase y (symbol (if (eq x y) :eq (if (string-lessp (string (the symbol x)) (string (the symbol y))) :lt :gt))) (integer :gt) (otherwise :lt))) (cons (typecase y (cons (let ((comp-car (ob-compare (car x ) (car y)))) (if (eq :eq comp-car) (ob-compare (cdr x) (cdr y)) comp-car))) ((or symbol integer) :gt) (otherwise :lt))) (number (typecase y (number (if (< x y) :lt (if (< y x) :gt :eq))) ((or symbol integer cons) :gt) (otherwise :lt))) (character (typecase y (character (if (char< (the character x) (the character y)) :lt (if (char< (the character y) (the character x)) :gt :eq))) ((or number cons symbol) :gt) (otherwise :lt))) (string (typecase y (string (if (string-lessp x y) :lt (if (string-lessp y x) :gt :eq))) ((or character number cons symbol) :gt) (otherwise :lt))) (sequence (typecase y (sequence (let ((lenx (length x)) (leny (length y))) (declare (type fixnum lenx leny)) (dotimes (i (min lenx leny) (ob-compare lenx leny)) (declare (type fixnum i)) (let ((xi (elt x i)) (yi (elt y i))) (let ((cmp (ob-compare xi yi))) (unless (eq :eq cmp) (return cmp))))) :eq)) (otherwise :gt))) (otherwise :lt) ;; (structure :lt) ;; ;; how about structure ... ;; (otherwise (break "not yet type ~s" (type-of x))) )) ;;; ********* ;;; TOPO-SORT___________________________________________________________________ ;;; ********* ;;; will only apply to sequences of distinct items ;;; very simple method based on selection sort ;;; -- select minimal element of those remaining, swap with next and continue ;;; this is specialized to lists. ;;; (defun topo-sort (lst pred) (declare (type list lst) (type function pred)) (let ((res lst)) ; save original list as final value ;; run through the positions of lst successively filling them in (loop (when (null lst) (return)) ;; pos is location of val which is current minimal value (let ((pos lst) (val (car lst)) (rest (cdr lst))) ;; scan through remainder of list rest updating pos and val (loop ; -- select minimal (when (null rest) (return)) (let ((valr (car rest))) (when (funcall pred valr val) (setq pos rest val valr))) ; have found new minimal value (setq rest (cdr rest))) ; loop -- select minimal ;; swap values at front of lst and at pos (rplaca pos (car lst)) (rplaca lst val)) (setq lst (cdr lst))) res)) ;;; ******* ;;; ADDRESS______________________________________________________________________ ;;; ******* ;;; address of objects. ;;; The intention is to only use this for printing. ;;; #+GCL (Clines "static object addr_of(x) object x; {return(make_fixnum((int)x));}") ;;(defCfun "object addr_of(x) object x;" 0 ;;" Creturn(make_fixnum((int)x));" ;;) #+GCL (defentry addr-of (object) (object addr_of)) (defconstant .32bit. #xffffffff) #-GCL (declaim (inline addr-of)) #+LUCID (defun addr-of (x) (logand .32bit. (sys:%pointer x))) #+CMU (defun addr-of (x) (logand .32.bit. (kernel:get-lisp-obj-address x))) #+Excl (defun addr-of (x) (logand .32bit. (excl::pointer-to-positive-fixnum x))) #+CCL (defun addr-of (x) (logand .32bit. (ccl::%address-of x))) #+CLISP (defun addr-of (x) (logand .32bit. (sys::address-of x))) #+SBCL (defun addr-of (x) (logand .32bit. (sb-kernel:get-lisp-obj-address x))) (defun print-addr (x) (format t "0x~8,'0x" (addr-of x))) ;;; ************ ;;; QUERY-INPUT_________________________________________________________________ ;;; ************ (defun query-input (&optional (default #\y) (timeout 20) format-string &rest args) (clear-input *query-io*) (when format-string (fresh-line *query-io*) (apply #'format *query-io* format-string args) ;; FINISH-OUTPUT needed for CMU and other places which don't handle ;; output streams nicely. This prevents it from continuing and ;; reading the query until the prompt has been printed. (finish-output *query-io*)) (let ((read-char (read-char-wait timeout *query-io*))) (cond ((null read-char) (return-from query-input default)) (t (unread-char read-char *query-io*) (read *query-io*))))) ;;; ************* ;;; Y-OR-N-P-WAIT________________________________________________________________ ;;; ************* ;;; y-or-n-p-wait is like y-or-n-p, but will timeout ;;; after a specified number of seconds (defun internal-real-time-in-seconds () (/ (get-internal-real-time) internal-time-units-per-second)) (defun read-char-wait (&optional (timeout 20) input-stream &aux char) (do ((start (internal-real-time-in-seconds))) ((or (setq char (read-char-no-hang input-stream nil)) ;(listen *query-io*) (< (+ start timeout) (internal-real-time-in-seconds))) char))) (defvar *use-timeouts* t "If T, timeouts in Y-OR-N-P-WAIT are enabled. Otherwise it behaves like Y-OR-N-P. This is provided for users whose lisps don't handle read-char-no-hang properly.") (defvar *clear-input-before-query* t "If T, y-or-n-p-wait will clear the input before printing the prompt and asking the user for input.") ;;; y-or-n-p-wait ;;; Y-OR-N-P-WAIT prints the message, if any, and reads characters from ;;; *QUERY-IO* until the user enters y, Y or space as an affirmative, or either ;;; n or N as a negative answer, or the timeout occurs. It asks again if ;;; you enter any other characters. (defun y-or-n-p-wait (&optional (default #\y) (timeout 20) format-string &rest args) (when *clear-input-before-query* (clear-input *query-io*)) (when format-string (fresh-line *query-io*) (apply #'format *query-io* format-string args) ;; FINISH-OUTPUT needed for CMU and other places which don't handle ;; output streams nicely. This prevents it from continuing and ;; reading the query until the prompt has been printed. (finish-output *query-io*)) (loop (let* ((read-char (if *use-timeouts* (read-char-wait timeout *query-io*) (read-char *query-io*))) (char (or read-char default))) (declare (type character char)) ;; We need to ignore #\newline because otherwise the bugs in ;; clear-input will cause y-or-n-p-wait to print the "Type ..." ;; message every time... *sigh* ;; Anyway, we might want to use this to ignore whitespace once ;; clear-input is fixed. (unless (find char '(#\tab #\newline #\return)) (when (null read-char) (format *query-io* "~@[~A~]" default) (finish-output *query-io*)) (cond ((null char) (return t)) ((find char '(#\y #\Y #\space) :test #'char=) (return t)) ((find char '(#\n #\N) :test #'char=) (return nil)) (t (when *clear-input-before-query* (clear-input *query-io*)) (format *query-io* "~%Type \"y\" for yes or \"n\" for no. ") (when format-string (fresh-line *query-io*) (apply #'format *query-io* format-string args)) (finish-output *query-io*))))))) ;;; ******** ;;; MULTISET____________________________________________________________________ ;;; ******** ;;; A multiset is a collection of elements "{e1, ..., en}" of some type, where ;;; the elements need not be distinct. The operations "multiset.equal" is used ;;; to determine if two elements are the same. Two elements are said to be ;;; `distinct' in a multiset if they are not "multiset.equal" to one another. ;;; ;;; IMPLEMENTATION: ;;; an element is represented as a pair of the form `(object . cout)', ;;; where, `object' is the element and `count' is the number of times it ;;; occurs in the multiset (if it occurs at least once in the multiset). ;;; a multiset itself is represented as a list of this pairs. (defstruct (multiset (:conc-name "MULTISET-") (:constructor multiset-create (equal-fun elements)) (:copier nil)) (equal-fun #'eq :type function) ; predicate which determines the equality ; of the objects. (elements nil :type list)) ; list of pair (object . count). ;;; MULTISET-NEW ;;; creates the new empty multiset- ;;; (defmacro multiset-new (&optional (equal-fun #'eq)) `(multiset-create ,equal-fun nil)) ;;; MULTISET-IS-EMPTY m ;;; (defmacro multiset-is-empty (m) `(null (multiset-elements ,m))) ;;; MULTISET-INSERT ms e ;;; insert e in ms. (defmacro multiset-insert (ms e) (once-only (ms) `(let* ((elems (multiset-elements ,ms)) (pair (assoc ,e elems :test (multiset-equal-fun ,ms)))) (if pair (incf (the fixnum (cdr pair))) (setf (multiset-elements ,ms) (push (cons e 1) elems)))))) ;;; LIST-TO-MULTISET list ;;; returns a new multiset consisting of the elements in list. ;;; (defmacro list-to-multiset (list &optional (equal-fun #'eq)) ` (let ((ms (multiset-new ,equal-fun))) (declare (type multiset ms)) (dolist (e ,list) (multiset-insert ms e)) ms)) ;;; MULTISET-TO-SET ms ;;; returns a set contains element in ms. (defmacro multiset-to-set (ms) `(mapcar #'car (multiset-elements ,ms))) ;;; MULTISET-DELETE ms e ;;; removes one occurrence of e in ms. ;;; (defmacro multiset-delete (ms e) (once-only (ms) `(let* ((elems (multiset-elements ,ms)) (pair (assoc ,e elems :test (multiset-equal-fun ,ms)))) (when pair (when (zerop (decf (the fixnum (cdr pair)))) (setf (multiset-elements ,ms) (delete e elems :test (multiset-equal-fun ,ms) :key #'car))))))) ;;; MULTISET-MERGE m1 m2 ;;; inserts each elements of m2 into m1. leaves m2 unchanged. ;;; equality is determined with respect to m1. ;;; (defmacro multiset-merge (m1 m2) (once-only (m1) `(let ((m1-elems (multiset-elements ,m1)) (equal-fun (multiset-equal-fun ,m1))) (dolist (e2 (multiset-elements ,m2)) (let ((pair (assoc (car e2) m1-elems :test equal-fun))) (if pair (incf (the fixnum (cdr m1-elems)) (the fixnum (cdr pair))) (push e2 m1-elems))))))) ;;; MULTISET-INTERSECTION m1 m2 ;;; returns a new multiset with all elements that occur in both m1 and m2, ;;; with the number of occurences being the smaller of the two. ;;; leaves m1 and m2 unchanged. ;;; (defmacro multiset-intersectin (m1 m2) (once-only (m1) `(let ((m1-elems (multiset-elements ,m1)) (equal-fun (multiset-equal-fun ,m1)) (new-elems nil)) (dolist (e2 (multiset-elements ,m2)) (let ((pair (assoc (car e2) m1-elems :test equal-fun))) (when pair (push (cons (car pair) (min (cdr pair) (cdr e2))) new-elems)))) (multiset-create equal-fun new-elems)))) ;;; MULTISET-DIFF m1 m2 ;;; returns the new multiset formed by removing from m1 each elements that ;;; occurs in m2, the number of times it occurs. Thus, the relationship ;;; m1 + m2 == (m1 - m2) + (m1 ^ m2) + (m2 - m1) will hold. ;;; (defmacro multiset-diff (m1 m2) (once-only (m1) `(let ((m1-elems (multiset-elements ,m1)) (equal-fun (multiset-equal-fun ,m1)) (new-elems nil)) (dolist (e2 (multiset-elements ,m2)) (let ((pair (assoc (car e2) m1-elems :test equal-fun))) (if pair (let ((count (- (cdr pair) (cdr e2)))) (when (< 0 count) (push (cons (car pair) count) new-elems))) (push (cons (car par) (cdr pair)) new-elems)))) (multiset-create equal-fun new-elems)))) ;;; MULTISET-COUNT m e ;;; returns the nubmer of occurences of e in m. ;;; (defmacro multiset-count (m e) (once-only (m) `(let ((pair (assoc ,e (multiset-elements ,m) :test (multiset-equal-fun ,m)))) (if pair (cdr pair) 0)))) ;;; **** ;;; TIME________________________________________________________________________ ;;; **** (defun get-time-string (&optional universal-time) (unless universal-time (setf universal-time (get-universal-time))) (multiple-value-bind (secs min hour date month year dow) (decode-universal-time universal-time 0) ; GMT time (declare (type fixnum dow month)) (format nil "~d ~a ~d ~a ~d:~2,'0d:~2,'0d GMT" year (%svref '#(0 "Jan" "Feb" "Mar" "Apr" "May" "Jun" "Jul" "Aug" "Sep" "Oct" "Nov" "Dec") month) date (%svref '#("Mon" "Tue" "Wed" "Thu" "Fri" "Sat" "Sun") dow) hour min secs) )) ;;; elapsed-time-in-seconds ;;; ;;; Returns the time in seconds that has elapsed between Base and Now. ;;; Just subtracts Base from Now to get elapsed time in internal time units, ;;; then divides by the number of internal units per second to get seconds. (defun elapsed-time-in-seconds (base now) (declare (type integer base now)) (coerce (/ (- now base) internal-time-units-per-second) 'float)) (defun time-in-seconds (sum) (declare (type integer sum)) (coerce (/ sum internal-time-units-per-second) 'float)) ;;; **** ;;; MISC________________________________________________________________________ ;;; **** (defmacro every2len (fn l1 l2) (let* ((lmbd (cadr fn)) (args (cadr lmbd)) (bdy (cddr lmbd))) ` (let ((lst1 ,l1) (lst2 ,l2) ,@args) (loop (when (null lst1) (return (null lst2))) (when (null lst2) (return (null lst1))) (setq ,(car args) (car lst1)) (setq ,(cadr args) (car lst2)) (unless (progn ,@bdy) (return nil)) (setq lst1 (cdr lst1)) (setq lst2 (cdr lst2)) ) ))) (defun list2array (list) (declare (type list list) #-GCL (values simple-vector) ) #-GCL (make-array (length list) :initial-contents list) #+GCL (let ((len (length list))) (let ((arr (si:make-vector t len nil nil nil 0 nil)) (i 0)) (declare (fixnum i)) (dolist (e list) (si:aset arr i e) (setq i (1+ i))) arr))) (defun make-list-1-n (n) (declare (type fixnum n) (values list)) (let ((result nil)) (dotimes-fixnum (x n) (push (+ x 1) result)) (reverse result))) (defun make-list-1-n-0 (n) (declare (type fixnum n) (values list)) (let ((result nil)) (dotimes-fixnum (x n) (push (+ x 1) result)) (push 0 result) (reverse result))) ;;; ;;; REMOVEABLE ASSOCIATION TABLE ;;; (defmacro find-in-assoc-table (table key &optional (test '#'equal)) `(cdr (assoc ,key ,table :test ,test))) (defmacro get-entry-in-assoc-table (table key &optional (test '#'equal)) `(assoc ,key ,table :test ,test)) (defmacro delete-entry-from-assoc-table (table key &optional (test '#'equal)) ` (let ((entry (assoc ,key ,table :test ,test))) (when entry (setq ,table (delete entry ,table :test #'eq))))) (defmacro delete-object-from-assoc-table (table object &optional (test '#'eq)) ` (let ((entry (rassoc ,object ,table :test ,test))) (when entry (setq ,table (delete entry ,table :test #'eq))))) (defmacro add-to-assoc-table (table key value &optional (test '#'equal)) (once-only (table key value) ` (let ((entry (get-entry-in-assoc-table ,table ,key ,test))) (if entry (setf (cdr entry) ,value) (prog1 ,value (push (cons ,key ,value) ,table)))))) (defmacro object-is-in-assoc-table? (table object &optional (test '#'eq)) `(rassoc ,object ,table :test ,test)) ;;; ******************* ;;; FIXNUM COMPUTATIONS ;;; ******************* (defmacro test-and (a b) `(not (zerop (logand ,a ,b)))) (defmacro make-and (*a *b) `(logand ,*a ,*b)) (defmacro make-or (*a *b) `(logior ,*a ,*b)) (defmacro make-xor (*a *b) `(logxor ,*a ,*b)) (defmacro expt2 (x) `(expt 2 (the fixnum ,x))) ;;; EOF cafeobj-1.6.0/tests/0000755000000000000000000000000013373141170013070 5ustar rootwheelcafeobj-1.6.0/tests/cafeobj-memo0000755000000000000000000000020513373141170015337 0ustar rootwheel#!/bin/bash if [ -n "$3" ] ; then ENGINE="-engine $3" else ENGINE="" fi echo -e "set always memo $1\nin $2" | cafeobj $ENGINE -q cafeobj-1.6.0/tests/run-all-checks0000755000000000000000000000656313373141170015640 0ustar rootwheel#!/bin/bash # # Copyright 2018 Norbert Preining # License: GPL3+ # # test cafeobj with with memo on/off and sbcl/acl # against a set of .mod files from a given directory (first argument) # Usage: # run-all-checks PATH-TO-DIR-WITH-MOD-FILES # Generates lots of .log files for each combination and test # Generates a file # result.YYYYMMDDHHMMSS.csv # containing the results timeout=10m dn=$(dirname $0) if [ "$1" = "-no-run" ] ; then runco=false shift else runco=true fi output=results.$(date '+%Y%m%d%H%M%S').csv if [ -r $output ] ; then echo "$output already present, exiting" >&2 exit 1 fi echo "test,sbcl,,,,acl,,," > $output echo ",memo on,,memo off,,memo on,,memo off," >> $output echo ",result,time,result,time,result,time,result,time" >> $output if [ ! -d "$1" ] ; then echo "Not a directory: $1" >&2 exit 1 fi function shipout_run_data { testname=$1 if [ ! -r $testname.sbcl.memo-off.log ] ; then return fi declare -A ret declare -A tim for e in sbcl acl ; do for m in on off ; do ret[${e},${m}]=$(get_exit_status $testname.$e.memo-$m.log) tim[${e},${m}]=$(get_elapsed_time $testname.$e.memo-$m.log) if [ -n "${ret[${e},${m}]}" ] ; then set $(echo ${ret[${e},${m}]} | sed -e 's/:/ /') # echo "e=$e, m=$m ret=${ret[${e},${m}]}, 1=$1, 2=$2" if [ "$1" = "OK" ] ; then ret[${e},${m}]="OK" else ret[${e},${m}]="$1 ($2)" fi fi done done echo "$testname,${ret[sbcl,on]},${tim[sbcl,on]},${ret[sbcl,off]},${tim[sbcl,off]},${ret[acl,on]},${tim[acl,on]},${ret[acl,off]},${tim[acl,off]}" >> $output } function get_exit_status { local result local errtype if grep -q "Command exited with non-zero status 124" $1 ; then result="ERROR" errtype="timeout" elif grep -q "more bytes of heap" $1 ; then # ACL heap error result="ERROR" errtype="heap" elif grep -q "Heap exhausted" $1 ; then # SBCL heap error result="ERROR" errtype="heap" elif grep -q "Stack overflow" $1 ; then # ACL stack result="ERROR" errtype="stack" elif grep -q "Control stack exhausted" $1 ; then result="ERROR" errtype="stack" elif grep -q "Caught an exception" $1 ; then result="ERROR" errtype="unknown" elif grep -q "Leaving CafeOBJ" $1 ; then result=OK else result=ERROR errtype=??? fi echo "$result:$errtype" } function get_elapsed_time { # 22.52user 1.95system 0:24.47elapsed 99%CPU (0avgtext+0avgdata 17612maxresident)k # 0inputs+9845072outputs (0major+1788minor)pagefaults 0swaps # format of elapsed time is [hours:]minutes:seconds[.subseconds] elapsedTime=$(tail -5 $1 | grep elapsed | awk '{print$3}' | sed -e 's/elapsed$//') echo "$elapsedTime" } for i in "$1"/*.mod ; do bn=`basename "$i" .mod` echo -n "$bn: " echo -n "sbcl/memo-off " $runco && /usr/bin/time timeout $timeout $dn/cafeobj-memo off $i sbcl > $bn.sbcl.memo-off.log 2>&1 echo -n "sbcl/memo-on " $runco && /usr/bin/time timeout $timeout $dn/cafeobj-memo on $i sbcl > $bn.sbcl.memo-on.log 2>&1 echo -n "acl/memo-off " $runco && /usr/bin/time timeout $timeout $dn/cafeobj-memo off $i acl-standalone > $bn.acl.memo-off.log 2>&1 echo -n "acl/memo-on " $runco && /usr/bin/time timeout $timeout $dn/cafeobj-memo on $i acl-standalone > $bn.acl.memo-on.log 2>&1 shipout_run_data $bn echo "done" done # vim:set tabstop=2 expandtab: # cafeobj-1.6.0/thstuff/0000755000000000000000000000000013611200224013400 5ustar rootwheelcafeobj-1.6.0/thstuff/parse-apply.lisp0000644000000000000000000006155013373141170016546 0ustar rootwheel;;;-*- Mode:LISP; Package:CHAOS; Base:10; Syntax:Common-lisp -*- ;;; ;;; Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. ;;; ;;; Redistribution and use in source and binary forms, with or without ;;; modification, are permitted provided that the following conditions ;;; are met: ;;; ;;; * Redistributions of source code must retain the above copyright ;;; notice, this list of conditions and the following disclaimer. ;;; ;;; * Redistributions in binary form must reproduce the above ;;; copyright notice, this list of conditions and the following ;;; disclaimer in the documentation and/or other materials ;;; provided with the distribution. ;;; ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ;;; (in-package :chaos) #|============================================================================== System: CHAOS Module: thstuff File: parse-apply.lisp ==============================================================================|# #-:chaos-debug (declaim (optimize (speed 3) (safety 0) #-GCL (debug 0))) #+:chaos-debug (declaim (optimize (speed 1) (safety 3) #-GCL (debug 3))) ;;; === APPLY COMMAND FAMILY PARSERS ;;; ---------------------------------------------------------------------- ;;; ***** ;;; START ;;; ***** ;;; - Syntax ----------------------------------------------------------------- ;;; ::= start . ;;; -------------------------------------------------------------------------- ;;; Chaos form (defterm start (%script) :visible (target) ; target term :eval eval-start-command ) ;;; parser (defun parse-start-command (e) (%start* (cadr e))) ;;; ************ ;;; APPLY FAMILY ;;; ************ ;;; apply command of Chaos is the subset(but not a restriction) of OBJ(ver2.0) + ;;; some extensions. ;;;----------------------------------------------------------------------------- ;;; (1) don't have . no problem, we have operator with error sorts as ;;; their rank. ;;; (2) allow rule labels with digit chars at its head. ;;; only labels consisting of all digit chars are considered as rule ;;; numbers. ;;; (3) explicit forward direction specifier `+' allowing module with `-' ;;; at head of their names and vise versa. ;;; aboves are not so important. ;;; (4) break down features of `apply' into more elementary ones. ;;; `apply' of OBJ seems trying "do everything at once", or "to be a ;;; powerful tool applicable to almost everything" like swiss army ;;; knife. must agree(shouldn't we?), but this makes its syntax rather ;;; heavy and prevents us from doing some simple tasks in a handy manner. ;;; Chaos supports full apply command of OBJ (without of course) ;;; in itself, and also provides some new command "do a simple thing at one ;;; time", whose produced informations can be used in the later use of ;;; apply command. ;;; also have some extensions to OBJ's apply. ;;; hopefully, these would be useful for those who uses Chaos system ;;; interactively. ;;; ;;; === NEW COMMANDS & EXTENSIONS to APPLY of OBJ ========================= ;;; *NOTE* ---------------------------------------------------------------- ;;; like `apply', some new commands assume a term which is the result of ;;; `start' or `parse' (even of `reduce') commands. we refer this term as ;;; "$$term" in the sequel. a specific subterm of $$term may be also ;;; refered and/or set by some commands; this subterm will be denoted by ;;; "$$subterm". initially, that is, just after `start', `parse', or ;;; `reduce', $$subterm is identical to $$term(the whole). ;;; ----------------------------------------------------------------------- ;;; (4-1) subterm selection : ;;; [a] choose command ;;; - SYNTAX -------------------------------------------------------- ;;; ::= choose ;;; ----------------------------------------------------------------- ;;; this selects a subterm specified by . ;;; is just the same to `apply' command. here is its ;;; summary (selector "subterm" is added, see `* NOTE (1)' below): ;;; ::= { top | term | subterm } | ;;; { of }* ;;; ::= | ;;; | ;;; ::= "(" + ")" ;;; ::= "[" .. "]" | "[" "]" ;;; ::= "{" [, ]* "}" ;;; - BEHAVIOUR ----------------------------------------------------- ;;; the meaning of is the same as OBJ. ;;; the target term of `choose' is $$subterm(see *NOTE* above), and ;;; it will be reset to the selected subterm. thus, succeeding ;;; applications of choose command selects a "subterm of subterm of ;;; ... subterm of $$subterm". ;;; one can archive the same effect at onece by a form ;;; like " of of ...", but the former way ;;; is useful for selecting a subterm of a complex(large) term ;;; incrementaly being with some checks that a subterm is correctly ;;; selected at some steps of choices. ;;; if sole "top" or "term" is given as , original whole ;;; term ($$term) is selected as subterm and is set to $$subterm. ;;; this is a handy way to cancell of preceding selections. but ;;; of cource, if one `applied' some rules to selected subterm, $$term ;;; would be changed, and then the $$term can be quite different from ;;; its original. ;;; ----------------------------------------------------------------- ;;; * NOTE: (1) for combined use of `choose' and `apply', the ;;; of apply command is extended. it now accepts ;;; "subterm" as a which refers to a subterm ;;; selected by the last `choose' command. ;;; (2) once some rewrite rule is successfully applied ;;; to somewhere in $$term, $$subterm is reset to $$term. ;;; ;;; [b] show command extension. ;;; - SYNTAX ------------------------------------------------------- ;;; ::= show subterm [ tree ] ;;; ---------------------------------------------------------------- ;;; we extended `show' command so that it can print out the subterm ;;; chosen by the last `choose' command ($$term will be printed if ;;; there has been any selected proper subterm). ;;; this can be used for cirtifying the subterm selected by choose ;;; command. if optional "tree" is given, also prints out $$subterm ;;; in a tree form. ;;; *NOTE* ordinal "show term" will pirnt out $$term. for tree form ;;; print of $$term, "show tree" (specific to Chaos) can be ;;; used. also prepared "show term tree" though. ;;; (4-2) listing out applicable rewrite rules. ;;; [a] find command ;;; - SYNTAX ------------------------------------------------------- ;;; ::= find { rule | +rule | -rule } ;;; ---------------------------------------------------------------- ;;; - BEHAVIOUR ---------------------------------------------------- ;;; print-outs all axioms which can be successfully applied ;;; to $$subterm. the direction as a rewrite rule is specified by ;;; the argument "rule", "+rule" or "-rule". ;;; given "rule", `find' searches through the set of all axioms ;;; of the current context(current module) including imported axioms ;;; of submodules and system generated ones for associative and/or ;;; commutative operators, and selects ones whose left OR right hand ;;; side matches to $$subterm. "+rule" try matches only to left-hand ;;; side of the axioms (forward direction), and "-rule" is used for ;;; specifying backward direction. ;;; ---------------------------------------------------------------- ;;; printing form is arranged to be giving useful informations for ;;; later `apply' commands. each printed axioms has the form ;;; ------------------------------------------------------ ;;; () {}+ : LHS {-->|<--} RHS [SUBST-INFO] ;;; ------------------------------------------------------ ;;; where is a natural number assigned by find command and ;;; can be directly used as rule specifier of our extended apply ;;; command (see (4-3) below for the extension.) ;;; is just the same to rule specifier of OBJ's apply ;;; command, which is in a form of . or .. ;;; find always prints former form and if an axioms has a label, ;;; it will also be printed. of course these also can be used for ;;; rule specifier of apply command. following a separate mark `:' ;;; axiom itself is printed. between left and right hand side side, ;;; --> or <-- sign is printed showing the direction as a rewrite ;;; rule. an axiom can have match on its both side to $$subterm ;;; (this can happen as giving "rule"), the same axiom is printed 2 ;;; times with different , (backward direction has ;;; preceding "-") and direction sign between LHS and RHS. optional ;;; SUBST-INFO is printed when the RHS(LHS) has extra variable than ;;; LHS(RHS) in the case of forward(backward) direction. ;;; SUBST-INFO has the form ;;; ------------------------------------------------------------- ;;; with = : {, = ;;; : }* ;;; ------------------------------------------------------------- ;;; where, is the variable name occur in the axiom, ;;; is an identifier generated by `find' command, and ;;; is a name of a sort of the variable. this provides ;;; a template for for apply command. one can substitute ;;; `:' with appopreate term and can give it to ;;; an argument to `apply'. ;;; (4-3) extensions to `apply' command: ;;; [a] rule specifier of apply command ;;; - Syntax ----------------------------------------------------- ;;; apply [] { at | within } . ;;; -------------------------------------------------------------- ;;; apply now accepts simple natural number as a rule specifier ;;; which refers the number assigned by preceding `find'command to ;;; a rewrite rule (see (4-2) above). ;;; [b] new option -- "subterm" ;;; as noted in (4-1)[a] above, apply accepts "subterm" as a subterm ;;; selector. ;;; [c] can omit ;;; can omit even if there exists some extra variables. ;;; in this case, system generates pusude variables (constant terms) ;;; on the fly, and uses them instead of extra variables. ;;; in a similar manner, one can `start' with a term with some ;;; variables in it. also, in this case, system generates constant ;;; terms and supply them istead. this is almost the same with ;;; `open'ing a module and declare some constants and uses them. ;;; ;;; (4-4) some support commands: ;;; [a] showing apply context ;;; separating out the functions of apply command requires us to keep ;;; some context(selected subterms, applicable rules) in mind. ;;; the following extension to `show' can be used for this purpose. ;;; - Syntax -------------------------------------------------------- ;;; ::= show apply context ;;; ----------------------------------------------------------------- ;;; print-outs informations useful for using apply command in a form ;;; like this: ;;; ------------------------------------------------------- ;;; current module : name of current module. ;;; term : whole target term ($$term). ;;; subterm : subterm selected by `choose' command, ;;; also prints . ;;; rules : set of rules found by `find' command. ;;; ------------------------------------------------------- ;;; ;;; *LIMITATION* : we don't have `abbriviated' module names for complex ;;; module expressions. thus we are restricted to perform ;;; `apply' only in modules with simple name. ;;; seems to need something like `abbrev' of OBJ. ;;; * some extensions planned * ;;; (1) `step' option: ;;; must do apply process in interactive manner. ;;; (2) `stop' option: ;;; stop reduction process when we meet the `pattern' specified. ;;; might need some interactive process, `continue',`done'or .. ? ;;; *NOTE on Semantics of * ;;; the semantics of rule specifier(rule identifier or rule number) of ;;; in OBJ is only loosely defined. at least for me, careful reading ;;; of throughout OBJ manual doesn't give me an enough infos to implement this ;;; feature. ;;; the aim of specifier is of course to select one specific rule to be applied, ;;; but there exists some ambiguities here. ;;; the follwing is the problem summarized and its treatment of current ;;; Chaos implementation. ;;; (1) searching context: ;;; *(1-1) semantics of is loose. ;;; how about rules imported from sub-modules? limits to the ;;; OWN rules of or including ones of submodules? ;;; my understanding is that says "search in all rewrite rules ;;; in including imported ones" limiting the search space ;;; to a subset of current module. this seems reasonable, so Chaos follows ;;; this line. (*note* the real implementation of OBJ is more complex one ;;; reflecting the value of a global flag set by users with `set' command, ;;; but this can make the behaviour of apply command magical one. we want ;;; to make things more simple). ;;; *(1-2) what is the rule number? ;;; what does "2.MOD" mean? this says `the second' rule of module `MOD', ;;; but which is the `second'? ;;; *(1-3) system generated rules. ;;; should we consider rules generated by the system, eg. some rules for ;;; associative/commutative operators? from the user side, full control ;;; of reduction needs these rules to be choosed. but generated rules has ;;; no rule identifier, thus user must select them by `number'. ;;; (2) multiple rules with the same identifier: ;;; there is no syntactical limitation on rule identifiers, they can be ;;; overloaded, and there is no automatic selection machanisms for choosing ;;; one among them. Chaos asks user to select one ;;; ;;; APPLY FAMILY --------------------------------------------------------------- ;;; forms and parsers ;;; ---------------------------------------------------------------------------- ;;; ****** ;;; CHOOSE ;;; ****** (defterm choose (%script) :visible (selectors) ; one of :top, :subterm or list of ; selectors. :eval eval-choose-command) ;;; ************ ;;; INSPECT-TERM ;;; ************ (defterm inspect-term (%script) :visible () :eval eval-inspect-term-command) ;;; get-selectors : selector-token-seq -> { symbol | list(token)} ;;; ;;; ::= subterm | term | top | { of }* ;;; ::= | | } ;;; ::= "(" + ")" ;;; ::= "[" .. "]" | "[" "]" ;;; ::= "{" [, ]* "}" ;;; (defun get-selectors (selector-toks) (case-equal (car selector-toks) (("top" "term") :top) ("subterm" :subterm) (("(" "{" "[") ;; *NOTE* discard the first token ;; because of stupid behaviour of our token reader. (cdr selector-toks)) (t (with-output-chaos-error ('invalid-selector) (format t "unknown type of selectors ~a" selector-toks) )))) (defun parse-choose-command (tok) (%choose* (get-selectors (cadr tok)))) ;;; ***** ;;; MATCH ;;; ***** ;;; - Syntax ------------------------------------------------------------------- ;;; ::= match to . ;;; ::= { it | term | top | subterm | } ;;; ::= { rule | +rule | -rule | } ;;;----------------------------------------------------------------------------- (defterm match (%script) :visible (type ; or :match, :unify, :xmatch target ; or :it pre-term pattern ; or :rule, +rule, -rule, pre-term ) :eval eval-match-command) (defun parse-match-command (toks) (let (type target pattern) ;; (setq type (if (equal "match" (car toks)) :match (if (equal "xmatch" (car toks)) :xmatch :unify))) (setq toks (cdr toks)) ; arguments ;; get target (loop (when (or (null toks) (or (equal "to" (car toks)) (equal "with" (car toks)))) (return)) (push (car toks) target) (setq toks (cdr toks))) (setq target (car (nreverse target))) ;; get pattern (setq pattern (cadr toks)) ;; make ast (%match* type (case-equal target ((("top") ("term")) :top) ((("subterm")) :subterm) ((("it")) :it) (t target)) (case-equal pattern ((("rule") ("rules")) :rule) ((("+rule") ("+rules")) :+rule) ((("-rule") ("-rules")) :-rule) (t pattern))))) ;;; **** ;;; FIND ;;; **** ;;;- Syntax -------------------------------------------------------------------- ;;; ::= find ;;; ::= { rule | +rule | -rule } ;;;----------------------------------------------------------------------------- ;;; *NOTE* just the alias of "match it to . " ;;; (defun parse-find-command (toks) (%match* :match :it (case-equal (cadr toks) (("rule" "rules") :rule) (("+rule" "+rules") :+rule) (("-rule" "+rules") :-rule) (t (with-output-chaos-error ('invalid-rule-spec) (princ "only `rule', `+rule', or `-rule' is meaningful for find,") (print-next) (format t "but ~a is given." (cadr toks))))))) ;;; ***** ;;; APPLY ;;; ***** ;;; - Syntax -------------------------------------------------------------------- ;;; ::= apply . ;;; ::= {red | reduction | print | ? | ;;; []} ;;; ::= | [ + | - ] [].{ | } ;;; ::= with = {, = }* ;;; ::= { at | within } ;;; ::= subterm | term | top | { of }* ;;; ::= | | } ;;; ::= "(" + ")" ;;; ::= "[" { .. | } "]" ;;; ::= "{" [, ]* "}" ;;; ;;; *note* the syntax of of OBJ is defined as ;;; ::= { of }* ;;; ::= { term | top } | | | ;;; ;;; this seemes to be strange for me. ;;; how about "top of top of top" or "top of { 1, 3 } of top of [ 1 .. 2 ]"? ;;; these are meaningful, but unneccessarily complex. ;;;----------------------------------------------------------------------------- (defterm apply (%script) :visible (action ; action to be performed, one-of ; :apply, :reduce, :print, :help. rule-spec ; rule specifier to be applied. substitution ; list of variable bindings. where-spec ; one of :at, :within. selectors) ; list of selectors. :eval eval-apply-command) ;;; get-apply-action : -> action keyword ;;; ;;; ::= { red | reduction | print | help | []} ;;; * "help" & are specially treated elsewhere. ;;; (defun get-apply-action (tok) ;; tok ::= { red | reduction | reduce | print | } (case-equal tok (("red" "reduction" "reduce") :reduce) (("bred" "breduce" "behavioural-reduction") :breduce) (("execute" "exec") :exec) ("print" :print) (t :apply))) ;;; NOTE: rules labels cannot contain . ;;; parse-rule-spec : -> (Module Rule Direction) ;;; ;;; ::= | [ - | + ][].{ | } ;;; ::= [ - | + ][.]{ | } ;;; #|| (defun parse-rule-spec (tok) (declare (type string tok)) (if (every #'digit-char-p tok) (let ((val (parse-integer tok))) (unless (> val 0) (with-output-chaos-error ('invalid-rule-number) (princ "rule index must be greater than 0.") )) val) (let* ((fwd (eql #\+ (char tok 0))) (rev (eql #\- (char tok 0))) (i (if (or rev fwd) 1 0)) (dot-pos (position-if #'(lambda (x) (char= #\. x)) tok))) (if dot-pos (list (subseq tok i dot-pos) (subseq tok (1+ dot-pos)) rev) (list "" (subseq tok i) rev))))) ||# (defun parse-rule-spec (tok) (declare (type string tok)) (let* ((fwd (eql #\+ (char tok 0))) (rev (eql #\- (char tok 0))) (i (if (or rev fwd) 1 0)) (dot-pos (position-if #'(lambda (x) (char= #\. x)) tok))) (if dot-pos (list (subseq tok i dot-pos) (subseq tok (1+ dot-pos)) rev) (list "" (subseq tok i) rev)))) ;;; get-apply-where : -> where keyword ;;; ::= { at | within } ;;; (defun get-apply-where (where) (if (equal where "at") :at (if (equal where "within") :within (with-output-chaos-error ('invalid-apply-place) (format t " must be either \"at\" or \"within\", but ~a is specified" where))))) ;;; parse-apply-command ;;; parse whole form (defun parse-apply-command (e) (when (equal '(("?")) (cdr e)) (return-from parse-apply-command (%apply* :help nil nil nil nil))) (let* ((ee (cadr e)) ; eliminate "apply" and the last "." (act (nth 0 ee))) (let* ((action (get-apply-action act)) (rule-spec (if (eq action :apply) (parse-rule-spec act)))) (let* ((no-subst (stringp (nth 1 ee))) ; "at" "within" -- no substitution. (substtoks (if no-subst nil (nth 1 ee))) ; we don't syntactic check here. (where-spec (get-apply-where (nth (if no-subst 1 2) ee))) (selectors (get-selectors (car (subseq ee (if no-subst 2 3)))))) (%apply* action rule-spec substtoks where-spec selectors))))) ;;; EOF cafeobj-1.6.0/thstuff/basics.lisp0000644000000000000000000006222413373141170015554 0ustar rootwheel;;;-*- Mode:LISP; Package:CHAOS; Base:10; Syntax:Common-lisp -*- ;;; ;;; Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. ;;; ;;; Redistribution and use in source and binary forms, with or without ;;; modification, are permitted provided that the following conditions ;;; are met: ;;; ;;; * Redistributions of source code must retain the above copyright ;;; notice, this list of conditions and the following disclaimer. ;;; ;;; * Redistributions in binary form must reproduce the above ;;; copyright notice, this list of conditions and the following ;;; disclaimer in the documentation and/or other materials ;;; provided with the distribution. ;;; ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ;;; (in-package :chaos) #|============================================================================== System: CHAOS Module: thstuff File: basics.lisp ==============================================================================|# #-:chaos-debug (declaim (optimize (speed 3) (safety 0) #-GCL (debug 0))) #+:chaos-debug (declaim (optimize (speed 1) (safety 3) #-GCL (debug 3))) ;;; === Common Basic Functions for APPLY family ;;; ------------------------------------------------------------------------ ;;; ***** ;;; UTILS ;;; ***** (defun check-apply-context (mod) (unless (check-$$term-context mod) (with-output-chaos-warning () (format t "the target term : ") (print-chaos-object $$term) (print-next) (format t "isn't proper in the context : ") (print-chaos-object mod) (print-next) (format t "please re-`start' with supplying new one!") (throw 'apply-context-error nil)))) (defun command-display () (if $$action-stack (format t "~%-- condition(~s) " (length $$action-stack)) (format t "~&result ")) (disp-term $$term)) (defun command-final () (when $$action-stack ;; $$action-stack == list of ;; ($$term term rule condition rhs-instance sort) ;; 0 1 2 3 4 (if (term-is-similar? $$term *bool-true*) (progn (command-display) (format t "~%-- condition is satisfied, applying rule") (format t "~&-- shifiting focus back to previous context") (let ((cur (car $$action-stack))) (setq $$term (car cur)) (term-replace (nth 1 cur) (nth 4 cur)) (setq $$action-stack (cdr $$action-stack))) t) (if (term-is-similar? $$term *bool-false*) (progn (command-display) (format t "~%-- condition is not satisfied, rule not applied") (format t "~&-- shifting focus back to previous context") (setq $$term (caar $$action-stack)) (setq $$action-stack (cdr $$action-stack)) t) nil)))) (defun disp-term (x) (with-in-module ((get-context-module)) (term-print x) (princ " : ") (print-sort-name (term-sort x) *current-module*))) (defun disp-term* (x) (term-print x) (princ " : ") (print-sort-name (term-sort x) *current-module*)) ;;; ;;; apply-help ;;; (defun apply-help () (format t "~%Apply a selected rule, possibly with an instantiation,") (format t " to selected subterm(s).") (format t "~&Syntax:") (format t "~& apply { reduction | red | print | bred | exec | [ ] }") (format t "~& { at | within } ") (format t "~& ::= [ + | - ] [.]") (format t "~& ::= | ") (format t "~& ::= with = { , = }*") (format t "~& ::= top | term | subterm | { of }* .") (format t "~& ::= (+) | `[' [ .. ] `]' |") (format t "~& `{' {, }* `}'") ) ;;; ******************* ;;; COMPUTING SELECTION ;;; ******************* (defun str-to-int (x) (if (equal "" x) 0 (read-from-string x))) (defun !make-right-associative (method subs) (if (null (cdr subs)) (car subs) (make-right-assoc-normal-form method subs))) ;;; ;;; ________________ (defun compute-occur-selection (sort term occs) (let ((cursrt sort) (cur term)) (dolist (i occs) (if (and (<= 0 i) (<= i (length (term-subterms cur)))) (unless (zerop i) (setq cursrt (nth (1- i) (method-arity (term-head cur)))) (setq cur (nth (1- i) (term-subterms cur)))) (with-output-chaos-warning () (format t "no such occurrenct, occurrence ~a is not correct for term :" occs) (print-next) (term-print term) (print-next) (format t "ignoring it.") (return-from compute-occur-selection (values sort term))))) (values cursrt cur) )) ;;; ;;; _________________ ;;; compute-subseq-selection : sort term m n ;;; ;;; ::= [ m .. n ] | [ m ] ;;; - case [ m ] --> [ m .. m ] ;;; (defun compute-subseq-selection (sort term m1 n1) (let ((m (1- m1)) ; *note* sequence specifier is 1 origin. (n (1- n1))) (if (term-is-variable? term) (with-output-chaos-warning () (format t "found variable in selection of subsequence selection : ") (term-print term) (values sort term)) (let ((method (term-head term))) ;; [ ... ] is meaningful only for associative operators. (if (method-is-associative method) (let ((lst (list-assoc-subterms term method))) (if (and (<= m n) (<= 1 m1) (<= n1 (length lst))) (if (or (< 1 m1) (< n1 (length lst))) (let ((res (!make-right-associative method (subseq lst m (1+ n))))) (term-replace term (!make-right-associative method (append (subseq lst 0 m) (list res) (subseq lst (1+ n))))) (values (car (method-arity method)) res)) (values sort term)) (with-output-chaos-warning () (format t "selection [~a .. ~a] is out of range for term :~% " m1 n1) (term-print term) (print-next) (format t "selected the whole subterms instead.") (values sort term) ))) (with-output-chaos-warning () (format t "found non-associative operator in selection of subsequence slection : ~% ") (print-chaos-object method) (values sort term))))))) ;;; ;;; _________________ (defun compute-subset-selection (sort term occs) (if (term-is-variable? term) (with-output-chaos-warning () (format t "found variable in subset selection ~a: " occs) (term-print term) (print-next) (format t "ignoring the selection and select whole subterms instead.") (values sort term)) (let ((method (term-head term))) (if (and (method-is-associative method) (method-is-commutative method)) (let ((lst (list-AC-subterms term method))) (let ((len (length lst)) (sel nil) (rest nil) (err nil)) (dolist (i occs) (let ((n (1- i))) (if (and (<= 0 n) (< n len)) (let ((tl (nthcdr n lst))) (when (car tl) (push (car tl) sel)) (rplaca tl nil)) (push i err)))) (dolist (x lst) (when x (push x rest))) (when err (with-output-chaos-warning () (princ "found out of range in selection of subterms") (print-next) (format t "ignoring these selections : ~a" err))) (if (null rest) (values sort term) (let ((res (!make-right-associative method (nreverse sel)))) (term-replace term (!make-right-associative method (cons res (reverse rest)))) (values (car (method-arity method)) res) )))) (with-output-chaos-warning () (princ "subset selection is meaningful only for associative and commuteative operators,") (print-next) (format t "but : ") (print-chaos-object method) (princ " is not.") (print-next) (princ "ignoreing the selection and select whole subterms instead.") (values sort term))) ))) ;;; compute-set-ocs ;;; ("{" "1" "," "2" "," "4" "}") --> (1 2 4) ;;; (defun compute-set-ocs (x) (let ((res nil) (val nil)) (setq x (cdr x)) (do ((elt x (cddr elt))) ((endp elt) (nreverse res)) (setq val (str-to-int (car elt))) (pushnew val res)))) ;;; top-level interface ;;; ******************* (defvar *selection-target* nil) (declaim (special *selection-target*)) (defun compute-selection (tm sel) (let ((*selection-target* tm)) (!compute-selection *cosmos* tm (if (consp sel) (if (equal (car (last sel)) ".") (butlast sel) sel) sel)))) ;;; !compute-selection ;;; the main computing selections ;;; (defun !compute-selection (sort tm sel) ;; no selection (unless sel (return-from !compute-selection (if (not (term-eq $$term *selection-target*)) (values sort *selection-target*) (values sort $$term)))) ;; whole term (when (memq sel '(:term :top)) (return-from !compute-selection (values sort $$term))) ;; subterm (when (eq sel :subterm) (if $$subterm (return-from !compute-selection (values sort $$subterm)) (progn (with-output-chaos-warning () (format t "no subterm is specified yet, please `choose' some.") (print-next) (format t "selected the whole term.")) (values sort $$term)))) ;; (!compute-selection-aux sort tm (cons (car sel) (cadr sel)))) (defun !compute-selection-aux (sort tm sel) (unless sel (return-from !compute-selection-aux (if (not (term-eq *selection-target* $$term)) (values sort *selection-target*) (values sort $$term)))) ;; of (when (equal "of" (car sel)) (return-from !compute-selection-aux (!compute-selection-aux sort tm (cdr sel)))) ;; (case-equal (caar sel) ("(" ;; occur selection (when (equal ")" (cadr (car sel))) (return-from !compute-selection-aux (!compute-selection-aux sort tm (cdr sel)))) (multiple-value-bind (s1 t1) (!compute-selection-aux sort tm (cdr sel)) (return-from !compute-selection-aux (compute-occur-selection s1 t1 (mapcar #'str-to-int (cadr (car sel))))))) ("[" ;; subseq selection { [ m .. n ] | [ m ] } (let ((i1 (str-to-int (cadr (car sel))))) (multiple-value-bind (s1 t1) (!compute-selection-aux sort tm (cdr sel)) (compute-subseq-selection s1 t1 i1 (if (equal "]" (nth 2 (car sel))) ;; case [ m ] i1 ;; case [ m .. n ] (str-to-int (cadr (nth 2 (car sel))))))))) ("{" ;; subset selection (multiple-value-bind (s1 t1) (!compute-selection-aux sort tm (cdr sel)) (compute-subset-selection s1 t1 (compute-set-ocs (car sel))))) (t (break "SNARK: !compute-selection")))) ;;; ************** ;;; Utils on TERMS ;;; ************** (defun @copy-list-term-using-list-var (term-list list-new-var) (declare (type list term-list list-new-var) (values list list)) (let ((v-image nil) (list-copied-term nil)) (values (mapcar #'(lambda (term) (cond ((term-is-variable? term) (if (setq v-image (cdr (assoc term list-new-var :test #'variable-equal))) v-image (let ((new-var (variable-copy term))) (declare (type term new-var)) (setf list-new-var (acons term new-var list-new-var)) new-var ))) ((term-is-builtin-constant? term) term) ((term-is-lisp-form? term) term) (t (multiple-value-setq (list-copied-term list-new-var) (@copy-list-term-using-list-var (term-subterms term) list-new-var)) (make-applform (term-sort term) (term-head term) list-copied-term)))) term-list) list-new-var))) ;;; @COPY-TERM-USING-VARIABLE : term List[variable] -> term ;;; (defun @copy-term-using-variable (term list-new-var) (declare (type term term) (type list list-new-var) (values term)) (multiple-value-bind (res list-new-var-res) (@copy-list-term-using-list-var (list term) list-new-var) (declare (ignore list-new-var-res) (type list res)) (car res))) #|| (defun @copy-term (term) (simple-copy-term term)) ||# (defun @copy-term (term) (let ((vars (term-variables term))) ;; (print vars) (if vars (@copy-term-using-variable term nil) (simple-copy-term term)))) (defun @matcher (pat term type) (if (term-is-variable? pat) (if (sort<= (term-sort term) (variable-sort pat) (module-sort-order *current-module*)) (values nil (list (cons pat term)) nil nil) (values nil nil t nil)) (if (term-is-lisp-form? pat) (values nil nil t nil) (if (eq type :match) (first-match pat term) (first-unify pat term))))) (defun @test-rule-direct (rul term type) (multiple-value-bind (gs sub no eeq) (@matcher (axiom-lhs rul) term type) (declare (ignore gs sub eeq)) (null no))) (defvar *-inside-apply-with-extensions-* nil) (defun @test-rule (rule term &optional (type :match)) (multiple-value-bind (gs sub no-match eeq) (@matcher (axiom-lhs rule) term type) (declare (ignore gs sub eeq)) (if (and no-match (and *-inside-apply-with-extensions-* (not (or (term-is-variable? term) (term-is-builtin-constant? term))) (method-is-of-same-operator (term-head (axiom-lhs rule)) (term-head term)))) (@test-rule-extensions rule term type) (null no-match)))) (defun @make-ac-pattern (top term) (let ((newvar (make-variable-term *cosmos* 'ac-pat))) (make-right-assoc-normal-form top (cons newvar (list-assoc-subterms term (term-head term)))))) (defun @make-a-patterns (top term) (let ((new-var1 (make-variable-term *cosmos* 'a-pat1)) (new-var2 (make-variable-term *cosmos* 'a-pat2))) (list (make-right-assoc-normal-form top (cons new-var1 (list-assoc-subterms term (term-head term)))) (make-right-assoc-normal-form top (append (list-assoc-subterms term (term-head term)) (list new-var1))) (make-right-assoc-normal-form top (list new-var2 term new-var1))))) (defun @pat-match (pat term &optional (type :match)) (declare (type term pat term)) (multiple-value-bind (gs sub no-match eeq) (@matcher pat term type) (declare (type global-state gs) (type substitution sub) (type (or null t) no-match eeq)) (unless no-match (return-from @pat-match (values t sub))) (if (and (term-is-application-form? term) (term-is-application-form? pat) (method-is-of-same-operator (term-head pat) (term-head term))) (let ((top (term-head pat))) (declare (type method top)) (if (method-is-associative top) (dolist (npat (if (method-is-commutative top) (list (@make-ac-pattern top pat)) (@make-a-patterns top pat)) (values nil nil)) (when (and npat (progn (multiple-value-setq (gs sub no-match eeq) (@matcher npat term type)) (null no-match))) (return (values t sub)))) (values nil nil)))))) ;;; ;;; FOR := ;;; (declaim (special *m-pattern-subst*)) (defun match-m-pattern (pat term) (declare (type term pat term) (optimize (speed 3) (safety 0))) (multiple-value-bind (res subst) (@pat-match pat term) (when res (dolist (sub subst) (push sub *m-pattern-subst*)) (return-from match-m-pattern t)) nil)) (defun @test-rule-extensions (rule term type) (let ((top (term-head (axiom-lhs rule)))) (if (method-is-associative top) (dolist (r (if (method-is-commutative top) (compute-AC-extension rule top) (compute-A-extensions rule top)) nil) (when (and r (@test-rule-direct r term type)) (return t))) nil))) ;;; ********************* ;;; VARIABLE SUBSTITUTION ;;; ********************* ;;; COMPUTE-VARIABLE-SUBSTITUTION ;;; (defun compute-variable-substitution (rule substtoks) ;; rule just for vars (let ((vars (union (term-variables (axiom-lhs rule)) (union (term-variables (axiom-rhs rule)) (term-variables (axiom-condition rule))))) (sub nil) varnm trmtoks avar aterm) (with-in-module ((get-context-module)) (loop (when (null substtoks) (return)) ;; = (setq varnm (cadr substtoks)) (setq trmtoks (nth 3 substtoks)) (setq avar (find-if #'(lambda (x) (equal (string (variable-name x)) varnm)) vars)) (setq aterm (simple-parse *current-module* trmtoks *cosmos*)) (if (and avar (not (term-is-an-error aterm))) (progn (if (not (is-in-same-connected-component (term-sort aterm) (variable-sort avar) *current-sort-order*)) (with-output-chaos-warning () (princ "sort of term is incompatible with variable sort") (print-next) (format t "variable ~a:" (string (variable-name avar))) (print-sort-name (variable-sort avar)) (print-next) (princ "term ") (print-chaos-object aterm) (princ ":") (print-sort-name (term-sort aterm))) (push (cons avar aterm) sub))) (with-output-chaos-error ('invalid-subst) (unless avar (format t "No such variable in rule: ~s" varnm) (print-next) (princ "specified substitution contains an error") ))) (setq substtoks (cddddr substtoks)))) sub)) ;;; ********************** ;;; FINDING MATCHING RULES ;;; ********************** (defstruct found-pattern rule-num direction rule subst extra occur) (defun get-subterm-pos (term pos) (let ((cur term)) (when pos (dolist (p pos) (let ((rp (1- p))) (when (>= rp 0) (setq cur (term-arg-n cur rp))) (unless cur (with-output-panic-message () (format t "could not find subterm at pos ~d" pos) (format t "~% target was ") (term-print term) (break "wow!") (chaos-error 'panic)))))) cur)) (defun find-matching-rules-all (what target module &optional (type :match) (start-pos nil)) (with-in-module (module) (when start-pos (setq target (get-subterm-pos target start-pos))) (find-matching-rules-all* what target module type start-pos))) (defun find-matching-rules-all* (what target module type pos) (let ((result (find-matching-rules what target module type))) (dolist (r result) (setf (found-pattern-occur r) pos)) (dotimes (x (length (term-subterms target))) (let ((r (find-matching-rules-all* what (term-arg-n target x) module type (append pos (list (1+ x)))))) (when r (setq result (nconc result r))))) ;; result)) (defun find-matching-rules (what target module &optional (type :match)) (with-in-module (module) (let* ((*module-all-rules-every* t) (rules (get-module-axioms *current-module* t)) (res nil)) (do* ((rls rules (cdr rls)) (rule (car rls) (car rls)) (num 1 (1+ num))) ((endp rls)) (when (or (eq what :rule) (eq what :+rule)) (multiple-value-bind (match subst) (@pat-match (axiom-lhs rule) target type) (when match (push (make-found-pattern :rule-num num :direction :+rule :rule rule :subst subst :extra (compute-extra-variables rule :+rule)) res)))) (when (and (or (eq what :rule) (eq what :-rule)) (not (eq (axiom-type rule) :rule)) (not (rule-is-builtin rule))) (multiple-value-bind (match subst) (@pat-match (axiom-rhs rule) target type) (when match (push (make-found-pattern :rule-num num :direction :-rule :rule rule :subst subst :extra (compute-extra-variables rule :-rule)) res))))) (nreverse res)))) (defun compute-extra-variables (rule direction) (let ((lhs (axiom-lhs rule)) (rhs (axiom-rhs rule)) (condition (axiom-condition rule))) (when (eq direction ':-rule) (setq lhs rhs) (setq rhs lhs)) (let* ((lvars (term-variables lhs)) (rvars (union (term-variables rhs) (term-variables condition)))) (nset-difference rvars lvars)))) ;;; EOF cafeobj-1.6.0/thstuff/eval-apply.lisp0000644000000000000000000004506713373141170016370 0ustar rootwheel;;;-*- Mode:LISP; Package:CHAOS; Base:10; Syntax:Common-lisp -*- ;;; ;;; Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. ;;; ;;; Redistribution and use in source and binary forms, with or without ;;; modification, are permitted provided that the following conditions ;;; are met: ;;; ;;; * Redistributions of source code must retain the above copyright ;;; notice, this list of conditions and the following disclaimer. ;;; ;;; * Redistributions in binary form must reproduce the above ;;; copyright notice, this list of conditions and the following ;;; disclaimer in the documentation and/or other materials ;;; provided with the distribution. ;;; ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ;;; (in-package :chaos) #|============================================================================== System: CHAOS Module: thstuff File: eval-apply.lisp ==============================================================================|# #-:chaos-debug (declaim (optimize (speed 3) (safety 0) #-GCL (debug 0))) #+:chaos-debug (declaim (optimize (speed 1) (safety 3) #-GCL (debug 3))) ;;; ***** ;;; START ;;; ***** (defun eval-start-command (ast) (do-eval-start-th (%start-target ast) (get-context-module))) (defun do-eval-start-th (pre-term &optional context) (catch 'apply-context-error (let ((mod (if context (eval-modexp context) (get-context-module)))) (if (or (null mod) (modexp-is-error mod)) (if (null mod) (with-output-chaos-error ('invalid-module) (princ "no module expression provided and no current module.")) (with-output-chaos-error ('invalid-module) (format t "incorrect module expression: ~a" context))) (if pre-term (with-in-module (mod) (prepare-for-parsing *current-module*) (cond ((or (equal pre-term '("$$term")) (equal pre-term '("$$subterm"))) (let ((target nil)) (catch 'term-context-error (setq target (get-bound-value (car pre-term)))) (unless target (return-from do-eval-start-th nil)) (setq $$action-stack nil) (reset-reduced-flag target) (reset-target-term target *current-module* mod))) (t (let ((*parse-variables* nil)) (let ((res (simple-parse *current-module* pre-term *cosmos*))) (when (term-is-an-error res) (return-from do-eval-start-th nil)) (setq $$action-stack nil) (reset-target-term res *current-module* mod)))))) ;; try use $$term (progn (when (or (null $$term) (eq 'void $$term)) (with-output-chaos-warning () (format t "no target term is given!") (return-from do-eval-start-th nil))) (check-apply-context mod) (setq $$action-stack nil) (reset-reduced-flag $$term) (reset-target-term $$term (get-context-module) mod)))) (when (command-final) (command-display)) t))) ;;; ****** ;;; CHOOSE ;;; ****** (defun eval-choose-command (ast) (unless $$subterm (setq $$subterm $$term)) (unless $$subterm (with-output-chaos-warning () (format t "no target term is specified yet.") (print-next) (princ "please set the target term by `start' command.") (return-from eval-choose-command nil))) (let ((selectors (%choose-selectors ast))) (when (eq selectors ':top) (setq $$subterm $$term) (setq $$selection-stack nil) (return-from eval-choose-command nil)) (with-in-module ((get-context-module)) (multiple-value-bind (subterm-sort subterm) (compute-selection $$subterm selectors) (declare (ignore subterm-sort)) (push selectors $$selection-stack) (setq $$subterm subterm))))) ;;; ************* ;;; INSPECT-TERM ;;; ************* (defun eval-inspect-term-command (&optional ast) (declare (ignore ast)) (unless $$subterm (setq $$subterm $$term)) (unless $$subterm (with-output-chaos-warning () (format t "no target term is specified yet.") (print-next) (princ "please set the target term by `choose' command.") (return-from eval-inspect-term-command nil))) (inspect-term $$subterm)) ;;; ***** ;;; APPLY ;;; ***** (defvar *-applied-* nil) (defvar *-inside-apply-all-* nil) ;;; top-level evaluator (defun eval-apply-command (ast) (let ((action (%apply-action ast)) (rule-spec (%apply-rule-spec ast)) (substitution (%apply-substitution ast)) (where-spec (%apply-where-spec ast)) (selectors (%apply-selectors ast))) (catch 'apply-context-error (when (eq action :help) (apply-help) (return-from eval-apply-command nil)) ;; check some evaluation env (when (or (null $$term) (eq 'void $$term)) (with-output-chaos-error ('invalid-term) (princ "term to be applied is not defined."))) ;; real work begins here ------------------------------ (with-in-module ((get-context-module)) (multiple-value-bind (subterm-sort subterm) (compute-selection $$term selectors) (setq *-applied-* t) (case action (:reduce ; full reduction on selections. (!setup-reduction *current-module*) (let ((*rewrite-semantic-reduce* (module-has-behavioural-axioms *current-module*)) (*rewrite-exec-mode* nil)) (term-replace subterm (@copy-term subterm)) (reset-reduced-flag subterm) (rewrite subterm *current-module*))) (:breduce (!setup-reduction *current-module*) (let ((*rewrite-semantic-reduce* nil) (*rewrite-exec-mode* nil)) (term-replace subterm (@copy-term subterm)) (reset-reduced-flag subterm) (rewrite subterm *current-module*))) (:exec (!setup-reduction *current-module*) (let ((*rewrite-semantic-reduce* (module-has-behavioural-axioms *current-module*)) (*rewrite-exec-mode* t)) (term-replace subterm (@copy-term subterm)) (reset-reduced-flag subterm) (rewrite subterm *current-module*))) ;; (:print ; print selections. (format t "~%term ") (disp-term subterm) (format t "~&tree form") (print-term-tree subterm)) (:apply ; apply specified rule. (setq *-applied-* nil) (let* ((actrule (compute-action-rule rule-spec substitution selectors)) (*-inside-apply-with-extensions-* (and (let ((arlhs (rule-lhs actrule))) (and (term-is-application-form? arlhs) (method-is-associative (term-head arlhs))))))) (if (eq :within where-spec) (let ((*-inside-apply-all-* t)) (catch 'apply-all-quit (@apply-all actrule subterm-sort subterm))) (@apply-rule actrule subterm-sort subterm))) (when *-applied-* (update-lowest-parse $$term) (when (nth 2 rule-spec) ; reverse order (setq $$term (@copy-term $$term))) (reset-target-term $$term *current-module* *current-module*))) ; end :apply (t (with-output-panic-message () (format t "unknown apply action : ~a" action) (chaos-error 'unknown-action)))) ;; (unless *-applied-* (with-output-chaos-warning () (princ "rule not applied"))) ;; (command-final) (command-display)))))) (defvar *copy-conditions*) (declaim (special *copy-conditons*)) (defvar *apply-debug* nil) (defun @apply-one-rule (rule sort term) (when *apply-debug* (princ "* @apply-one-rule : rule = ") (print-chaos-object rule) (format t "~%- sort = ") (print-sort-name sort) (format t "~&- term = ") (term-print term)) (let ((*self* term)) (let ((cond (rule-condition rule))) (if (or *reduce-conditions* (is-true? cond)) (let ((lhs (rule-lhs rule))) (if (term-is-variable? lhs) (multiple-value-bind (gs sub no eeq) (@matcher lhs (@copy-term term) :match) ; why? (declare (ignore gs)) (when eeq (setq sub nil)) (unless (or no (and (not (is-true? cond)) (not (is-true? (!normalize-term (@copy-term (substitution-image! sub cond))))))) (setq *-applied-* t) (term-replace-dd-simple term (@copy-term (substitution-image! sub (rule-rhs rule)))))) (let ((*copy-conditions* t)) (let ((res (apply-one-rule-no-simplify rule term))) (when res (term-replace-dd-simple term (@copy-term term)) (setq *-applied-* t)) ))) term) ;; "recurse" on condition (let ((lhs (rule-lhs rule)) (rhs (rule-rhs rule))) (multiple-value-bind (gs sub no eeq) (@matcher lhs (@copy-term term) :match) (declare (ignore gs)) (when eeq (setq sub nil)) (unless no (setq *-applied-* t) (format t "~%shifting focus to condition") (force-output) (let ((cond-inst (@copy-term (substitution-image! sub cond))) (rhs-inst (@copy-term (substitution-image! sub rhs)))) (setq $$action-stack (cons (list $$term term rule cond-inst rhs-inst sort) $$action-stack)) (setq $$term cond-inst) (when *-inside-apply-all-* (format t "~%-- applying rule only at first position found: ") (term-print term) (force-output) (throw 'apply-all-quit nil)))))))))) ;;; APPLY-ONE-RULE-NO-SIMPLIFY (rule term) ;;; (defun apply-one-rule-no-simplify (rule term) (when *apply-debug* (with-output-simple-msg () (princ "[apply]: rule = ") (print-chaos-object rule) (print-next) (princ " term = ") (print-chaos-object term))) (block the-end (let ((condition nil) next-match-method ;; (*do-unify* t) (*self* term)) (multiple-value-bind (global-state subst nomatch Eequal) (funcall (rule-first-match-method rule) (rule-lhs rule) term) (when nomatch (return-from the-end nil)) (when *apply-debug* (format t "~%[apply-one-rule] : ") (format t "~% subst = ") (print-substitution subst) (format t "~% Eequal = ~a" eequal)) ;; technical assignation related to substitution$image (when Eequal (setq subst nil)) ;; the condition must be checked (block try-rule (catch 'rule-failure (when (is-true? (setq condition (rule-condition rule))) ;; there is no condition (term-replace-dd-simple term (if (rule-is-builtin rule) (multiple-value-bind (newterm success) (funcall (lisp-form-function (rule-rhs rule)) subst) (if success newterm (return-from try-rule nil))) ;; note that the computation of the substitution ;; made a copy of the rhs. (substitution-image! subst (rule-rhs rule)))) (return-from the-end t)))) ;; if the condition is not trivial, we enter in a loop ;; where one try to find a match such that the condition ;; is satisfied (setf next-match-method (rule-next-match-method rule)) (loop (when nomatch (return)) ; exit from loop (block try-rule (catch 'rule-failure (when (is-true? (let (($$cond (substitution-image ;; want to avoid recopying the whole (if *copy-conditions* (mapcar #'(lambda (x) (cons (car x) (@copy-term (cdr x)))) subst) subst) condition))) (!normalize-term $$cond))) ;; the condition is satisfied (term-replace-dd-simple term (if (rule-is-builtin rule) (multiple-value-bind (newterm success) (funcall (lisp-form-function (rule-rhs rule)) subst) (if success newterm (return-from try-rule nil))) (substitution-image! subst (rule-rhs rule)))) (return-from the-end t))) ) ; block try-rule ;; else, try another ... (multiple-value-setq (global-state subst nomatch) (funcall next-match-method global-state)) ) ; end loop ;; In this case there is no match at all and the rule does not apply (return-from the-end nil))))) (defun @apply-rule (rule sort term) (if (and *-inside-apply-with-extensions-* (term-is-application-form? term) (method-is-of-same-operator (term-head (rule-lhs rule)) (term-head term))) (@apply-rule-with-extensions rule sort term) (@apply-one-rule rule sort term))) (defun @apply-rule-with-extensions (rule sort term) (let ((top (term-head (rule-lhs rule)))) (if (method-is-associative top) (let ((is-applied nil) (is-AC (method-is-commutative top))) (when (@test-rule rule term) (@apply-one-rule rule sort term) (setq is-applied *-applied-*)) (unless is-applied (dolist (r (if is-AC (compute-AC-extension rule top) (compute-A-extensions rule top))) (when (and r (@test-rule r term)) (@apply-one-rule r sort term) (setq is-applied *-applied-*) (return))))) ;; only hit this case if top of rule lhs wasn't associative (@apply-one-rule rule sort term))) nil) ;;; ;;; @apply-all ;;; (defun @apply-all (rule sort term) (if (term-is-variable? term) (when (@test-rule rule term) (@apply-rule rule sort term)) (if (@test-rule rule term) (@apply-rule rule sort term) (if (term-is-application-form? term) (mapc #'(lambda (s x) (@apply-all rule s x)) (method-arity (term-head term)) (term-subterms term))))) nil) ;;; ;;; apply-print-rule ;;; (defun apply-print-rule (x) (unless x (format t "~%That dosen't make sense as a rule specification.") (return-from apply-print-rule t)) (let* ((act (get-apply-action x)) (rule-spec (if (eq act :apply) (parse-rule-spec x)))) ;; (if (eq :reduce act) (format t "~%special rule for reduction of a selected subterm.") (if (eq :print act) (format t "~%special rule to print-the selected subterm.") (progn (when (or (eq :error rule-spec) (null rule-spec)) (format t "~%That doesn't make sense as a rule specification.") (return-from apply-print-rule t)) (let ((num (cadr rule-spec)) (mod (car rule-spec)) (rev (caddr rule-spec))) (format t "~&rule ~a" num) (when rev (format t " (reversed)")) (if (equal "" mod) (format t " of the last module") (format t " of module ~a" mod)) (multiple-value-bind (rule module) (compute-action-rule rule-spec nil) (with-in-module (module) (format t "~& ") (print-chaos-object rule) (when (and rev (or (rule-is-builtin rule) (eq (axiom-type rule) :rule))) (format t "~%This rule cannot be applied reversed.")) (when (and (get-context-module t) (not (rule-is-builtin rule))) (format t "~%(This rule rewrites up.)")))))))) t)) ;;; EOF cafeobj-1.6.0/thstuff/case.lisp0000644000000000000000000000764213373141170015226 0ustar rootwheel;;;-*- Mode:LISP; Package:CHAOS; Base:10; Syntax:Common-lisp -*- ;;; ;;; Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. ;;; ;;; Redistribution and use in source and binary forms, with or without ;;; modification, are permitted provided that the following conditions ;;; are met: ;;; ;;; * Redistributions of source code must retain the above copyright ;;; notice, this list of conditions and the following disclaimer. ;;; ;;; * Redistributions in binary form must reproduce the above ;;; copyright notice, this list of conditions and the following ;;; disclaimer in the documentation and/or other materials ;;; provided with the distribution. ;;; ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ;;; (in-package :chaos) #|============================================================================== System: CHAOS Module: thstuff File: base.lisp ==============================================================================|# (defparameter .case-module-true. (%module-decl* "true-dummy" :object :user nil)) (defparameter .case-module-false. (%module-decl* "false-dummy" :object :user nil)) (defparameter .case-true-axiom. (%axiom-decl* :equation '(":case_true") :LHS '("true") nil nil)) (defparameter .case-false-axiom. (%axiom-decl* :equation '(":case_false") :LHS '("false") nil nil)) (defun perform-case-reduction (ast) (let ((bool-term (%scase-bool-term ast)) (module (%scase-module ast)) (name (%scase-name ast)) (body (parse-module-elements (%scase-body ast))) (goal-term (%scase-goal-term ast))) ;; prepare modules (setf (%module-decl-name .case-module-true.) (concatenate 'string name "-#T")) (setf (%module-decl-name .case-module-false.) (concatenate 'string name "-#F")) ;; (push (%import* :including (parse-modexp module)) body) (push (%import* :including module) body) (setf (%axiom-decl-lhs .case-true-axiom.) bool-term) (setf (%module-decl-elements .case-module-true.) (append body (list .case-true-axiom.))) (setf (%axiom-decl-lhs .case-false-axiom.) bool-term) (setf (%module-decl-elements .case-module-false.) (append body (list .case-false-axiom.))) ;; (let ((org-mod (eval-modexp module)) (true-mod (eval-ast .case-module-true.)) (false-mod (eval-ast .case-module-false.))) (when (modexp-is-error org-mod) (with-output-chaos-error ('no-such-module) (format t "No such module or invalid module expression ~s" module))) ;; CASE TRUE (with-in-module (true-mod) (compile-module *current-module*) ;; (with-output-simple-msg () (format t "===================~%") (format t ">>* CASE: true *<<~%") (format t "===================")) (perform-reduction* goal-term true-mod :red)) ;; CASE FALSE (with-in-module (false-mod) (compile-module *current-module*) ;; (with-output-simple-msg () (format t "===================~%") (format t ">>* CASE: false *<<~%") (format t "===================")) (perform-reduction* goal-term false-mod :red))))) ;;; EOF cafeobj-1.6.0/thstuff/citp.lisp0000755000000000000000000007451613575631653015277 0ustar rootwheel;;;-*-Mode:LISP; Package: CHAOS; Base:10; Syntax:Common-lisp -*- ;;; ;;; Copyright (c) 2000-2016, Toshimi Sawada. All rights reserved. ;;; ;;; Redistribution and use in source and binary forms, with or without ;;; modification, are permitted provided that the following conditions ;;; are met: ;;; ;;; * Redistributions of source code must retain the above copyright ;;; notice, this list of conditions and the following disclaimer. ;;; ;;; * Redistributions in binary form must reproduce the above ;;; copyright notice, this list of conditions and the following ;;; disclaimer in the documentation and/or other materials ;;; provided with the distribution. ;;; ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ;;; (in-package :chaos) #|============================================================================= System:CHAOS Module:thstuff File:citp.lisp =============================================================================|# #-:chaos-debug (declaim (optimize (speed 3) (safety 0) #-GCL (debug 0))) #+:chaos-debug (declaim (optimize (speed 1) (safety 3) #-GCL (debug 3))) (defun check-context-module () (unless *current-module* (with-output-chaos-error ('no-context) (format t "No context module is specified, please 'select' or 'open' a module.")))) (defun check-ptree () (unless *proof-tree* (with-output-chaos-error ('no-proof-tree) (format t "No proof is ongoing.")))) (defun check-on-going() (unless (and *proof-tree* (get-unproved-nodes *proof-tree*)) (with-output-chaos-error ('no-target) (format t "There are no unproved goals.")))) (defun check-context-module-and-ptree () (check-context-module) (check-ptree)) ;;; ============================ ;;; CITP related command parsers ;;; ============================ ;;; ;;; :goal { . . .... . } ;;; (defun citp-parse-goal (args) (let ((ax-decls nil)) (dolist (elem (third args)) (push (parse-module-element-1 elem) ax-decls)) (nreverse ax-decls))) ;;; ;;; :apply [to ] ( ...) ;;; ;;; (":apply" ("(" ("tc" "rd" "si") ")")) ;;; (":apply" ("to" ("1-1-1")) ("(" ("RD") ")")) ;;; (defun citp-parse-apply (args) (let ((tactic-forms nil) (tactics nil) (target nil)) (cond ((string-equal (car (second args)) "to") (setq target (car (second (second args)))) (setq tactic-forms (second (third args)))) (t (setq tactic-forms (second (second args))))) (dolist (tac tactic-forms) (let ((tactic (get-tactic tac))) (setq tactics (nconc tactics tactic)))) (cons target tactics))) ;;; citp-parse-ind-on ;;; :ind on (var ... var) ;;; (":ind" ("on" "(" ("A:S-1" "B:S-2" "C:S-3") ")")) ;;; (":ind" ("{" ("on" #1="(" ("L1:List") #2=")") ;;; ("base" #1# ("nil") "." nil #2#) ;;; ("step" #1# ("X:Elm" "T:List") "." nil #2#) "}")) ;;; (":ind" ("{" ("on" #1="(" ("S1:Seq") #2=")") ;;; ("base" #1# ("nil") "." nil #2#) ;;; ("hypo" #1# ("SQ:Seq") "." nil #2#) ;;; ("step" #1# ("EL:Elt" "SQ:Seq") "." nil #2#) "}")) (defun citp-parse-seq-of-terms (module token-list) (let ((terms nil)) (when (atom token-list) (return-from citp-parse-seq-of-terms nil)) (dolist (term? token-list) ;; (format t "~%<<>> ~s" term?) (when (consp term?) (let* ((*parse-variables* nil) (target-term (simple-parse module term? *cosmos*))) (when (or (null (term-sort target-term)) (sort<= (term-sort target-term) *syntax-err-sort* *chaos-sort-order*)) (with-output-chaos-error ('invalid-term) (format t "Could not parse ~s" term?))) (push target-term terms)))) (nreverse terms))) (defun citp-parse-ind-on (args) (check-context-module) (with-in-module (*current-module*) (let ((ind-type (first (second args)))) (flet ((parse-vars (decls) (let ((vars nil)) (dolist (var-decl decls) (let ((var (simple-parse-from-string var-decl))) (when (term-is-an-error var) (with-output-chaos-error ('no-parse) (format t "Illegal variable form: ~a" var-decl))) (unless (term-is-variable? var) (with-output-chaos-error ('no-var) (format t "Invalid argument to ':ind' command: ~a" var-decl))) (push var vars))) (nreverse vars)))) (if (equal ind-type "on") (let ((vars (parse-vars (third (second args))))) (cons :simple vars)) ;; :ind { on () base() [hypo ()] step() } (let* ((decl (second args)) (vars (parse-vars (third (second decl)))) (bases (citp-parse-seq-of-terms *current-module* (third decl))) (hypo (citp-parse-seq-of-terms *current-module* (fourth decl))) (steps (citp-parse-seq-of-terms *current-module* (fifth decl)))) (if steps (list :user vars bases hypo steps) (list :user vars bases nil hypo)))))))) ;;; ;;; :auto ;;; (defun citp-parse-auto (args) (declare (ignore args)) (cons :auto (get-default-tactics))) ;;; ;;; :roll back ;;; (defun citp-parse-roll-back (args) (declare (ignore args)) :roll-back) ;;; ;;; :init {[